One can now create (at runtime) objective-c classes and add methods

to them to get them to do things.  See lab/objc-create-class.ss for
a cute example.

lab/hello-cocoa.ss

@@ -2,6 +2,11 @@
 
 (import (ikarus) (objc) (Cocoa) (Cocoa helpers))
 
+(define-class NSTableView)
+(define-class NSTableColumn)
+(define-class NSColor)
+(define-class NSButton)
+(define-class NSImageView)
 
 (define pool [$ [$ NSAutoreleasePool alloc] init])
 
@@ -55,14 +60,33 @@
 
 (define win 
   [$ [$ NSWindow alloc]
-     initWithContentRect: '#(#(50 50) #(600 400))
+     initWithContentRect: '#(#(400 500) #(400 500))
      styleMask: style
      backing: backing
      defer: #f])
 
 [$ win setTitle: (nsstring "Hello Ikarus")]
+;[$ win setAlphaValue: 3/4] ; cute
+
+#; ; button test
+(let ([btn [$ [$ NSButton alloc] init]])
+  [$ btn setTitle: (nsstring "Quit")]
+  [$ btn setTarget: NSApp]
+  [$ btn setAction: (get-selector "terminate:")]
+  [$ win setContentView: btn])
+
+#;
+(let ([table [$ [$ NSTableView alloc] init]])
+  [$ table setBackgroundColor: [$ NSColor blueColor]]
+  (printf "~s\n" [$ table headerView])
+
+  (let ([col [$ [$ NSTableColumn alloc] init]])
+    [$ table addTableColumn: col]
+    [$ [$ col headerCell] setStringValue: (nsstring "header")])
+  [$ win setContentView: table]
+  [$ win setDelegate: table])
+
 [$ win makeKeyAndOrderFront: win]
-;[$ win setAlphaValue: 0.5] ; cute
 
 [$ NSApp run]
 [$ pool release]

lab/objc-class.ss

@@ -0,0 +1,51 @@
+#!/usr/bin/env ikarus --r6rs-script
+
+(import (ikarus) (objc))
+
+(define-framework Cocoa)
+;(load-shared-object "IKFoo.dylib")
+
+(define who (car (command-line)))
+
+(define (println x) (printf "~a\n" x))
+
+(define (print-classes)
+  (for-each println 
+    (list-sort string<? 
+      (map class-name (get-class-list)))))
+
+(define (parents x)
+  (let ([p (class-parent x)])
+    (if p (cons p (parents p)) '())))
+
+(define (ivar-info x)
+  `(ivar name: ,(ivar-name x) 
+         type: ,(ivar-type x)
+         offset: ,(ivar-offset x)))
+
+(define (print-class-methods x)
+  (define (public? x)
+    (and (> (string-length x) 0)
+         (not (char=? (string-ref x 0) #\_))))
+  (let ([x (or (get-class x) (error who "cannot find class" x))])
+    (printf "instance size = ~s\n" (class-instance-size x))
+    (printf "parents = ~s\n"
+            (map (lambda (x) 
+                   (cons (class-name x) 
+                         (class-instance-size x)))
+                 (parents x)))
+    (printf "ivars=~s\n" (map ivar-info (class-ivars x)))
+    #;
+    (for-each println 
+      (list-sort string<? 
+        (filter public? 
+          (map method-name (class-methods x)))))))
+
+(apply
+  (case-lambda
+    [() (print-classes)]
+    [(x) (print-class-methods x)]
+    [args 
+     (error who "supply either 0 or 1 arguments")])
+  (cdr (command-line)))
+

lab/objc-create-class.ss

@@ -0,0 +1,17 @@
+#!/usr/bin/env ikarus --r6rs-script
+
+(import (ikarus) (objc))
+
+(define-framework Cocoa)
+(define-class NSObject)
+
+(define IKFact 
+  (create-class "IKFact" NSObject '() #f))
+
+(class-add-class-method IKFact 'fact: 'int '(class selector int)
+  (trace-lambda fact (self sel n)
+    (if (zero? n)
+        1
+        (* n [$ self fact: (sub1 n)]))))
+
+(printf "(fact 5) = ~s\n" [$ IKFact fact: 5])

lib/objc.ss

@@ -11,6 +11,17 @@
     class-methods
     class-name
     method-name
+    create-class
+    class-instance-size
+    class-parent
+    class-ivars
+    ivar-name
+    ivar-type
+    ivar-offset
+    load-shared-object
+    class-ivar
+    class-add-instance-method
+    class-add-class-method
     $)
   (import
     (ikarus)
@@ -19,42 +30,48 @@
 
 (define ptrsize 4)
 
-
-
- 
 (define objc
   (load-shared-object "libobjc.A.dylib"))
 (define Cocoa
   (load-shared-object "/System/Library/Frameworks/Cocoa.framework/Cocoa"))
 
-
 (define-syntax define-function
   (syntax-rules ()
     ((_ ret name args)
      (define name
        (c-function objc "Objective C Binding" ret __stdcall name args)))))
 
-
 (define-function int objc_getClassList (void* int))
+(define-function void objc_addClass (void*))
 (define-function void* objc_getClass (char*))
 (define-function void* sel_registerName (char*))
 (define-function void* sel_getUid (char*))
 (define-function void* class_getInstanceMethod (void* void*))
 (define-function void* class_getClassMethod (void* void*))
 (define-function void* class_nextMethodList (void* void*))
-
+(define-function void* class_getInstanceVariable (void* void*))
-
+(define-function void class_addMethods (void* void*))
 
 (define-record-type class (fields ptr))
 (define-record-type object (fields ptr))
 (define-record-type lazy-object (fields ptr))
 (define-record-type selector (fields ptr))
 (define-record-type method (fields ptr))
+(define-record-type ivar (fields ptr))
 
 (define (pointer-ref addr offset)
   (assert (pointer? addr))
   (integer->pointer (pointer-ref-long addr offset)))
 
+(define (offset? x) (or (fixnum? x) (bignum? x)))
+
+(define (pointer-set addr offset val)
+  (define who 'pointer-set)
+  (check who pointer? addr)
+  (check who pointer? val)
+  (check who offset? offset)
+  (pointer-set-long addr offset (pointer->integer val)))
+
 (define (char*len x)
   (let f ([i 0])
     (cond
@@ -94,7 +111,6 @@
                (pointer-set-char p i (bytevector-s8-ref x i))
                (f (+ i 1))]))))))
 
-
 (define (char*->string x)
   (utf8->string (char*->bv x)))
 
@@ -102,7 +118,6 @@
   (let ([bv (string->utf8 x)])
     (bv->char* bv)))
 
-
 (define-syntax check
   (syntax-rules ()
     [(_ who pred expr)
@@ -114,6 +129,162 @@
   (check 'class-name class? x)
   (char*->string (pointer-ref (class-ptr x) (* ptrsize 2))))
 
+(define (class-parent x)
+  (check 'class-parent class? x)
+  (let ([super (pointer-ref (class-ptr x) (* ptrsize 1))])
+    (if (nil? super)
+        #f
+        (make-class super))))
+
+(define (class-metaclass x)
+  (check 'class-metaclass class? x)
+  (let ([super (pointer-ref (class-ptr x) (* ptrsize 0))])
+    (if (nil? super)
+        #f
+        (make-class super))))
+
+(define (get-root-class x)
+  (let ([super (class-parent x)])
+    (if super
+        (get-root-class super)
+        x)))
+
+; FIXME: no hardocding
+(define CLS_CLASS #x01)
+(define CLS_META  #x02)
+
+(define objc-class-isa-offset           (* 0 ptrsize))
+(define objc-class-superclass-offset    (* 1 ptrsize))
+(define objc-class-name-offset          (* 2 ptrsize))
+(define objc-class-version-offset       (* 3 ptrsize))
+(define objc-class-info-offset          (* 4 ptrsize))
+(define objc-class-instance-size-offset (* 5 ptrsize))
+(define objc-class-ivars-offset         (* 6 ptrsize))
+(define objc-class-methodlists-offset   (* 7 ptrsize))
+(define objc-class-cache-offset         (* 8 ptrsize))
+(define objc-class-protocols-offset     (* 9 ptrsize))
+(define objc-class-struct-size          (* 10 ptrsize))
+
+(define objc-methodlist-obsolete-offset (* 0 ptrsize))
+(define objc-methodlist-count-offset    (* 1 ptrsize))
+(define objc-methodlist-methods-offset  (* 2 ptrsize))
+
+(define objc-method-sel-offset          (* 0 ptrsize))
+(define objc-method-types-offset        (* 1 ptrsize))
+(define objc-method-imp-offset          (* 2 ptrsize))
+(define objc-method-size                (* 3 ptrsize))
+
+(define objc-ivarlist-count-offset      (* 0 ptrsize))
+(define objc-ivarlist-ivars-offset      (* 1 ptrsize))
+(define objc-ivar-name-offset           (* 0 ptrsize))
+(define objc-ivar-type-offset           (* 1 ptrsize))
+(define objc-ivar-offset-offset         (* 2 ptrsize))
+(define objc-ivar-size                  (* 3 ptrsize))
+
+(define (class-instance-size x)
+  (check 'class-instance-size class? x)
+  (pointer-ref-long (class-ptr x) objc-class-instance-size-offset))
+
+(define (ivar-name x)
+  (check 'ivar-name ivar? x)
+  (char*->string (pointer-ref (ivar-ptr x) 0)))
+
+(define (ivar-type x)
+  (check 'ivar-type ivar? x)
+  (char*->string (pointer-ref (ivar-ptr x) ptrsize)))
+
+(define (ivar-offset x)
+  (check 'ivar-offset ivar? x)
+  (pointer-ref-int (ivar-ptr x) (* 2 ptrsize)))
+
+(define (class-ivars x)
+  (check 'class-ivars class? x)
+  (let ([p (pointer-ref (class-ptr x) objc-class-ivars-offset)])
+    (if (nil? p)
+        '()
+        (let ([n (pointer-ref-long p 0)])
+          (let f ([i 0] [off objc-ivarlist-ivars-offset])
+            (if (= i n)
+                '()
+                (let ([iv (integer->pointer (+ off (pointer->integer p)))])
+                  (cons (make-ivar iv)
+                    (f (+ i 1) (+ off objc-ivar-size))))))))))
+
+(define (create-class name super-class ivars intern?)
+  (define who 'create-class)
+  (check who string? name)
+  (check who list? ivars)
+  (check who class? super-class)
+  (when (get-class name)
+    (error who "class already exists" name))
+  (let-values ([(ivars-ptr instance-size)
+                (make-ivar-ptr ivars super-class)])
+    (let* ([root-class (get-root-class super-class)]
+           [class (malloc objc-class-struct-size)]
+           [meta  (malloc objc-class-struct-size)])
+      ;;; init meta class
+      (pointer-set-long meta objc-class-info-offset CLS_META)
+      (pointer-set meta objc-class-name-offset (string->char* name))
+      (pointer-set meta objc-class-methodlists-offset
+        (malloc objc-methodlist-methods-offset))
+      (pointer-set meta objc-class-superclass-offset
+        (pointer-ref (class-ptr super-class) objc-class-isa-offset))
+      (pointer-set meta objc-class-isa-offset
+        (pointer-ref (class-ptr root-class) objc-class-isa-offset))
+      ;;; init class
+      (pointer-set-long class objc-class-info-offset CLS_CLASS)
+      (pointer-set class objc-class-name-offset (string->char* name))
+      (pointer-set class objc-class-methodlists-offset
+        (malloc objc-methodlist-methods-offset))
+      (pointer-set class objc-class-superclass-offset
+        (class-ptr super-class))
+      (pointer-set class objc-class-ivars-offset ivars-ptr)
+      (pointer-set-long class objc-class-instance-size-offset instance-size)
+      ;;; wire up
+      (pointer-set class objc-class-isa-offset meta)
+      (when intern? (objc_addClass class))
+      (make-class class))))
+
+(define (class-add-method who class sel rtype argtypes proc)
+  (check who class? class)
+  (check who symbol? sel)
+  (check who procedure? proc)
+  (let ([type (make-objc-type (cons rtype argtypes))])
+    (let ([callback
+           (make-callback
+             (objc-type->ikarus-type rtype)
+             (map objc-type->ikarus-type argtypes))])
+      (let ([imp (callback
+                   (lambda args
+                     (convert-outgoing rtype
+                       (apply proc (map convert-incoming argtypes args)))))])
+        (let ([p (malloc (+ objc-methodlist-methods-offset
+                            objc-method-size))])
+          (pointer-set-int p objc-methodlist-count-offset 1)
+          (pointer-set p
+            (+ objc-methodlist-methods-offset objc-method-sel-offset)
+            (selector-ptr
+              (or (get-selector (symbol->string sel))
+                  (begin
+                    (free p)
+                    (error who "invalid selector")))))
+          (pointer-set p
+            (+ objc-methodlist-methods-offset objc-method-types-offset)
+            (string->char* type))
+          (pointer-set p
+            (+ objc-methodlist-methods-offset objc-method-imp-offset)
+            imp)
+          (class_addMethods (class-ptr class) p))))))
+
+(define (class-add-instance-method class sel rtype argtypes proc)
+  (define who 'class-add-instance-method)
+  (class-add-method who class sel rtype argtypes proc))
+
+(define (class-add-class-method class sel rtype argtypes proc)
+  (define who 'class-add-instance-method)
+  (check who class? class)
+  (class-add-method who (class-metaclass class) sel rtype argtypes proc))
+
 (define (method-types x)
   (check 'method-types method? x)
   (char*->string (pointer-ref (method-ptr x) (* ptrsize 1))))
@@ -122,7 +293,6 @@
   (check 'method-pointer method? x)
   (pointer-ref (method-ptr x) (* ptrsize 2)))
 
-
 (define (method-selector x)
   (check 'method-selector method? x)
   (make-selector (pointer-ref (method-ptr x) (* ptrsize 0))))
@@ -131,11 +301,8 @@
   (check 'method-name method? x)
   (selector-name (method-selector x)))
 
-
-
 (define CLS_METHOD_ARRAY #x100)
 
-
 (define (class-is? x what)
   (define alist
     '([method-array      #x100]
@@ -174,7 +341,6 @@
            (let ([ls (methods methodlist)])
              (append ls (f)))])))))
 
-
 (define (get-class-list)
   (let ([n (objc_getClassList (integer->pointer 0) 0)])
     (if (= n 0)
@@ -233,7 +399,6 @@
       [(nil? v) #f]
       [else (make-method v)]))))
 
-
 (define-syntax define-class
   (syntax-rules ()
     [(_ name)
@@ -241,43 +406,6 @@
        (or (get-class (symbol->string 'name))
            (error 'define-class "undefined class" 'name)))]))
 
-(define-syntax define-selector 
-  (syntax-rules ()
-    [(_ name) 
-     (define name 
-       (or (get-selector (symbol->string 'name))
-           (error 'define-selector "undefined selector" 'name)))]))
-
-(define-syntax define-class-method
-  (syntax-rules ()
-    [(_ name class selector)
-     (define name 
-       (or (get-class-method class selector)
-           (error 'define-class-method 
-                  "class method not implemented"
-                  'name)))]))
-
-
-(define-class NSObject)
-(define-class NSString)
-(define-class NSAutoreleasePool)
-(define-class NSWindow)
-(define-selector alloc)
-(define-selector allocWithZone:)
-(define-selector init)
-
-(define-class-method NSObject:alloc NSObject alloc)
-(define-class-method NSObject:allocWithZone: NSObject allocWithZone:)
-(define-class-method NSAutoreleasePool:alloc NSAutoreleasePool alloc)
-
-
-(define (class-info x)
-  `([name: ,(class-name x)]
-    [methods: 
-      ,(list-sort string<?
-         (map method-name (class-methods x)))]))
-
-
 (define-syntax define-framework
   (lambda (x)
     (syntax-case x ()
@@ -304,6 +432,77 @@
   (or (get-selector (symbol->string x))
       (error 'symbol->selector "undefined selector" x)))
 
+(define ctype-info
+  ; [name     size]
+  '([pointer     4]
+    [sint        4]))
+
+(define objc-type-info
+  '([object   "@" pointer]
+    [selector ":" pointer]
+    [class    "#" pointer]
+    [void     "v" #f]
+    [int      "i" sint]))
+
+(define (ivar-info x)
+  (cond
+    [(assq x objc-type-info) =>
+     (lambda (p)
+       (let ([name (car p)] [typestr (cadr p)] [ctype (caddr p)])
+         (cond
+           [(assq ctype ctype-info) =>
+            (lambda (p)
+              (let ([name (car p)] [size (cadr p)])
+                (values typestr size)))]
+           [else (error 'ivar-info "invalid ctype" ctype)])))]
+    [else (error 'ivar-info "invalid type" x)]))
+
+(define (class-ivar class ivar-name)
+  (define who 'class-ivar)
+  (check who class? class)
+  (check who string? ivar-name)
+  (let ([char* (string->char* ivar-name)])
+    (let ([v (class_getInstanceVariable (class-ptr class) char*)])
+      (free char*)
+      (cond
+        [(nil? v) #f]
+        [else (make-ivar v)]))))
+
+(define (make-ivar-ptr ivars super-class)
+  (define (make-ivar-ptr ivars super-class)
+    ;;; ivars = ([name . type] ...)
+    (define who 'make-ivar-ptr)
+    (define count (length ivars))
+    (define p
+      (malloc (+ objc-ivarlist-ivars-offset (* count objc-ivar-size))))
+    (pointer-set-int p objc-ivarlist-count-offset count)
+    (let f ([ivars ivars]
+            [poff objc-ivarlist-ivars-offset]
+            [ivaroff (class-instance-size super-class)])
+      (cond
+        [(null? ivars) (values p ivaroff)]
+        [else
+         (let ([ivar (car ivars)])
+           (let ([name (car ivar)])
+             (let-values ([(ivar-type ivar-size) (ivar-info (cdr ivar))])
+               (pointer-set p (+ poff objc-ivar-name-offset)
+                 (string->char* (symbol->string name)))
+               (pointer-set p (+ poff objc-ivar-type-offset)
+                 (string->char* ivar-type))
+               (pointer-set-int p (+ poff objc-ivar-offset-offset) ivaroff)
+               (f (cdr ivars)
+                  (+ poff objc-ivar-size)
+                  (+ ivaroff ivar-size)))))])))
+  (if (null? ivars)
+      (values (integer->pointer 0) (class-instance-size super-class))
+      (make-ivar-ptr ivars super-class)))
+
+(define (make-objc-type signature)
+  (define (type-string x)
+    (cond
+      [(assq x objc-type-info) => cadr]
+      [else (error 'make-objc-type "invalid type" x)]))
+  (apply string-append (map type-string signature)))
 
 (define (make-signature method-name str)
   (define who 'make-signature)
@@ -321,6 +520,7 @@
            (case c
              [(#\@) (values 'object (+ i 1))]
              [(#\:) (values 'selector (+ i 1))]
+             [(#\#) (values 'class (+ i 1))]
              [(#\v) (values 'void (+ i 1))]
              [(#\f) (values 'float (+ i 1))]
              [(#\i) (values 'int (+ i 1))]
@@ -357,7 +557,6 @@
          (let-values ([(x i) (parse i)])
            (cons/skip x (f i)))]))))
 
-
 (define (objc-type->ikarus-type x)
   (cond
     [(vector? x)
@@ -367,6 +566,7 @@
      (case x
        [(selector) 'pointer]
        [(object)   'pointer]
+       [(class)    'pointer]
        [(void)     'void]
        [(float)    'float]
        [(uint)     'uint32]
@@ -375,13 +575,15 @@
        [(char*)    'pointer]
        [else (error 'objc-type->ikarus-type "invalid type" x)])]))
 
-
-
 (define (convert-incoming t x)
   (case t
     [(object)
      (if (nil? x) #f (make-object x))]
-    [(char)   x]
+    [(class)
+     (if (nil? x) #f (make-class x))]
+    [(selector)
+     (if (nil? x) #f (make-selector x))]
+    [(char int)   x]
     [(void)   (void)]
     [else (error 'convert-incoming "invalid type" t)]))
 
@@ -417,6 +619,10 @@
           [(class? x) (class-ptr x)]
           [(not x)    (integer->pointer 0)]
           [else (error 'convert-output "cannot convert to object" x)])]
+       [(class)
+        (cond
+          [(class? x) (class-ptr x)]
+          [else (error 'convert-output "cannot convert to class" x)])]
        [(float)
         (cond
           [(number? x) (inexact x)]
@@ -430,9 +636,9 @@
         (cond
           [(string? x) (string->char* x)]
           [else (error 'convert-output "cannot convert to char*" x)])]
+       [(void) (void)]
        [else (error 'convert-outgoing "invalid type" t)])]))
 
-
 (define (call-with-sig sig mptr args)
   (let ([rtype (car sig)] [argtypes (cdr sig)])
     (unless (= (length args) (length argtypes))
@@ -486,25 +692,4 @@
                       (process-args #'(kwd/arg* ...))])
          #'(send-message receiver 'sel-name arg* ...))])))
 
-
-         
-
-;(printf "Classes: ~s\n" 
-;  (list-sort string<? (map class-name (get-class-list))))
-;
-;(printf "NSObject=~s\n" NSObject)
-;(printf "alloc=~s\n" alloc)
-;(printf "init=~s\n" init)
-;(printf "NSObject:alloc=~s\n" NSObject:alloc)
-;(printf "NSObject:allocWithZone=~s\n" NSObject:allocWithZone:)
-;(printf "types alloc=~s\n" (method-types NSObject:alloc))
-;(printf "types alloc=~s\n" (method-types NSAutoreleasePool:alloc))
-;(printf "types allocWithZone=~s\n" (method-types NSObject:allocWithZone:))
-;(for-each
-;  (lambda (x)
-;    (pretty-print (class-info x)))
-;  (list NSObject NSString NSAutoreleasePool NSWindow))
-
-
-
 ) ; library