(library (objc) (export define-framework define-class define-object string->char* get-selector get-class-list get-class 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) (ikarus system $foreign) (except (ypsilon-compat) format)) (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 [(zero? (pointer-ref-uchar x i)) i] [else (f (+ i 1))]))) (define (char*->bv x) (let ([n (char*len x)]) (let ([bv (make-bytevector n)]) (let f ([i 0]) (cond [(= i n) bv] [else (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)]) (if (= n 0) (integer->pointer 0) (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) (let ([t expr]) (unless (pred t) (die who (format "not a ~a" 'pred) t)))])) (define (class-name x) (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)))) (define (method-pointer x) (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)))) (define (method-name x) (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] [no-method-array #x4000])) (check 'class-info class? x) (let ([mask (cond [(assq what alist) => cadr] [else (error 'class-is? "invalid what" what)])]) (= mask (bitwise-and mask (pointer-ref-long (class-ptr x) (* ptrsize 4)))))) (define (class-methods x) (define (methods x) (let ([n (pointer-ref-int x ptrsize)] [array (integer->pointer (+ (pointer->integer x) (* 2 ptrsize)))]) (let f ([i 0]) (if (= i n) '() (let ([m (make-method (integer->pointer (+ (pointer->integer array) (* 3 ptrsize i))))]) (cons m (f (+ i 1)))))))) (check 'class-methods class? x) (when (class-is? x 'method-array) (error 'class-methods "BUG: not yet for method arrays")) (let ([iterator (malloc ptrsize)]) (pointer-set-long iterator 0 0) (let f () (let ([methodlist (class_nextMethodList (class-ptr x) iterator)]) (cond [(nil? methodlist) (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) '() (let ([buffer (malloc (* ptrsize n))]) (let ([n (objc_getClassList buffer n)]) (let f ([i 0] [ac '()]) (if (= i n) (begin (free buffer) ac) (f (+ i 1) (cons (make-class (integer->pointer (pointer-ref-long buffer (* ptrsize i)))) ac))))))))) (define (nil? x) (zero? (pointer->integer x))) (define (get-class name) (check 'lookup-class string? name) (let ([v (objc_getClass name)]) (cond [(nil? v) #f] [else (make-class v)]))) (define (get-selector name) (check 'lookup-selector string? name) (let ([v (sel_registerName name)]) (cond [(nil? v) #f] [else (make-selector v)]))) (define (selector-name x) (check 'selector-name selector? x) (char*->string (selector-ptr x))) (define (get-class-method class selector) (check 'get-class-method class? class) (check 'get-class-method selector? selector) (let ([v (class_getClassMethod (class-ptr class) (selector-ptr selector))]) (cond [(nil? v) #f] [else (make-method v)]))) (define (get-instance-method x selector) (check 'get-instance-method object? x) (check 'get-instance-method selector? selector) (let ([class (pointer-ref (object-ptr x) 0)]) (let ([v (class_getInstanceMethod class (selector-ptr selector))]) (cond [(nil? v) #f] [else (make-method v)])))) (define-syntax define-class (syntax-rules () [(_ name) (define name (or (get-class (symbol->string 'name)) (error 'define-class "undefined class" 'name)))])) (define-syntax define-framework (lambda (x) (syntax-case x () [(_ name) (identifier? #'name) (let ([str (symbol->string (syntax->datum #'name))]) (with-syntax ([framework-name (string-append str ".framework/" str)]) #'(define name (load-shared-object framework-name))))]))) (define (load-object lib name) (let ([ptr (or (dlsym (library-pointer lib) (symbol->string name)) (error 'load-object "cannot find symbol" name))]) (make-lazy-object ptr))) (define-syntax define-object (lambda (x) (syntax-case x () [(_ name lib) #'(define name (load-object lib 'name))]))) (define (symbol->selector x) (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) (let ([n (string-length str)]) (define (scan i c) (cond [(= i n) (error who "cannot find " c)] [(char=? c (string-ref str i)) (+ i 1)] [else (scan (+ i 1) c)])) (define (parse i) (cond [(= i n) (error who "unterminated string")] [else (let ([c (string-ref str i)]) (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))] [(#\I) (values 'uint (+ i 1))] [(#\S) (values 'ushort (+ i 1))] [(#\c) (values 'char (+ i 1))] [(#\{) ;;; struct (let ([i (scan (+ i 1) #\=)]) (let-values ([(i ls) (let f ([i i]) (let-values ([(x i) (parse i)]) (cond [(>= i n) (error who "runaway")] [(char=? (string-ref str i) #\}) (values (+ i 1) (list x))] [else (let-values ([(i ls) (f i)]) (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 #\r) (values 'skip (+ i 1))] [else (error who "invalid char" c str)]))])) (define (cons/skip x y) (if (eq? x 'skip) y (cons x y))) (let f ([i 0]) (cond [(= i n) '()] [else (let-values ([(x i) (parse i)]) (cons/skip x (f i)))])))) (define (objc-type->ikarus-type x) (cond [(vector? x) (vector-map objc-type->ikarus-type x)] [(pair? x) 'pointer] [else (case x [(selector) 'pointer] [(object) 'pointer] [(class) 'pointer] [(void) 'void] [(float) 'float] [(uint) 'uint32] [(int) 'sint32] [(char) 'sint8] [(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))] [(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)])) (define (convert-outgoing t x) (cond [(vector? t) (cond [(vector? x) (unless (= (vector-length x) (vector-length t)) (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) (cond [(selector? x) (selector-ptr x)] [(not x) (integer->pointer 0)] [else (error 'convert-output "not a selector" x)])] [(object) (cond [(object? x) (object-ptr 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)])] [(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)])] [(uint int char) (cond [(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)])] [(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 (objc-type->ikarus-type rtype) (map objc-type->ikarus-type argtypes))]) (let ([proc (ffi mptr)]) (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 (cond [(class? x) (get-class-method x selector)] [(object? x) (get-instance-method x selector)] [(lazy-object? x) (get-instance-method (make-object (pointer-ref (lazy-object-ptr x) 0)) selector)] [else (error 'send-message "not an object" x)])]) (unless method (error 'send-message "undefined method" method-name)) (let ([sig (make-signature method-name (method-types method))] [mptr (method-pointer method)]) (call-with-sig sig mptr (cons* x selector args)))))) (define-syntax $ (lambda (x) (define (process-rest ls) (syntax-case ls () [() (values "" '())] [(kwd val . rest) (identifier? #'kwd) (let-values ([(sel args) (process-rest #'rest)]) (values (string-append (symbol->string (syntax->datum #'kwd)) sel) (cons #'val args)))])) (define (process-args ls) (let-values ([(sel args) (process-rest ls)]) (cons (datum->syntax #'here (string->symbol sel)) args))) (syntax-case x () [(_ receiver kwd) (identifier? #'kwd) #'(send-message receiver 'kwd)] [(_ receiver kwd/arg* ...) (identifier? #'kwd) (with-syntax ([(sel-name arg* ...) (process-args #'(kwd/arg* ...))]) #'(send-message receiver 'sel-name arg* ...))]))) ) ; library