diff --git a/lab/hello-cocoa.ss b/lab/hello-cocoa.ss index 280b61d..7a64f5c 100755 --- a/lab/hello-cocoa.ss +++ b/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] diff --git a/lab/objc-class.ss b/lab/objc-class.ss new file mode 100755 index 0000000..84dc21d --- /dev/null +++ b/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 (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 stringpointer (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] @@ -154,8 +321,8 @@ (let f ([i 0]) (if (= i n) '() - (let ([m (make-method - (integer->pointer + (let ([m (make-method + (integer->pointer (+ (pointer->integer array) (* 3 ptrsize i))))]) (cons m (f (+ i 1)))))))) @@ -168,13 +335,12 @@ (let ([methodlist (class_nextMethodList (class-ptr x) iterator)]) (cond [(nil? methodlist) - (free iterator) + (free iterator) '()] [else (let ([ls (methods methodlist)]) (append ls (f)))]))))) - (define (get-class-list) (let ([n (objc_getClassList (integer->pointer 0) 0)]) (if (= n 0) @@ -182,11 +348,11 @@ (let ([buffer (malloc (* ptrsize n))]) (let ([n (objc_getClassList buffer n)]) (let f ([i 0] [ac '()]) - (if (= i n) + (if (= i n) (begin (free buffer) ac) - (f (+ i 1) - (cons - (make-class + (f (+ i 1) + (cons + (make-class (integer->pointer (pointer-ref-long buffer (* ptrsize i)))) ac))))))))) @@ -215,7 +381,7 @@ (define (get-class-method class selector) (check 'get-class-method class? class) (check 'get-class-method selector? selector) - (let ([v (class_getClassMethod + (let ([v (class_getClassMethod (class-ptr class) (selector-ptr selector))]) (cond @@ -226,58 +392,20 @@ (check 'get-instance-method object? x) (check 'get-instance-method selector? selector) (let ([class (pointer-ref (object-ptr x) 0)]) - (let ([v (class_getInstanceMethod + (let ([v (class_getInstanceMethod class (selector-ptr selector))]) (cond [(nil? v) #f] [else (make-method v)])))) - -(define-syntax define-class +(define-syntax define-class (syntax-rules () - [(_ name) - (define name + [(_ name) + (define name (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 stringstring (syntax->datum #'name))]) (with-syntax ([framework-name (string-append str ".framework/" str)]) - #'(define name + #'(define name (load-shared-object framework-name))))]))) (define (load-object lib name) - (let ([ptr + (let ([ptr (or (dlsym (library-pointer lib) (symbol->string name)) (error 'load-object "cannot find symbol" name))]) (make-lazy-object ptr))) @@ -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))] @@ -341,10 +541,10 @@ (values i (cons x ls)))])))]) (values (list->vector ls) i)))] [(#\*) (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 + [(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\r) (values 'skip (+ i 1))] [else (error who "invalid char" c str)]))])) @@ -353,20 +553,20 @@ (let f ([i 0]) (cond [(= i n) '()] - [else + [else (let-values ([(x i) (parse i)]) (cons/skip x (f i)))])))) - (define (objc-type->ikarus-type x) (cond - [(vector? x) + [(vector? x) (vector-map objc-type->ikarus-type x)] [(pair? x) 'pointer] [else - (case x + (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) + [(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)])) @@ -396,9 +598,9 @@ [else (error 'convert-output "not a vector" x)])] [(and (pair? t) (eq? (car t) 'pointer)) (case (cdr t) - [(ushort) + [(ushort) (cond - [(string? x) + [(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)])] @@ -409,15 +611,19 @@ [(selector? x) (selector-ptr x)] [(not x) (integer->pointer 0)] [else (error 'convert-output "not a selector" x)])] - [(object) + [(object) (cond [(object? x) (object-ptr x)] - [(lazy-object? x) + [(lazy-object? x) (pointer-ref (lazy-object-ptr x) 0)] [(class? x) (class-ptr x)] [(not x) (integer->pointer 0)] [else (error 'convert-output "cannot convert to object" x)])] - [(float) + [(class) + (cond + [(class? x) (class-ptr x)] + [else (error 'convert-output "cannot convert to class" x)])] + [(float) (cond [(number? x) (inexact x)] [else (error 'convert-output "cannot convert to float" x)])] @@ -426,32 +632,32 @@ [(or (fixnum? x) (bignum? x)) x] [(boolean? x) (if x 1 0)] [else (error 'convert-output "cannot convert to int" x)])] - [(char*) + [(char*) (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)) (error 'call-with-sig "incorrect number of args" args argtypes)) - (let ([ffi (make-ffi + (let ([ffi (make-ffi (objc-type->ikarus-type rtype) (map objc-type->ikarus-type argtypes))]) (let ([proc (ffi mptr)]) - (convert-incoming rtype + (convert-incoming rtype (apply proc (map convert-outgoing argtypes args))))))) (define (send-message x method-name . args) (let ([selector (symbol->selector method-name)]) - (let ([method + (let ([method (cond [(class? x) (get-class-method x selector)] [(object? x) (get-instance-method x selector)] [(lazy-object? x) - (get-instance-method + (get-instance-method (make-object (pointer-ref (lazy-object-ptr x) 0)) selector)] [else (error 'send-message "not an object" x)])]) @@ -468,8 +674,8 @@ [() (values "" '())] [(kwd val . rest) (identifier? #'kwd) (let-values ([(sel args) (process-rest #'rest)]) - (values - (string-append + (values + (string-append (symbol->string (syntax->datum #'kwd)) sel) (cons #'val args)))])) @@ -486,25 +692,4 @@ (process-args #'(kwd/arg* ...))]) #'(send-message receiver 'sel-name arg* ...))]))) - - - -;(printf "Classes: ~s\n" -; (list-sort string