conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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.
This commit is contained in:
Abdulaziz Ghuloum 2008-09-29 01:40:58 -04:00
parent 0a7a3a8266
commit cd4e12be68
4 changed files with 394 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
lab/hello-cocoa.ss
View File

@ -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]

51
lab/objc-class.ss Executable file
View File

@ -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)))

17
lab/objc-create-class.ss Executable file
View File

@ -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])

415
lib/objc.ss
View File

@ -1,6 +1,6 @@
(library (objc)
(export
(export
define-framework
define-class
define-object
@ -11,50 +11,67 @@
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
(import
(ikarus)
(ikarus system $foreign)
(except (ypsilon-compat) format))
(define ptrsize 4)
(define objc
(define objc
(load-shared-object "libobjc.A.dylib"))
(define Cocoa
(define Cocoa
(load-shared-object "/System/Library/Frameworks/Cocoa.framework/Cocoa"))
(define-syntax define-function
(syntax-rules ()
((_ ret name args)
(define name
(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]
@ -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 string<?
(map method-name (class-methods x)))]))
(define-syntax define-framework
(lambda (x)
(syntax-case x ()
@ -285,11 +413,11 @@
(let ([str (symbol->string (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<? (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