From 2c95f77c3141a0827bd094d8d93b3e3fa39ef8b5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 18 Dec 2008 20:05:21 +0000 Subject: [PATCH] ctype->layout in scheme/foreign; prototype Objective-C binding in ffi collection svn: r12890 --- collects/ffi/objc.ss | 546 +++++++++++++++++++++++ collects/mzlib/foreign.ss | 22 +- collects/scribblings/foreign/types.scrbl | 19 +- src/foreign/foreign.c | 13 +- src/foreign/foreign.ssc | 10 +- 5 files changed, 591 insertions(+), 19 deletions(-) create mode 100644 collects/ffi/objc.ss diff --git a/collects/ffi/objc.ss b/collects/ffi/objc.ss new file mode 100644 index 0000000000..c84c3462b7 --- /dev/null +++ b/collects/ffi/objc.ss @@ -0,0 +1,546 @@ +#lang scheme/base +(require scheme/foreign (only-in '#%foreign ffi-call) + scheme/stxparam + (for-syntax scheme/base)) +(unsafe!) + +(define objc-lib (ffi-lib "libobjc")) + +(define-syntax define-objc/private + (syntax-rules () + [(_ id type) + (define-objc/private id id type)] + [(_ id c-id type) + (define id (get-ffi-obj 'c-id objc-lib type))])) + +(define-syntax-rule (define-objc id type) + (begin + (provide id) + (define-objc/private id id type))) + +;; ---------------------------------------- + +(provide _id _BOOL _SEL) + +(define _id (_cpointer/null 'id)) + +(define _SEL (_cpointer/null 'SEL)) +(define _Ivar (_cpointer/null 'Ivar)) +(define _Class (make-ctype _id + (lambda (v) v) + (lambda (p) + (when p (cpointer-push-tag! p 'Class)) + p))) +(define _BOOL (make-ctype _byte + (lambda (v) (if v 1 0)) + (lambda (v) (not (eq? v 0))))) +(define _IMP (_fun _id _id -> _id)) + +(define-cstruct _objc_super ([receiver _id][class _Class])) + +(provide YES NO) +(define YES #t) +(define NO #f) + +;; ---------------------------------------- + +(define-objc objc_lookUpClass (_fun _string -> _Class)) + +(define-objc sel_registerName (_fun _string -> _SEL)) + +(define-objc objc_allocateClassPair (_fun _Class _string _long -> _Class)) +(define-objc objc_registerClassPair (_fun _Class -> _void)) + +(define-objc object_getClass (_fun _id -> _Class)) + +(provide class_addMethod) +(define (class_addMethod cls sel imp ty enc) + ((get-ffi-obj 'class_addMethod objc-lib (_fun _Class _SEL ty _string -> _BOOL)) + cls sel imp enc)) + +(define-objc class_addIvar (_fun _Class _string _long _uint8 _string -> _BOOL)) +(define-objc object_getInstanceVariable (_fun _id _string [p : (_ptr o _pointer)] + -> [ivar : _Ivar] + -> (values ivar p))) +(define-objc object_setInstanceVariable (_fun _id _string _pointer -> _Ivar)) + +(define-objc/private objc_msgSend _fpointer) +(define-objc/private objc_msgSend_fpret _fpointer) +(define-objc/private objc_msgSendSuper _fpointer) +(define objc_msgSendSuper_fpret objc_msgSendSuper) ; why no fpret variant? + +(define (lookup-send types msgSends msgSend msgSend_fpret first-arg-type) + ;; First type in `types' vector is the result type + (or (hash-ref msgSends types #f) + (let ([m (ffi-call (if (memq (ctype->layout (vector-ref types 0)) + '(float double double*)) + msgSend_fpret + msgSend) + (list* first-arg-type _SEL (cdr (vector->list types))) + (vector-ref types 0))]) + (hash-set! msgSends types m) + m))) + +(define msgSends (make-hash)) +(define (objc_msgSend/typed types) + (lookup-send types msgSends objc_msgSend objc_msgSend_fpret _id)) +(provide objc_msgSend/typed) + +(define msgSendSupers (make-hash)) +(define (objc_msgSendSuper/typed types) + (lookup-send types msgSendSupers objc_msgSendSuper objc_msgSendSuper_fpret _pointer)) +(provide objc_msgSendSuper/typed) + +;; ---------------------------------------- + +(provide import-class) +(define-syntax (import-class stx) + (syntax-case stx () + [(_ id) + (quasisyntax/loc stx + (define id (objc_lookUpClass #,(symbol->string (syntax-e #'id)))))] + [(_ id ...) + (syntax/loc stx (begin (import-class id) ...))])) + +;; ---------------------------------------- +;; iget-value and iset-value work only with fields that contain Scheme values + +(provide iget-value iset-value) + +(define-for-syntax (check-ivar ivar stx) + (unless (identifier? ivar) + (raise-type-error #f + "expected an identifier for an instance-variable name" + stx + ivar))) + +(define-syntax (iget-value stx) + (syntax-case stx () + [(_ obj ivar) + (begin + (check-ivar #'ivar stx) + (quasisyntax/loc stx + (get-ivar-value obj #,(symbol->string (syntax-e #'ivar)))))])) + +(define (get-ivar-value obj name) + (let-values ([(ivar p) (object_getInstanceVariable obj name)]) + (and p (ptr-ref p _scheme)))) + + +(define-syntax (iset-value stx) + (syntax-case stx () + [(_ obj ivar val) + (begin + (check-ivar #'ivar stx) + (quasisyntax/loc stx + (set-ivar-value obj #,(symbol->string (syntax-e #'ivar)) val)))])) + +(define (set-ivar-value obj name val) + (let-values ([(ivar p) (object_getInstanceVariable obj name)]) + (if p + (ptr-set! p _scheme val) + (let ([p (malloc-immobile-cell val)]) + (void (object_setInstanceVariable obj name p)))))) + +(define (free-fields obj names) + (for-each (lambda (name) + (let-values ([(ivar p) (object_getInstanceVariable obj name)]) + (when p (free-immobile-cell p)))) + names)) + +;; ---------------------------------------- + +(define-for-syntax method-sels (make-hash)) + +(define-for-syntax (register-selector sym) + (or (hash-ref method-sels (cons (syntax-local-lift-context) sym) #f) + (let ([id (syntax-local-lift-expression + #`(sel_registerName #,(symbol->string sym)))]) + (hash-set! method-sels sym id) + id))) + +(provide selector) +(define-syntax (selector stx) + (syntax-case stx () + [(_ id) + (begin + (unless (identifier? #'id) + (raise-syntax-error #f + "expected an identifier" + stx + #'id)) + (register-selector (syntax-e #'id)))])) + +;; ---------------------------------------- + +(define-for-syntax (combine stxes) + (string->symbol + (apply + string-append + (map (lambda (e) (symbol->string (syntax-e e))) + (syntax->list stxes))))) + +(define-for-syntax (check-method-name m stx) + (unless (identifier? m) + (raise-syntax-error #f + "expected an identifier for the method name" + stx + m))) + +(define-for-syntax (check-id-colon id stx) + (unless (regexp-match #rx":$" (symbol->string (syntax-e id))) + (raise-syntax-error #f + "expected an identifier that ends in `:' to tag an argument" + stx + id))) + +(define-for-syntax (parse-arg-list l stx formals?) + (define (is-typed? l) + (if formals? + (and (pair? (cdr l)) + (let ([l (syntax->list (cadr l))]) + (and (list? l) + (= 2 (length l))))) + (and (pair? (cdr l)) + (eq? '#:type (syntax-e (cadr l)))))) + (let loop ([l l]) + (if (null? l) + null + (begin + (unless (identifier? (car l)) + (raise-syntax-error #f + "expected an identifier to tag an argument" + stx + (car l))) + (check-id-colon (car l) stx) + (let ([tag (car l)] + [type (if (is-typed? l) + (if formals? + (car (syntax-e (cadr l))) + (if (pair? (cddr l)) + (caddr l) + (raise-syntax-error #f + "missing type expression after tag with #:type" + stx + (car l)))) + #'_id)] + [rest (if formals? + (cdr l) + (if (is-typed? l) + (cdddr l) + (cdr l)))]) + (unless (pair? rest) + (raise-syntax-error #f + (format "missing an argument~a after tag" + (if formals? " identifier" " expression")) + stx + tag)) + (cons + (list tag type (let ([arg (car rest)]) + (if formals? + (if (identifier? arg) + arg + (let ([l (syntax->list arg)]) + (unless (and (list? l) + (= 2 (length l)) + (identifier? (cadr l))) + (raise-syntax-error #f + (string-append + "exepected an identifier for an argument name" + " or a parenthesized type--identifier sequence") + stx + arg)) + (cadr l))) + arg))) + (loop (cdr rest)))))))) + +(provide tell) +(define-for-syntax (build-send stx result-type send/typed send-args l-stx) + (let ([l (syntax->list l-stx)]) + (with-syntax ([((tag type arg) ...) (parse-arg-list l stx #f)] + [send send/typed] + [(send-arg ...) send-args]) + (quasisyntax/loc stx + ((send (type-vector #,result-type type ...)) + send-arg ... #,(register-selector (combine #'(tag ...))) + arg ...))))) + +(define-syntax (tell stx) + (syntax-case stx () + [(_ target) + (raise-syntax-error #f + "method identifier missing" + stx)] + [(_ #:type t) + (raise-syntax-error #f + "method target object missing" + stx)] + [(_ #:type t target) + (raise-syntax-error #f + "method identifier missing" + stx)] + [(_ #:type t target method) + (let ([m #'method]) + (check-method-name m stx) + (quasisyntax/loc stx + ((objc_msgSend/typed (type-vector t)) target #,(register-selector (syntax-e m)))))] + [(_ target method) + (not (keyword? (syntax-e #'target))) + (let ([m #'method]) + (check-method-name m stx) + (quasisyntax/loc stx + ((objc_msgSend/typed (type-vector _id)) target #,(register-selector (syntax-e m)))))] + [(_ #:type result-type target method/arg ...) + (build-send stx #'result-type + #'objc_msgSend/typed #'(target) + #'(method/arg ...))] + [(_ target method/arg ...) + (build-send stx #'_id + #'objc_msgSend/typed #'(target) + #'(method/arg ...))])) + +(define-for-syntax liftable-type? + (let ([prims + (syntax->list #'(_id _Class _SEL _void _int _long _float _double _double* _BOOL))]) + (lambda (t) + (and (identifier? t) + (ormap (lambda (p) (free-identifier=? t p)) + prims))))) + +(define-syntax (type-vector stx) + (let ([types (cdr (syntax->list stx))]) + ((if (andmap liftable-type? (cdr (syntax->list stx))) + (lambda (e) + (syntax-local-lift-expression #`(intern-type-vector #,e))) + values) + (quasisyntax/loc stx (vector . #,types))))) + +(define type-vectors (make-hash)) +(define (intern-type-vector v) + (or (hash-ref type-vectors v #f) + (begin + (hash-set! type-vectors v v) + v))) + +;; ---------------------------------------- + +(provide define-objc-class self super-tell) + +(define-syntax (define-objc-class stx) + (syntax-case stx () + [(_ id superclass (ivar ...) method ...) + (begin + (unless (identifier? #'id) + (raise-syntax-error #f + "expected an identifier for class definition" + stx + #'id)) + (for-each (lambda (ivar) + (unless (identifier? ivar) + (raise-syntax-error #f + "expected an identifier for an instance variable" + stx + ivar))) + (syntax->list #'(ivar ...))) + (let ([ivars (syntax->list #'(ivar ...))] + [methods (syntax->list #'(method ...))]) + (with-syntax ([id-str (symbol->string (syntax-e #'id))] + [whole-stx stx] + [(dealloc-method ...) + (if (null? ivars) + ;; no need to override dealloc: + #'() + ;; add dealloc if it's not here: + (if (ormap (lambda (m) + (syntax-case m () + [(+/- result-type (id . _) . _) + (eq? (syntax-e #'id) 'dealloc)])) + methods) + ;; Given a dealloc extension: + #'() + ;; Need to add one explicitly: + #'((- _void (dealloc) (void)))))]) + (syntax/loc stx + (begin + (define superclass-id superclass) + (define id (objc_allocateClassPair superclass-id id-str 0)) + (add-ivar id 'ivar) ... + (let-syntax ([ivar (make-ivar-form 'ivar)] ...) + (add-method whole-stx id superclass-id method) ... + (add-method whole-stx id superclass-id dealloc-method) ... + (void)) + (objc_registerClassPair id))))))])) + +(define-for-syntax (make-ivar-form sym) + (with-syntax ([sym sym]) + (make-set!-transformer + (lambda (stx) + (syntax-case stx (set!) + [(set! _ val) + (syntax/loc stx (iset-value self sym val))] + [(_ arg ...) + (quasisyntax/loc stx (#,(quasisyntax/loc #'sym #'(iget-value self sym)) + arg ...))] + [_ (quasisyntax/loc #'sym (iget-value self sym))]))))) + +(define (layout->string l) + (case l + [(uint8) "C"] + [(int8) "c"] + [(float) "f"] + [(double) "d"] + [(bool) "B"] + [(void) "v"] + [(bytes) "*"] + [(pointer fpointer string/ucs-4 string/utf-16) "?"] + [else + (cond + [(list? l) + (apply string-append + (for ([l (in-list l)] + [i (in-naturals)]) + (format "f~a=~a" i (layout->string l))))] + [(eq? l (ctype->layout _int)) "i"] + [(eq? l (ctype->layout _uint)) "I"] + [(eq? l (ctype->layout _short)) "s"] + [(eq? l (ctype->layout _ushort)) "S"] + [(eq? l (ctype->layout _long)) "l"] + [(eq? l (ctype->layout _ulong)) "L"] + [else (error 'generate-layout "unknown layout: ~e" l)])])) + +(define (generate-layout rt arg-types) + (let ([rl (ctype->layout rt)] + [al (map ctype->layout arg-types)]) + (apply + string-append + (layout->string rl) + "@:" + (map layout->string al)))) + +(define-syntax-parameter self + (lambda (stx) + (raise-syntax-error #f + "valid only within a `define-objc-class' method" + stx))) + +(define-syntax-parameter super-class + (lambda (stx) #f)) + +(define-syntax-parameter super-tell + (lambda (stx) + (raise-syntax-error #f + "valid only within a `define-objc-class' method" + stx))) + +(define-for-syntax (make-id-stx orig-id) + (make-set!-transformer + (lambda (stx) + (syntax-case stx (set!) + [(set! id v) (raise-syntax-error #f + "assignment to self identifier disallowed" + stx)] + [(id arg ...) (quasisyntax/loc stx (#,orig-id arg ...))] + [id (datum->syntax orig-id (syntax-e orig-id) stx orig-id orig-id)])))) + +(define-syntax (add-method stx) + (syntax-case stx () + [(_ whole-stx cls superclass-id m) + (let ([stx #'whole-stx]) + (syntax-case #'m () + [(kind result-type (id arg ...) body0 body ...) + (or (free-identifier=? #'kind #'+) + (free-identifier=? #'kind #'-)) + (let ([id #'id] + [args (syntax->list #'(arg ...))] + [in-class? (free-identifier=? #'kind #'+)]) + (when (null? args) + (unless (identifier? id) + (raise-syntax-error #f + "expected an identifier for method name" + stx + id))) + (with-syntax ([((arg-tag arg-type arg-id) ...) + (if (null? args) + null + (parse-arg-list (cons id args) stx #t))]) + (with-syntax ([id-str (if (null? args) + (symbol->string (syntax-e id)) + (symbol->string (combine #'(arg-tag ...))))] + [(dealloc-body ...) + (if (eq? (syntax-e id) 'dealloc) + (syntax-case stx () + [(_ _ _ [ivar ...] . _) + (with-syntax ([(ivar-str ...) + (map (lambda (ivar) + (symbol->string (syntax-e ivar))) + (syntax->list #'(ivar ...)))]) + #'((free-fields self '(ivar-str ...)) + (super-tell #:type _void dealloc)))] + [_ (error "oops")]) + '())] + [in-cls (if in-class? + #'(object_getClass cls) + #'cls)]) + (syntax/loc stx + (let ([rt result-type] + [arg-id arg-type] ...) + (void (class_addMethod in-cls + (sel_registerName id-str) + (save-method! + (lambda (self-id cmd arg-id ...) + (syntax-parameterize ([self (make-id-stx #'self-id)] + [super-class (make-id-stx #'superclass-id)] + [super-tell do-super-tell]) + body0 body ... + dealloc-body ...))) + (_fun _id _id arg-type ... -> rt) + (generate-layout rt (list arg-id ...)))))))))] + [else (raise-syntax-error #f + "bad method form" + stx + #'m)]))])) + +(define methods (make-hasheq)) +(define (save-method! m) + ;; Methods are never GCed, since classes are never unregistered + (hash-set! methods m #t) + m) + +(define (add-ivar cls name) + (void (class_addIvar cls + (symbol->string name) + (ctype-sizeof _pointer) + (sub1 (integer-length (ctype-alignof _pointer))) + (layout->string (ctype->layout _pointer))))) + +(define-for-syntax (do-super-tell stx) + (syntax-case stx () + [(_ #:type t) + (raise-syntax-error #f + "method name missing" + stx)] + [(_ #:type t method) + (let ([m #'method]) + (check-method-name m stx) + (quasisyntax/loc stx + ((objc_msgSendSuper/typed (type-vector t)) + (make-objc_super self super-class) + #,(register-selector (syntax-e m)))))] + [(_ method) + (not (keyword? (syntax-e #'method))) + (let ([m #'method]) + (check-method-name m stx) + (quasisyntax/loc stx + ((objc_msgSendSuper/typed (type-vector _id)) + (make-objc_super self super-class) + #,(register-selector (syntax-e m)))))] + [(_ #:type result-type method/arg ...) + (build-send stx #'result-type + #'objc_msgSendSuper/typed + #'((make-objc_super self super-class)) + #'(method/arg ...))] + [(_ method/arg ...) + (build-send stx #'_id + #'objc_msgSendSuper/typed + #'((make-objc_super self super-class)) + #'(method/arg ...))])) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 8737faa41c..fa2520d35e 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -58,7 +58,7 @@ (unsafe malloc) (unsafe free) (unsafe end-stubborn-change) cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!) ptr-offset ptr-add! offset-ptr? set-ptr-offset! - ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string) + ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string) ctype->layout _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64 _fixint _ufixint _fixnum _ufixnum _float _double _double* @@ -1494,6 +1494,26 @@ (if v (apply values v) (msg/fail-thunk))))] [else (msg/fail-thunk)])))) +;; ---------------------------------------------------------------------------- +;; + +(define prim-synonyms + #hasheq((double* . double) + (fixint . long) + (ufixint . ulong) + (fixnum . long) + (ufixnum . ulong) + (path . bytes) + (symbol . bytes) + (scheme . pointer))) + +(define (ctype->layout c) + (let ([b (ctype-basetype c)]) + (cond + [(ctype? b) (ctype->layout b)] + [(list? b) (map ctype->layout b)] + [else (hash-ref prim-synonyms b b)]))) + ;; ---------------------------------------------------------------------------- ;; Misc utilities diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index aae66609a6..49f1a5443d 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -35,12 +35,29 @@ otherwise.} @defproc*[([(ctype-sizeof [type ctype?]) exact-nonnegative-integer?] - [(ctype-alignof [ctype ctype?]) exact-nonnegative-integer?])]{ + [(ctype-alignof [type ctype?]) exact-nonnegative-integer?])]{ Returns the size or alignment of a given @scheme[type] for the current platform.} +@defproc[(ctype->layout [type ctype?]) (flat-rec-contract rep + symbol? + (listof rep))]{ + +Returns a value to describe the eventual C representation of the +type. It can be any of the following symbols: + +@schemeblock[ + 'int8 'uint8 'int16 'uint16 'int32 'uint32 'int64 'uint64 + 'float 'double 'bool 'void 'pointer 'fpointer + 'bytes 'string/ucs-4 'string/utf-16 +] + +The result can also be a list, which describes a C struct whose +element representations are provided in order within the list.} + + @defproc[(compiler-sizeof [sym symbol?]) exact-nonnegative-integer?]{ Possible values for @scheme[symbol] are @scheme['int], @scheme['char], diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 6d97a28770..f4644b6eb9 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -1222,13 +1222,6 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, * is used for both the function definition and calls, but the actual code in * the function is different: in the relevant cases zero an int and offset the * ptr */ -#ifdef SCHEME_BIG_ENDIAN -#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \ - scheme_to_c(typ,dst,delta,val,basep,_offset,retloc) -#else -#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \ - scheme_to_c(typ,dst,delta,val,basep,_offset) -#endif /* Usually writes the C object to dst and returns NULL. When basetype_p is not * NULL, then any pointer value (any pointer or a struct) is returned, and the @@ -1257,7 +1250,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val); } else switch (CTYPE_PRIMLABEL(type)) { case FOREIGN_void: - scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type)); + if (!ret_loc) scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type)); + break; case FOREIGN_int8: #ifdef SCHEME_BIG_ENDIAN if (sizeof(Tsint8)C","non-void-C-type",0,1,&(type)); + if (!ret_loc) scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type)); + break; case FOREIGN_struct: if (!SCHEME_FFIANYPTRP(val)) scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val); diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc index 50a0ce63ac..565f07a932 100755 --- a/src/foreign/foreign.ssc +++ b/src/foreign/foreign.ssc @@ -1016,13 +1016,6 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, * is used for both the function definition and calls, but the actual code in * the function is different: in the relevant cases zero an int and offset the * ptr */ -#ifdef SCHEME_BIG_ENDIAN -#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \ - scheme_to_c(typ,dst,delta,val,basep,_offset,retloc) -#else -#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \ - scheme_to_c(typ,dst,delta,val,basep,_offset) -#endif /* Usually writes the C object to dst and returns NULL. When basetype_p is not * NULL, then any pointer value (any pointer or a struct) is returned, and the @@ -1099,7 +1092,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, (error 'scheme->c "unhandled pointer type: ~s" ctype) (~ " if (!("(pred "val" x)")) "(wrong-type "val" stype) \\ " return NULL;")))) - (~ " "(wrong-type "type" "non-void-C-type")))):} + (~ " if (!ret_loc) "(wrong-type "type" "non-void-C-type") + ~ " break;"))):} case FOREIGN_struct: if (!SCHEME_FFIANYPTRP(val)) scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);