Added a Cocoa library exporting some useful Cocoa stuff.

lab/objc/Cocoa.ss

@@ -0,0 +1,52 @@
+
+(library (Cocoa)
+  (export) ; below
+  (import (ikarus) (objc))
+
+  (define-syntax define-and-export
+    (syntax-rules ()
+      [(_ (def* name* . rest*) ...)
+       (begin
+         (def* name* . rest*) ...
+         (export name* ...))]))
+
+  (define-and-export
+    (define-framework Cocoa)
+    (define-class NSAutoreleasePool)
+    (define-class NSWindow)
+    (define-class NSApplication)
+    (define-class NSString)
+    (define-object NSApp Cocoa)
+    
+    (define NSBorderlessWindowMask         #b000000000)
+    (define NSTitledWindowMask             #b000000001)
+    (define NSClosableWindowMask           #b000000010)
+    (define NSMiniaturizableWindowMask     #b000000100)
+    (define NSResizableWindowMask          #b000001000)
+    (define NSTexturedBackgroundWindowMask #b100000000)
+    
+    (define NSBackingStoreRetained     0)
+    (define NSBackingStoreNonretained  1)
+    (define NSBackingStoreBuffered     2)
+    
+    (define NSASCIIStringEncoding 1)   ; /* 0..127 only */
+    (define NSNEXTSTEPStringEncoding 2)
+    (define NSJapaneseEUCStringEncoding 3)
+    (define NSUTF8StringEncoding 4)
+    (define NSISOLatin1StringEncoding 5)
+    (define NSSymbolStringEncoding 6)
+    (define NSNonLossyASCIIStringEncoding 7)
+    (define NSShiftJISStringEncoding 8)
+    (define NSISOLatin2StringEncoding 9)
+    (define NSUnicodeStringEncoding 10)
+    (define NSWindowsCP1251StringEncoding 11) ;   /* Cyrillic; same as AdobeStandardCyrillic */
+    (define NSWindowsCP1252StringEncoding 12) ;   /* WinLatin1 */
+    (define NSWindowsCP1253StringEncoding 13) ;   /* Greek */
+    (define NSWindowsCP1254StringEncoding 14) ;   /* Turkish */
+    (define NSWindowsCP1250StringEncoding 15) ;   /* WinLatin2 */
+    (define NSISO2022JPStringEncoding 21)     ;    /* ISO 2022 Japanese encoding for e-mail */
+    (define NSMacOSRomanStringEncoding 30)
+    (define NSProprietaryStringEncoding 65536)  ;  /* Installation-specific encoding */
+    
+  ))
+

lab/objc/hello-cocoa.ss

@@ -1,47 +1,36 @@
 #!/usr/bin/env ikarus --r6rs-script
-;;; vim:syntax=scheme
-(import (ikarus) (objc))
-
-(define-framework Cocoa)
-(define-class NSAutoreleasePool)
-(define-class NSWindow)
-(define-class NSApplication)
-(define-object NSApp Cocoa)
 
+(import (ikarus) (objc) (Cocoa))
 
 (define pool [$ [$ NSAutoreleasePool alloc] init])
+
 [$ NSApplication sharedApplication]
 
-(define NSBorderlessWindowMask         #b000000000)
-(define NSTitledWindowMask             #b000000001)
-(define NSClosableWindowMask           #b000000010)
-(define NSMiniaturizableWindowMask     #b000000100)
-(define NSResizableWindowMask          #b000001000)
-(define NSTexturedBackgroundWindowMask #b100000000)
-
-(define NSBackingStoreRetained     0)
-(define NSBackingStoreNonretained  1)
-(define NSBackingStoreBuffered     2)
-
 (define style
   (bitwise-ior 
+    NSTitledWindowMask
     NSClosableWindowMask 
     NSResizableWindowMask
-    NSTexturedBackgroundWindowMask
-    NSTitledWindowMask
     NSMiniaturizableWindowMask))
 
 (define backing NSBackingStoreBuffered)
 
-(define win [$ [$ NSWindow alloc]
+(define win 
-               initWithContentRect: '#(#(50 50) #(600 400))
+  [$ [$ NSWindow alloc]
-               styleMask: style
+     initWithContentRect: '#(#(50 50) #(600 400))
-               backing: backing
+     styleMask: style
-               defer: #f])
+     backing: backing
+     defer: #f])
+
+(define (nsstring x)
+  [$ [$ NSString alloc]
+     initWithCharactersNoCopy: x
+     length: (string-length x)
+     freeWhenDone: #t])
+
+[$ win setTitle: (nsstring "Hello Ikarus")]
 
 [$ win makeKeyAndOrderFront: win]
 
 [$ NSApp run]
 [$ pool release]
-
-

lab/objc/objc.ss

@@ -4,6 +4,7 @@
     define-framework
     define-class
     define-object
+    string->char*
     $)
   (import 
     (ikarus)
@@ -65,9 +66,36 @@
            (bytevector-u8-set! bv i (pointer-ref-uchar x i))
            (f (+ i 1))])))))
 
+(define (bv->char* x)
+  (let ([n (bytevector-length x)])
+    (let ([p (malloc (+ n 1))])
+      (pointer-set-char p n 0)
+      (let f ([i 0])
+        (cond
+          [(= i n) p]
+          [else
+           (pointer-set-char p i (bytevector-s8-ref x i))
+           (f (+ i 1))])))))
+
+(define (bv->u8* x)
+  (let ([n (bytevector-length x)])
+    (let ([p (malloc n)])
+      (let f ([i 0])
+        (cond
+          [(= i n) p]
+          [else
+           (pointer-set-char p i (bytevector-s8-ref x i))
+           (f (+ i 1))])))))
+
+
 (define (char*->string x)
   (utf8->string (char*->bv x)))
 
+(define (string->char* x)
+  (let ([bv (string->utf8 x)])
+    (bv->char* bv)))
+
+
 (define-syntax check
   (syntax-rules ()
     [(_ who pred expr)
@@ -293,6 +321,7 @@
              [(#\f) (values 'float (+ i 1))]
              [(#\i) (values 'int (+ i 1))]
              [(#\I) (values 'uint (+ i 1))]
+             [(#\S) (values 'ushort (+ i 1))]
              [(#\c) (values 'char (+ i 1))]
              [(#\{) ;;; struct
               (let ([i (scan (+ i 1) #\=)])
@@ -307,7 +336,12 @@
                                      (let-values ([(i ls) (f i)])
                                        (values i (cons x ls)))])))])
                   (values (list->vector ls) i)))]
-             [(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+             [(#\*) (values 'char* (+ i 1))]
+             [(#\^) 
+              (let-values ([(t i) (parse (+ i 1))])
+                (values (cons 'pointer t) i))]
+             [(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 
+               #\r)
               (values 'skip (+ i 1))]
              [else (error who "invalid char" c str)]))]))
     (define (cons/skip x y)
@@ -324,6 +358,7 @@
   (cond
     [(vector? x) 
      (vector-map objc-type->ikarus-type x)]
+    [(pair? x) 'pointer]
     [else
      (case x 
        [(selector) 'pointer]
@@ -333,6 +368,7 @@
        [(uint)     'uint32]
        [(int)      'sint32]
        [(char)     'sint8]
+       [(char*)    'pointer]
        [else (error 'objc-type->ikarus-type "invalid type" x)])]))
 
 
@@ -352,6 +388,14 @@
           (error 'convert-outgoing "length mismatch" x t))
         (vector-map convert-outgoing t x)]
        [else (error 'convert-output "not a vector" x)])]
+    [(and (pair? t) (eq? (car t) 'pointer))
+     (case (cdr t)
+       [(ushort) 
+        (cond
+          [(string? x) 
+           (bv->u8* (string->utf16 x 'little))]
+          [else (error 'convert-output "cannot convert to ushort*" x)])]
+       [else (error 'convert-output "dunno how to convert" t)])]
     [else
      (case t
        [(selector)
@@ -374,6 +418,10 @@
           [(or (fixnum? x) (bignum? x)) x]
           [(boolean? x) (if x 1 0)]
           [else (error 'convert-output "cannot convert to int" x)])]
+       [(char*) 
+        (cond
+          [(string? x) (string->char* x)]
+          [else (error 'convert-output "cannot convert to char*" x)])]
        [else (error 'convert-outgoing "invalid type" t)])]))