From 4acba84b5bd7af324eb081beadd454f2ac00f9af Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 26 Apr 2010 17:10:55 -0600 Subject: [PATCH] reorganize and extend FFI under racket/unsafe/ffi --- collects/ffi/info.ss | 2 - collects/ffi/objc.ss | 678 +----------------- collects/ffi/private/objc-doc-unsafe.ss | 28 - collects/racket/unsafe/ffi/alloc.rkt | 70 ++ collects/racket/unsafe/ffi/atomic.rkt | 99 +++ collects/racket/unsafe/ffi/define.rkt | 75 ++ collects/racket/unsafe/ffi/objc.rkt | 649 +++++++++++++++++ collects/scribblings/foreign/alloc.scrbl | 72 ++ collects/scribblings/foreign/atomic.scrbl | 44 ++ collects/scribblings/foreign/define.scrbl | 101 +++ collects/scribblings/foreign/derived.scrbl | 32 +- collects/scribblings/foreign/foreign.scrbl | 7 +- collects/scribblings/foreign/intro.scrbl | 6 +- collects/scribblings/foreign/libs.scrbl | 4 - collects/scribblings/foreign/misc.scrbl | 3 - .../{ffi => scribblings/foreign}/objc.scrbl | 205 +++--- collects/scribblings/foreign/pointers.scrbl | 4 +- collects/scribblings/foreign/unsafe.scrbl | 5 - 18 files changed, 1270 insertions(+), 814 deletions(-) delete mode 100644 collects/ffi/private/objc-doc-unsafe.ss create mode 100644 collects/racket/unsafe/ffi/alloc.rkt create mode 100644 collects/racket/unsafe/ffi/atomic.rkt create mode 100644 collects/racket/unsafe/ffi/define.rkt create mode 100644 collects/racket/unsafe/ffi/objc.rkt create mode 100644 collects/scribblings/foreign/alloc.scrbl create mode 100644 collects/scribblings/foreign/atomic.scrbl create mode 100644 collects/scribblings/foreign/define.scrbl rename collects/{ffi => scribblings/foreign}/objc.scrbl (54%) delete mode 100644 collects/scribblings/foreign/unsafe.scrbl diff --git a/collects/ffi/info.ss b/collects/ffi/info.ss index 8209760e07..de10b968fb 100644 --- a/collects/ffi/info.ss +++ b/collects/ffi/info.ss @@ -3,5 +3,3 @@ (define name "Sample FFIs") (define compile-omit-paths '("examples")) - -(define scribblings '(("objc.scrbl" (multi-page) (foreign)))) diff --git a/collects/ffi/objc.ss b/collects/ffi/objc.ss index 4a39ee07a4..edac8c149a 100644 --- a/collects/ffi/objc.ss +++ b/collects/ffi/objc.ss @@ -1,655 +1,27 @@ -#lang scheme/base -(require scheme/foreign - scheme/stxparam - (for-syntax scheme/base)) -(unsafe!) +#lang racket/base +(require (for-syntax racket/base)) -(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) +(define-syntax-rule (provide-except-unsafe lib u! id ...) (begin - (provide* (unsafe id)) - (define-objc/private id id type))) - -;; ---------------------------------------- - -(provide _id _Class _Protocol _BOOL _SEL _Ivar - make-objc_super _objc_super) - -(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 _Protocol (make-ctype _id - (lambda (v) v) - (lambda (p) - (when p (cpointer-push-tag! p 'Protocol)) - 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 objc_getProtocol (_fun _string -> _Protocol)) - -(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 class_addProtocol (_fun _Class _Protocol -> _BOOL)) - -(define-objc/private objc_msgSend _fpointer) -(define-objc/private objc_msgSend_fpret _fpointer) -(define-objc/private objc_msgSend_stret _fpointer) -(define-objc/private objc_msgSendSuper _fpointer) -(define objc_msgSendSuper_fpret objc_msgSendSuper) ; why no fpret variant? -(define-objc/private objc_msgSendSuper_stret _fpointer) - -(define sizes-for-direct-struct-results - (case (string->symbol (path->string (system-library-subpath #f))) - [(i386-macosx i386-darwin) '(1 2 4 8)] - [(ppc-macosx ppc-darwin) '(1 2 3 4)] - [(x86_64-macosx x86_86-darwin) - ;; Do we need more analysis for unaligned fields? - '(1 2 3 4 5 6 7 8)])) - -(define (lookup-send types msgSends msgSend msgSend_fpret msgSend_stret first-arg-type) - ;; First type in `types' vector is the result type - (or (hash-ref msgSends types #f) - (let ([ret-layout (ctype->layout (vector-ref types 0))]) - (if (and (list? ret-layout) - (not (memq (ctype-sizeof (vector-ref types 0)) - sizes-for-direct-struct-results))) - ;; Structure return type: - (let* ([pre-m (function-ptr msgSend_stret - (_cprocedure - (list* _pointer first-arg-type _SEL (cdr (vector->list types))) - _void))] - [m (lambda args - (let ([v (malloc (vector-ref types 0))]) - (apply pre-m v args) - (ptr-ref v (vector-ref types 0))))]) - (hash-set! msgSends types m) - m) - ;; Non-structure return type: - (let ([m (function-ptr (if (memq ret-layout - '(float double double*)) - msgSend_fpret - msgSend) - (_cprocedure - (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 objc_msgSend_stret _id)) -(provide* (unsafe objc_msgSend/typed)) - -(define msgSendSupers (make-hash)) -(define (objc_msgSendSuper/typed types) - (lookup-send types msgSendSupers objc_msgSendSuper objc_msgSendSuper_fpret objc_msgSendSuper_stret _pointer)) -(provide* (unsafe objc_msgSendSuper/typed)) - -;; ---------------------------------------- - -(provide* (unsafe 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) ...))])) - -(provide* (unsafe import-protocol)) -(define-syntax (import-protocol stx) - (syntax-case stx () - [(_ id) - (quasisyntax/loc stx - (define id (objc_getProtocol #,(symbol->string (syntax-e #'id)))))] - [(_ id ...) - (syntax/loc stx (begin (import-protocol id) ...))])) - -;; ---------------------------------------- -;; iget-value and set-ivar! work only with fields that contain Scheme values - -(provide* (unsafe get-ivar) (unsafe set-ivar!)) - -(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 (get-ivar 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 (set-ivar! 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* (unsafe 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* (unsafe tell) (unsafe tellv)) -(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-syntax-rule (tellv a ...) - (tell #:type _void a ...)) - -(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* (unsafe define-objc-class) - (unsafe define-objc-mixin) - self super-tell) - -(define-for-syntax ((check-id stx what) id) - (unless (identifier? id) - (raise-syntax-error #f - (format "expected an identifier for ~a" what) - stx - id))) - -(define-syntax (define-objc-class stx) - (syntax-case stx () - [(_ id superclass #:mixins (mixin ...) #:protocols (proto ...) (ivar ...) method ...) - (begin - ((check-id stx "class definition") #'id) - (for-each (check-id stx "instance variable") - (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: - #'((-a _void (dealloc) (void)))))]) - (syntax/loc stx - (begin - (define superclass-id superclass) - (define id (objc_allocateClassPair superclass-id id-str 0)) - (void (class_addProtocol id proto)) ... - (add-ivar id 'ivar) ... - (let-syntax ([ivar (make-ivar-form 'ivar)] ...) - (add-method whole-stx id superclass-id method) ... - (mixin id superclass-id '(ivar ...)) ... - (add-method whole-stx id superclass-id dealloc-method) ... - (void)) - (objc_registerClassPair id))))))] - [(_ id superclass (ivar ...) method ...) - #'(define-objc-class id superclass #:mixins () #:protocols () (ivar ...) method ...)] - [(_ id superclass #:mixins (mixin ...) (ivar ...) method ...) - #'(define-objc-class id superclass #:mixins (mixin ...) #:protocols () (ivar ...) method ...)] - [(_ id superclass #:protocols (proto ...) (ivar ...) method ...) - #'(define-objc-class id superclass #:mixins () #:protocols (proto ...) (ivar ...) method ...)])) - -(define (check-expected-ivars id got-ivars expected-ivars) - (when (ormap (lambda (s) (not (memq s got-ivars))) - expected-ivars) - (error id "expected to mix into class with at least ivars: ~s; mixed into class with ivars: ~s" - expected-ivars - got-ivars))) - -(define-syntax (define-objc-mixin stx) - (syntax-case stx () - [(_ (id superclass-id) #:mixins (mixin ...) #:protocols (proto ...) (ivar ...) method ...) - (begin - ((check-id stx "class definition") #'id) - ((check-id stx "superclass") #'superclass-id) - (for-each (check-id stx "instance variable") - (syntax->list #'(ivar ...))) - (with-syntax ([whole-stx stx] - [(mixin-id ...) (generate-temporaries #'(mixin ...))] - [(proto-id ...) (generate-temporaries #'(proto ...))]) - (syntax/loc stx - (define id - (let ([mixin-id mixin] ... - [protocol-id proto] ...) - (lambda (to-id superclass-id ivars) - (check-expected-ivars 'id ivars '(ivar ...)) - (void (class_addProtocol to-id proto-id)) ... - (let-syntax ([ivar (make-ivar-form 'ivar)] ...) - (add-method whole-stx to-id superclass-id method) ... - (void)) - (mixin-id to-id superclass-id ivars) ...))))))] - [(_ (id superclass) (ivar ...) method ...) - #'(define-objc-mixin (id superclass) #:mixins () #:protocols () (ivar ...) method ...)] - [(_ (id superclass) #:mixins (mixin ...) (ivar ...) method ...) - #'(define-objc-mixin (id superclass) #:mixins (mixin ...) #:protocols () (ivar ...) method ...)] - [(_ (id superclass) #:protocols (proto ...) (ivar ...) method ...) - #'(define-objc-mixin (id superclass) #:mixins () #:protocols (proto ...) (ivar ...) method ...)])) - -(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 (set-ivar! self sym val))] - [(_ arg ...) - (quasisyntax/loc stx (#,(quasisyntax/loc #'sym #'(get-ivar self sym)) - arg ...))] - [_ (quasisyntax/loc #'sym (get-ivar 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/list ([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 #'-) - (free-identifier=? #'kind #'+a) - (free-identifier=? #'kind #'-a)) - (let ([id #'id] - [args (syntax->list #'(arg ...))] - [in-class? (or (free-identifier=? #'kind #'+) - (free-identifier=? #'kind #'+a))]) - (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 () - [(_ _ _ #:mixins _ #:protocols _ [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)] - [atomic? (or (free-identifier=? #'kind #'+a) - (free-identifier=? #'kind #'-a))]) - (quasisyntax/loc stx - (let ([rt result-type] - [arg-id arg-type] ...) - (void (class_addMethod in-cls - (sel_registerName id-str) - #,(syntax/loc #'m - (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 #:atomic? atomic? #:keep save-method! _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 ...))])) - -;; -------------------------------------------------- - -(provide* (unsafe objc-is-a?)) - -(define (objc-is-a? v c) - (ptr-equal? (object_getClass v) c)) - -;; ---------------------------------------- - -(define-unsafer objc-unsafe!) - + (require lib) + (provide (except-out (all-from-out lib) id ...)) + (define-syntax (u! stx) + (syntax-case stx () + [(_) (with-syntax ([lib+ids (datum->syntax stx '(lib id ...))]) + #'(require (only-in . lib+ids)))])))) + +(provide-except-unsafe + racket/unsafe/ffi/objc objc-unsafe! + + objc_msgSend/typed + objc_msgSendSuper/typed + import-class + import-protocol + get-ivar set-ivar! + selector + tell tellv + define-objc-class + define-objc-mixin + objc-is-a?) + +(provide objc-unsafe!) diff --git a/collects/ffi/private/objc-doc-unsafe.ss b/collects/ffi/private/objc-doc-unsafe.ss deleted file mode 100644 index ab8ec571e2..0000000000 --- a/collects/ffi/private/objc-doc-unsafe.ss +++ /dev/null @@ -1,28 +0,0 @@ -#lang scheme/base - -(require ffi/objc) - -(error 'objc-unsafe! "only `for-label' use in the documentation") - -(objc-unsafe!) - -(provide (protect-out objc_msgSend/typed - objc_msgSendSuper/typed - import-class - import-protocol - get-ivar set-ivar! - selector - tell tellv - define-objc-class - define-objc-mixin - objc_lookUpClass - objc_getProtocol - sel_registerName - objc_allocateClassPair - objc_registerClassPair - object_getClass - class_addIvar - object_getInstanceVariable - object_setInstanceVariable - objc-is-a?) - (all-from-out ffi/objc)) diff --git a/collects/racket/unsafe/ffi/alloc.rkt b/collects/racket/unsafe/ffi/alloc.rkt new file mode 100644 index 0000000000..9de090e928 --- /dev/null +++ b/collects/racket/unsafe/ffi/alloc.rkt @@ -0,0 +1,70 @@ +#lang scheme/base +(require scheme/foreign + "atomic.ss") +(unsafe!) + +(provide allocator deallocator retainer + (rename-out [deallocator releaser])) + +(define allocated (make-weak-hasheq)) + +(define (deallocate v) + ;; Called as a finalizer, we we assume that the + ;; enclosing thread will not be interrupted. + (let ([ds (hash-ref allocated v #f)]) + (when ds + (hash-remove! allocated v) + (for ([d (in-list ds)]) + (d v))))) + +(define ((allocator d) proc) + (rename + (lambda args + (dynamic-wind + start-atomic + (lambda () + (let ([v (apply proc args)]) + (hash-set! allocated v (list d)) + (register-finalizer v deallocate) + v)) + end-atomic)) + proc)) + +(define ((deallocator [get-arg car]) proc) + (rename + (lambda args + (dynamic-wind + start-atomic + (lambda () + (apply proc args) + (let ([v (get-arg args)]) + (let ([ds (hash-ref allocated v #f)]) + (when ds + (if (null? (cdr ds)) + (hash-remove! allocated v) + (hash-set! allocated (cdr ds))))))) + end-atomic)) + proc)) + +(define ((retainer d [get-arg car]) proc) + (rename + (lambda args + (dynamic-wind + start-atomic + (lambda () + (apply proc args) + (let ([v (get-arg args)]) + (let ([ds (hash-ref allocated v null)]) + (hash-set! allocated v (cons d ds))))) + end-atomic)) + proc)) + +(define (rename new orig) + (and orig + (let ([n (object-name orig)] + [new (procedure-reduce-arity + new + (procedure-arity orig))]) + (if n + (procedure-rename new n) + new)))) diff --git a/collects/racket/unsafe/ffi/atomic.rkt b/collects/racket/unsafe/ffi/atomic.rkt new file mode 100644 index 0000000000..143859f46f --- /dev/null +++ b/collects/racket/unsafe/ffi/atomic.rkt @@ -0,0 +1,99 @@ +#lang scheme/base +(require scheme/foreign + (for-syntax scheme/base)) +(unsafe!) + +(provide (protect-out start-atomic + end-atomic + call-as-atomic + call-as-nonatomic)) + +(define start-atomic + (get-ffi-obj 'scheme_start_atomic #f (_fun -> _void))) + +(define end-atomic + (get-ffi-obj 'scheme_end_atomic #f (_fun -> _void))) + +(define monitor-owner #f) + +;; An exception may be constructed while we're entered: +(define entered-err-string-handler + (lambda (s n) + (call-as-nonatomic + (lambda () + ((error-value->string-handler) s n))))) + +(define old-paramz #f) +(define old-break-paramz #f) + +(define exited-key (gensym 'as-exit)) +(define lock-tag (make-continuation-prompt-tag 'lock)) + +(define (call-as-atomic f) + (unless (and (procedure? f) + (procedure-arity-includes? f 0)) + (raise-type-error 'call-as-atomic "procedure (arity 0)" f)) + (cond + [(eq? monitor-owner (current-thread)) + (f)] + [else + (with-continuation-mark + exited-key + #f + (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () + (start-atomic) + (set! monitor-owner (current-thread))) + (lambda () + (set! old-paramz (current-parameterization)) + (set! old-break-paramz (current-break-parameterization)) + (parameterize ([error-value->string-handler entered-err-string-handler]) + (parameterize-break + #f + (call-with-exception-handler + (lambda (exn) + ;; Get out of atomic region before letting + ;; an exception handler work + (if (continuation-mark-set-first #f exited-key) + exn ; defer to previous exn handler + (abort-current-continuation + lock-tag + (lambda () (raise exn))))) + f)))) + (lambda () + (set! monitor-owner #f) + (set! old-paramz #f) + (set! old-break-paramz #f) + (end-atomic)))) + lock-tag + (lambda (t) (t))))])) + +(define (call-as-nonatomic f) + (unless (and (procedure? f) + (procedure-arity-includes? f 0)) + (raise-type-error 'call-as-nonatomic "procedure (arity 0)" f)) + (unless (eq? monitor-owner (current-thread)) + (error 'call-as-nonatomic "not in atomic area for ~e" f)) + (let ([paramz old-paramz] + [break-paramz old-break-paramz]) + (with-continuation-mark + exited-key + #t ; disables special exception handling + (call-with-parameterization + paramz + (lambda () + (call-with-break-parameterization + break-paramz + (lambda () + (dynamic-wind + (lambda () + (set! monitor-owner #f) + (end-atomic)) + f + (lambda () + (set! old-paramz paramz) + (set! old-break-paramz break-paramz) + (start-atomic) + (set! monitor-owner (current-thread))))))))))) diff --git a/collects/racket/unsafe/ffi/define.rkt b/collects/racket/unsafe/ffi/define.rkt new file mode 100644 index 0000000000..73975f038c --- /dev/null +++ b/collects/racket/unsafe/ffi/define.rkt @@ -0,0 +1,75 @@ +#lang scheme/base +(require (for-syntax syntax/parse + scheme/base) + scheme/foreign) +(unsafe!) + +(provide (protect-out define-ffi-definer) + provide-protected + make-not-available) + +(define (make-not-available id) + (lambda () + (lambda args + (error id "implementation not found; ~a" + (if (null? args) + "no arguments provided" + (apply + string-append + "arguments:" + (let loop ([args args]) + (if (null? args) + null + (cons (format " ~e" + (car args)) + (loop (cdr args))))))))))) + +(define-syntax-rule (provide-protected p ...) + (provide (protect-out p ...))) + +(define-syntax (define-ffi-definer stx) + (syntax-parse stx + [(_ define-:id ffi-lib:expr + (~seq (~or (~optional (~seq #:provide provide-form:id) + #:defaults ([provide-form #'#f]) + #:name "#:provide keyword") + (~optional (~seq #:define define-form:id) + #:defaults ([define-form #'define]) + #:name "#:define keyword") + (~optional (~seq #:default-make-fail default-make-fail:expr) + #:defaults ([default-make-fail #'(lambda (id) #f)]) + #:name "#:default-make-fail keyword")) + ...)) + #`(begin + (define the-ffi-lib + (let ([v ffi-lib]) + (if (or (not v) (ffi-lib? v)) + v + (raise-type-error 'define-ffi-definer + "ffi-lib or #f" + v)))) + (define-syntax define- + (with-syntax ([provide #'provide-form]) + (lambda (stx) + (syntax-parse stx + [(_ s-id:id type:expr (~seq (~or (~optional (~seq #:c-id c-id:id) + #:defaults ([c-id #'s-id]) + #:name "#:c-id keyword") + (~optional (~seq #:wrap wrapper:expr) + #:defaults ([wrapper #'values]) + #:name "#:wrap keyword") + (~optional (~or (~seq #:make-fail make-fail:expr) + (~seq #:fail fail:expr)) + #:defaults ([make-fail #'default-make-fail]))) + (... ...))) + (with-syntax ([fail (if (attribute fail) + #'fail + #'(make-fail 's-id))]) + (with-syntax ([def (syntax/loc stx + (define-form s-id (wrapper (get-ffi-obj 'c-id the-ffi-lib type fail))))]) + (if (syntax-e #'provide) + (syntax/loc stx + (begin + (provide s-id) + def)) + #'def)))])))))])) diff --git a/collects/racket/unsafe/ffi/objc.rkt b/collects/racket/unsafe/ffi/objc.rkt new file mode 100644 index 0000000000..da44db8d7d --- /dev/null +++ b/collects/racket/unsafe/ffi/objc.rkt @@ -0,0 +1,649 @@ +#lang racket/base +(require racket/unsafe/ffi + racket/stxparam + (for-syntax racket/base)) + +(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 _Class _Protocol _BOOL _SEL _Ivar + make-objc_super _objc_super) + +(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 _Protocol (make-ctype _id + (lambda (v) v) + (lambda (p) + (when p (cpointer-push-tag! p 'Protocol)) + 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 objc_getProtocol (_fun _string -> _Protocol)) + +(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 class_addProtocol (_fun _Class _Protocol -> _BOOL)) + +(define-objc/private objc_msgSend _fpointer) +(define-objc/private objc_msgSend_fpret _fpointer) +(define-objc/private objc_msgSend_stret _fpointer) +(define-objc/private objc_msgSendSuper _fpointer) +(define objc_msgSendSuper_fpret objc_msgSendSuper) ; why no fpret variant? +(define-objc/private objc_msgSendSuper_stret _fpointer) + +(define sizes-for-direct-struct-results + (case (string->symbol (path->string (system-library-subpath #f))) + [(i386-macosx i386-darwin) '(1 2 4 8)] + [(ppc-macosx ppc-darwin) '(1 2 3 4)] + [(x86_64-macosx x86_86-darwin) + ;; Do we need more analysis for unaligned fields? + '(1 2 3 4 5 6 7 8)])) + +(define (lookup-send types msgSends msgSend msgSend_fpret msgSend_stret first-arg-type) + ;; First type in `types' vector is the result type + (or (hash-ref msgSends types #f) + (let ([ret-layout (ctype->layout (vector-ref types 0))]) + (if (and (list? ret-layout) + (not (memq (ctype-sizeof (vector-ref types 0)) + sizes-for-direct-struct-results))) + ;; Structure return type: + (let* ([pre-m (function-ptr msgSend_stret + (_cprocedure + (list* _pointer first-arg-type _SEL (cdr (vector->list types))) + _void))] + [m (lambda args + (let ([v (malloc (vector-ref types 0))]) + (apply pre-m v args) + (ptr-ref v (vector-ref types 0))))]) + (hash-set! msgSends types m) + m) + ;; Non-structure return type: + (let ([m (function-ptr (if (memq ret-layout + '(float double double*)) + msgSend_fpret + msgSend) + (_cprocedure + (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 objc_msgSend_stret _id)) +(provide objc_msgSend/typed) + +(define msgSendSupers (make-hash)) +(define (objc_msgSendSuper/typed types) + (lookup-send types msgSendSupers objc_msgSendSuper objc_msgSendSuper_fpret objc_msgSendSuper_stret _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) ...))])) + +(provide import-protocol) +(define-syntax (import-protocol stx) + (syntax-case stx () + [(_ id) + (quasisyntax/loc stx + (define id (objc_getProtocol #,(symbol->string (syntax-e #'id)))))] + [(_ id ...) + (syntax/loc stx (begin (import-protocol id) ...))])) + +;; ---------------------------------------- +;; iget-value and set-ivar! work only with fields that contain Racket values + +(provide get-ivar set-ivar!) + +(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 (get-ivar 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 _racket)))) + + +(define-syntax (set-ivar! 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 _racket 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 tellv) +(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-syntax-rule (tellv a ...) + (tell #:type _void a ...)) + +(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 + define-objc-mixin + self super-tell) + +(define-for-syntax ((check-id stx what) id) + (unless (identifier? id) + (raise-syntax-error #f + (format "expected an identifier for ~a" what) + stx + id))) + +(define-syntax (define-objc-class stx) + (syntax-case stx () + [(_ id superclass #:mixins (mixin ...) #:protocols (proto ...) (ivar ...) method ...) + (begin + ((check-id stx "class definition") #'id) + (for-each (check-id stx "instance variable") + (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: + #'((-a _void (dealloc) (void)))))]) + (syntax/loc stx + (begin + (define superclass-id superclass) + (define id (objc_allocateClassPair superclass-id id-str 0)) + (void (class_addProtocol id proto)) ... + (add-ivar id 'ivar) ... + (let-syntax ([ivar (make-ivar-form 'ivar)] ...) + (add-method whole-stx id superclass-id method) ... + (mixin id superclass-id '(ivar ...)) ... + (add-method whole-stx id superclass-id dealloc-method) ... + (void)) + (objc_registerClassPair id))))))] + [(_ id superclass (ivar ...) method ...) + #'(define-objc-class id superclass #:mixins () #:protocols () (ivar ...) method ...)] + [(_ id superclass #:mixins (mixin ...) (ivar ...) method ...) + #'(define-objc-class id superclass #:mixins (mixin ...) #:protocols () (ivar ...) method ...)] + [(_ id superclass #:protocols (proto ...) (ivar ...) method ...) + #'(define-objc-class id superclass #:mixins () #:protocols (proto ...) (ivar ...) method ...)])) + +(define (check-expected-ivars id got-ivars expected-ivars) + (when (ormap (lambda (s) (not (memq s got-ivars))) + expected-ivars) + (error id "expected to mix into class with at least ivars: ~s; mixed into class with ivars: ~s" + expected-ivars + got-ivars))) + +(define-syntax (define-objc-mixin stx) + (syntax-case stx () + [(_ (id superclass-id) #:mixins (mixin ...) #:protocols (proto ...) (ivar ...) method ...) + (begin + ((check-id stx "class definition") #'id) + ((check-id stx "superclass") #'superclass-id) + (for-each (check-id stx "instance variable") + (syntax->list #'(ivar ...))) + (with-syntax ([whole-stx stx] + [(mixin-id ...) (generate-temporaries #'(mixin ...))] + [(proto-id ...) (generate-temporaries #'(proto ...))]) + (syntax/loc stx + (define id + (let ([mixin-id mixin] ... + [protocol-id proto] ...) + (lambda (to-id superclass-id ivars) + (check-expected-ivars 'id ivars '(ivar ...)) + (void (class_addProtocol to-id proto-id)) ... + (let-syntax ([ivar (make-ivar-form 'ivar)] ...) + (add-method whole-stx to-id superclass-id method) ... + (void)) + (mixin-id to-id superclass-id ivars) ...))))))] + [(_ (id superclass) (ivar ...) method ...) + #'(define-objc-mixin (id superclass) #:mixins () #:protocols () (ivar ...) method ...)] + [(_ (id superclass) #:mixins (mixin ...) (ivar ...) method ...) + #'(define-objc-mixin (id superclass) #:mixins (mixin ...) #:protocols () (ivar ...) method ...)] + [(_ (id superclass) #:protocols (proto ...) (ivar ...) method ...) + #'(define-objc-mixin (id superclass) #:mixins () #:protocols (proto ...) (ivar ...) method ...)])) + +(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 (set-ivar! self sym val))] + [(_ arg ...) + (quasisyntax/loc stx (#,(quasisyntax/loc #'sym #'(get-ivar self sym)) + arg ...))] + [_ (quasisyntax/loc #'sym (get-ivar 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/list ([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 #'-) + (free-identifier=? #'kind #'+a) + (free-identifier=? #'kind #'-a)) + (let ([id #'id] + [args (syntax->list #'(arg ...))] + [in-class? (or (free-identifier=? #'kind #'+) + (free-identifier=? #'kind #'+a))]) + (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 () + [(_ _ _ #:mixins _ #:protocols _ [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)] + [atomic? (or (free-identifier=? #'kind #'+a) + (free-identifier=? #'kind #'-a))]) + (quasisyntax/loc stx + (let ([rt result-type] + [arg-id arg-type] ...) + (void (class_addMethod in-cls + (sel_registerName id-str) + #,(syntax/loc #'m + (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 #:atomic? atomic? #:keep save-method! _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 ...))])) + +;; -------------------------------------------------- + +(provide objc-is-a?) + +(define (objc-is-a? v c) + (ptr-equal? (object_getClass v) c)) diff --git a/collects/scribblings/foreign/alloc.scrbl b/collects/scribblings/foreign/alloc.scrbl new file mode 100644 index 0000000000..624392b2ac --- /dev/null +++ b/collects/scribblings/foreign/alloc.scrbl @@ -0,0 +1,72 @@ +#lang scribble/doc +@(require "utils.ss" + (for-label racket/unsafe/ffi/alloc + racket/unsafe/ffi/define + racket/unsafe/ffi/atomic)) + +@title{Allocation and Finalization} + +@defmodule[racket/unsafe/ffi/alloc]{The +@schememodname[racket/unsafe/ffi/alloc] library provides utilities for +ensuring that values allocated through foreign functions are reliably +deallocated.} + +@defproc[((allocator [dealloc (any/c . -> . any)]) [alloc procedure?]) procedure?]{ + +Produces a procedure that behaves like @scheme[alloc], but the result +of @scheme[alloc] is given a finalizer that calls @scheme[dealloc] on +the result if it is not otherwise freed through a deallocator (as +designated with @scheme[deallocator]). In addition, @scheme[alloc] is +called in atomic mode (see @scheme[start-atomic]); its result is +received and registered in atomic mode, so that the result is reliably +freed. + +The @scheme[dealloc] procedure itself need not be specifically +designated a deallocator (via @scheme[deallocator]). If a deallocator +is called explicitly, it need not be the same as @scheme[dealloc].} + +@deftogether[( +@defproc[((deallocator [get-arg (list? . -> . any/c) car]) [dealloc procedure?]) + procedure?] +@defproc[((releaser [get-arg (list? . -> . any/c) car]) [dealloc procedure?]) + procedure?] +)]{ + +Produces a procedure that behaves like @scheme[dealloc]. The +@scheme[dealloc] procedure is called in atomic mode (see +@scheme[start-atomic]), and the reference count on one of its +arguments is decremented; if the reference count reaches zero, no +finalizer associated by an @scheme[allocator]- or +@scheme[referencer]-wrapped procedure is invoked when the value +becomes inaccessible. + +The optional @scheme[get-arg] procedure determines which of +@scheme[dealloc]'s arguments correspond to the released object; +@scheme[get-arg] receives a list of arguments passed to +@scheme[dealloc], so the default @scheme[car] selects the first one. + +The @scheme[releaser] procedure is a synonym for +@scheme[deallocator].} + + +@defproc[((retainer [release (any/c . -> . any)] + [get-arg (list? . -> . any/c) car]) + [retain procedure?]) + procedure?]{ + +Produces a procedure that behaves like @scheme[retain]. The procedure +is called in atomic mode (see @scheme[start-atomic]), and the +reference count on one of its arguments is incremented, with +@scheme[release] recorded as the corresponding release procedure to be +called by the finalizer on the retained object (unless some +deallocator, as wrapped by @scheme[deallocate], is explicitly called +first). + +The optional @scheme[get-arg] procedure determines which of +@scheme[retain]'s arguments correspond to the retained object; +@scheme[get-arg] receives a list of arguments passed to +@scheme[retain], so the default @scheme[car] selects the first one. + +The @scheme[release] procedure itself need not be specifically +designated a deallocator (via @scheme[deallocator]). If a deallocator +is called explicitly, it need not be the same as @scheme[release].} diff --git a/collects/scribblings/foreign/atomic.scrbl b/collects/scribblings/foreign/atomic.scrbl new file mode 100644 index 0000000000..f85822eaac --- /dev/null +++ b/collects/scribblings/foreign/atomic.scrbl @@ -0,0 +1,44 @@ +#lang scribble/doc +@(require "utils.ss" + (for-label racket/unsafe/ffi/atomic)) + +@title{Atomic Execution} + +@defmodule[racket/unsafe/ffi/atomic] + +@deftogether[( +@defproc[(start-atomic) void?] +@defproc[(end-atomic) void?] +)]{ + +Disables and enables context switches at the level of Scheme +threads. Calls to @scheme[start-atomic] and @scheme[end-atomic] can be +nested. + +Using @scheme[call-as-atomic] is somewhat safer, in that +@scheme[call-as-atomic] correctly catches exceptions and re-raises +them after exiting atomic mode. For simple uses, however, +@scheme[start-atomic] and @scheme[end-atomic] are faster.} + + +@defproc[(call-as-atomic [thunk (-> any)]) any]{ + +Calls @scheme[thunk] in atomic mode. If @scheme[thunk] raises and +exception, the exception is caught and re-raised after exiting atomic +mode. + +When @scheme[call-as-atomic] is used in the dynamic extent of +@scheme[call-as-atomic], then @scheme[thunk] is simply called directly +(as a tail call).} + + +@defproc[(call-as-nonatomic [thunk (-> any)]) any]{ + +Within the dynamic extent of a @scheme[call-as-atomic], calls +@scheme[thunk] in non-atomic mode. Beware that the current thread +maybe suspended or terminated by other threads during @scheme[thunk], +in which case the call never returns. + +When used not in the dynamic extent of @scheme[call-as-atomic], +@scheme[call-as-nonatomic] raises @scheme[exn:fail:contract].} + diff --git a/collects/scribblings/foreign/define.scrbl b/collects/scribblings/foreign/define.scrbl new file mode 100644 index 0000000000..8e827056d9 --- /dev/null +++ b/collects/scribblings/foreign/define.scrbl @@ -0,0 +1,101 @@ +#lang scribble/doc +@(require "utils.ss" + (for-label racket/unsafe/ffi/define + racket/unsafe/ffi/alloc)) + +@title{Defining Bindings} + +@defmodule[racket/unsafe/ffi/define] + +@defform/subs[(define-ffi-definer define-id ffi-lib-expr + option ...) + ([option (code:line #:provide provide-id) + (code:line #:define core-define-id) + (code:line #:default-make-fail default-make-fail-expr)])]{ + +Binds @scheme[define-id] as a definition form to extract bindings from +the library produced by @scheme[ffi-lib-expr]. The syntax of +@scheme[define-id] is + +@specform/subs[(define-id id type-expr + bind-option ...) + ([bind-option (code:line #:c-id c-id) + (code:line #:wrap wrap-expr) + (code:line #:make-fail make-fail-expr) + (code:line #:fail fail-expr)])] + +A @scheme[define-id] form binds @scheme[id] by extracting a binding +with the name @scheme[c-id] from the library produced by +@scheme[ffi-lib-expr], where @scheme[c-id] defaults to @scheme[id]. +The other options support further wrapping and configuration: + +@itemize[ + + @item{Before the extracted result is bound as @scheme[id], it is + passed to the result of @scheme[wrap-expr], which defaults to + @scheme[values]. Expressions such as @scheme[(allocator + _delete)] or @scheme[(deallocator)] are useful as + @scheme[wrap-expr]s.} + + @item{The @scheme[#:make-fail] and @scheme[#:fail] options are + mutually exclusive; if @scheme[make-fail-expr] is provided, it + is applied to @scheme['#,@scheme[id]] to obtain the last + argument to @scheme[get-ffi-obj]; if @scheme[fail-expr] is + provided, it is supplied directly as the last argument to + @scheme[get-ffi-obj]. The @scheme[make-not-available] function + is useful as @scheme[make-fail-expr] to cause a use of + @scheme[id] to report an error when it is applied if + @scheme[c-id] was not found in the foreign library.} + +] + +If @scheme[provide-id] is provided to @scheme[define-ffi-definer], then +@scheme[define-id] also provides its binding using +@scheme[provide-id]. The @scheme[provide-protected] form is usually a +good choice for @scheme[provide-id]. + +If @scheme[core-define-id] is provided to @scheme[define-ffi-definer], +then @scheme[code-define-id] is used in place of @scheme[define] in +the expansion of @scheme[define-id] for each binding. + +If @scheme[default-make-fail-expr] is provided to +@scheme[define-ffi-definer], it serves as the default +@scheme[#:make-fail] value for @scheme[define-id]. + +For example, + +@schemeblock[ + (define-ffi-definer define-gtk gtk-lib) +] + +binds @scheme[define-gtk] to extract FFI bindings from +@scheme[gtk-lib], so that @scheme[gtk_rc_parse] could be bound as + +@schemeblock[ + (define-gtk gtk_rc_parse (_fun _path -> _void)) +] + +If @tt{gtk_rc_parse} is not found, then @scheme[define-gtk] reports an +error immediately. If @scheme[define-gtk] is instead defined with + +@schemeblock[ + (define-ffi-definer define-gtk gtk-lib + #:default-make-fail make-not-available) +] + +then if @tt{gtk_rc_parse} is not found in @scheme[gtk-lib], an error +is reported only when @scheme[gtk_rc_parse] is called.} + + +@defproc[(make-not-available [name symbol?]) (#:rest list? -> any/c)]{ + +Returns a procedure that takes any number of arguments and reports an +error message from @scheme[name]. This function is intended for using +with @scheme[#:make-fail] or @scheme[#:default-make-fail] in +@scheme[define-ffi-definer]} + +@defform[(provide-protected provide-spec ...)]{ + +Equivalent to @scheme[(provide (protect-out provide-spec ...))]. The +@scheme[provide-protected] identifier is useful with +@scheme[#:provide] in @scheme[define-ffi-definer].} diff --git a/collects/scribblings/foreign/derived.scrbl b/collects/scribblings/foreign/derived.scrbl index a6d22d1923..bd05846359 100644 --- a/collects/scribblings/foreign/derived.scrbl +++ b/collects/scribblings/foreign/derived.scrbl @@ -1,7 +1,15 @@ #lang scribble/doc @(require "utils.ss") -@title{Derived Utilities} +@title[#:style 'toc]{Derived Utilities} + +@local-table-of-contents[] + +@; ------------------------------------------------------------ + +@include-section["define.scrbl"] + +@; ------------------------------------------------------------ @section[#:tag "foreign:tagged-pointers"]{Tagged C Pointer Types} @@ -60,10 +68,6 @@ type produced by @scheme[_cpointer/null] type. Finally, @schemevarfont{id}@schemeidfont{-tag} is defined as an accessor to obtain a tag. The tag is the string form of @schemevarfont{id}.} -@; ---------------------------------------- - -@subsection{Unsafe Tagged C Pointer Functions} - @defproc*[([(cpointer-has-tag? [cptr any/c] [tag any/c]) boolean?] [(cpointer-push-tag! [cptr any/c] [tag any/c]) void])]{ @@ -151,9 +155,6 @@ Converts the @scheme[cvec] C vector object to a list of values.} Converts the list @scheme[lst] to a C vector of the given @scheme[type].} -@; ---------------------------------------- - -@subsection{Unsafe C Vector Construction} @defproc[(make-cvector* [cptr any/c] [type ctype?] [length exact-nonnegative-integer?]) @@ -166,9 +167,9 @@ situations where the @scheme[type] and @scheme[length] are known.} @; ------------------------------------------------------------ -@section{SRFI-4 Vectors} +@section[#:tag "homogeneous-vectors"]{Homogenous Vectors} -SRFI-4 vectors are similar to C vectors (see +Homogenous vectors are similar to C vectors (see @secref["foreign:cvector"]), except that they define different types of vectors, each with a hard-wired type. @@ -271,3 +272,14 @@ aliases for @schemeidfont{byte} operations.} @srfi-4-vector[f32 _float] @srfi-4-vector[f64 _double*] +@; ------------------------------------------------------------ + +@include-section["alloc.scrbl"] + +@; ------------------------------------------------------------ + +@include-section["atomic.scrbl"] + +@; ------------------------------------------------------------ + +@include-section["objc.scrbl"] diff --git a/collects/scribblings/foreign/foreign.scrbl b/collects/scribblings/foreign/foreign.scrbl index 2e553f7967..1089ed3704 100644 --- a/collects/scribblings/foreign/foreign.scrbl +++ b/collects/scribblings/foreign/foreign.scrbl @@ -1,15 +1,15 @@ #lang scribble/doc @(require "utils.ss") -@title{@bold{FFI}: PLT Scheme Foreign Interface} +@title{@bold{FFI}: Racket Foreign Interface} @author["Eli Barzilay"] @defmodule[racket/unsafe/ffi #:use-sources ('#%foreign)] The @schememodname[racket/unsafe/ffi] library enables the direct use of -C-based APIs within Scheme programs---without writing any new C -code. From the Scheme perspective, functions and data with a C-based +C-based APIs within Racket programs---without writing any new C +code. From the Racket perspective, functions and data with a C-based API are @idefterm{foreign}, hence the term @defterm{foreign interface}. Furthermore, since most APIs consist mostly of functions, the foreign interface is sometimes called a @defterm{foreign function @@ -24,6 +24,5 @@ interface}, abbreviated @deftech{FFI}. @include-section["misc.scrbl"] @include-section["derived.scrbl"] @include-section["unexported.scrbl"] -@include-section["unsafe.scrbl"] @index-section[] diff --git a/collects/scribblings/foreign/intro.scrbl b/collects/scribblings/foreign/intro.scrbl index 7fd62d3783..1ed309362a 100644 --- a/collects/scribblings/foreign/intro.scrbl +++ b/collects/scribblings/foreign/intro.scrbl @@ -7,11 +7,11 @@ Although using the FFI requires writing no new C code, it provides very little insulation against the issues that C programmer faces related to safety and memory management. An FFI programmer must be particularly aware of memory management issues for data that spans the -Scheme--C divide. Thus, this manual relies in many ways on the -information in @|InsideMzScheme|, which defines how PLT Scheme +Racket--C divide. Thus, this manual relies in many ways on the +information in @|InsideMzScheme|, which defines how Racket interacts with C APIs in general. -Since using the FFI entails many safety concerns that Scheme +Since using the FFI entails many safety concerns that Racket programmers can normally ignore, the library name includes @schemeidfont{unsafe}. Importing the library macro should be considered as a declaration that your code is itself unsafe, therefore diff --git a/collects/scribblings/foreign/libs.scrbl b/collects/scribblings/foreign/libs.scrbl index 3be83de0db..f2757fb696 100644 --- a/collects/scribblings/foreign/libs.scrbl +++ b/collects/scribblings/foreign/libs.scrbl @@ -15,10 +15,6 @@ Returns @scheme[#t] if @scheme[v] is the result of @scheme[ffi-lib], @scheme[#f] otherwise.} -@; ---------------------------------------------------------------------- - -@section{Unsafe Library Functions} - @defproc[(ffi-lib [path (or/c path-string? #f)] [version (or/c string? (listof (or/c string? #f)) #f) #f]) any]{ diff --git a/collects/scribblings/foreign/misc.scrbl b/collects/scribblings/foreign/misc.scrbl index 1270d54cb8..212d22548d 100644 --- a/collects/scribblings/foreign/misc.scrbl +++ b/collects/scribblings/foreign/misc.scrbl @@ -74,9 +74,6 @@ Returns a platform-specific value corresponding to a Posix @tt{errno} symbol. The set of supported symbols is likely to expand in the future.} -@; ---------------------------------------------------------------------- - -@section{Unsafe Miscellaneous Operations} @defproc[(cast [v any/c][from-type ctype?][to-type ctype?]) any/c]{ diff --git a/collects/ffi/objc.scrbl b/collects/scribblings/foreign/objc.scrbl similarity index 54% rename from collects/ffi/objc.scrbl rename to collects/scribblings/foreign/objc.scrbl index 440f48e811..4d6562985f 100644 --- a/collects/ffi/objc.scrbl +++ b/collects/scribblings/foreign/objc.scrbl @@ -1,21 +1,24 @@ #lang scribble/doc @(require scribble/manual scribble/eval - (for-label scheme/base - scheme/contract - (except-in scheme/foreign ->) - "private/objc-doc-unsafe.ss")) + (for-label racket/base + racket/contract + racket/unsafe/ffi/objc + (except-in racket/unsafe/ffi ->) + (only-in ffi/objc objc-unsafe!) + (only-in scheme/foreign unsafe!))) @(define objc-eval (make-base-eval)) @(interaction-eval #:eval objc-eval (define-struct cpointer:id ())) @(define seeCtype - @elem{see @secref[#:doc '(lib "scribblings/foreign/foreign.scrbl") "ctype"]}) + @elem{see @secref["ctype"]}) -@title{@bold{Objective-C} FFI} +@title{Objective-C FFI} -@defmodule[ffi/objc]{The @schememodname[ffi/objc] library builds on -@schememodname[scheme/foreign] to support interaction with +@defmodule[racket/unsafe/ffi/objc]{The +@racketmodname[racket/unsafe/ffi/objc] library builds on +@racketmodname[racket/unsafe/ffi] to support interaction with @link["http://developer.apple.com/documentation/Cocoa/Conceptual/ObjectiveC/"]{Objective-C}.} The library supports Objective-C interaction in two layers. The upper @@ -23,25 +26,10 @@ layer provides syntactic forms for sending messages and deriving subclasses. The lower layer is a think wrapper on the @link["http://developer.apple.com/DOCUMENTATION/Cocoa/Reference/ObjCRuntimeRef/index.html"]{Objective-C runtime library} functions. Even the upper layer is unsafe and -relatively low-level compared to normal Scheme libraries, because +relatively low-level compared to normal Racket libraries, because argument and result types must be declared in terms of FFI C types (@seeCtype). -@bold{Important:} Most of the bindings documented here are available -only after an @scheme[(objc-unsafe!)] declaration in the importing -module. - -@table-of-contents[] - -@; ---------------------------------------------------------------------- - -@section{Using Unsafe Bindings} - -@defform[(objc-unsafe!)]{ - -Analogous to @scheme[(unsafe!)], makes unsafe bindings of -@schememodname[ffi/objc] available in the importing module.} - @; ---------------------------------------------------------------------- @section{FFI Types and Constants} @@ -52,11 +40,11 @@ The type of an Objective-C object, an opaque pointer.} @defthing[_Class ctype?]{ -The type of an Objective-C class, which is also an @scheme[_id].} +The type of an Objective-C class, which is also an @racket[_id].} @defthing[_Protocol ctype?]{ -The type of an Objective-C protocol, which is also an @scheme[_id].} +The type of an Objective-C protocol, which is also an @racket[_id].} @defthing[_SEL ctype?]{ @@ -64,17 +52,17 @@ The type of an Objective-C selector, an opaque pointer.} @defthing[_BOOL ctype?]{ -The Objective-C boolean type. Scheme values are converted for C in the -usual way: @scheme[#f] is false and any other value is true. C values -are converted to Scheme booleans.} +The Objective-C boolean type. Racket values are converted for C in the +usual way: @racket[#f] is false and any other value is true. C values +are converted to Racket booleans.} @defthing[YES boolean?]{ -Synonym for @scheme[#t]} +Synonym for @racket[#t]} @defthing[NO boolean?]{ -Synonym for @scheme[#f]} +Synonym for @racket[#f]} @; ---------------------------------------------------------------------- @@ -88,13 +76,13 @@ Synonym for @scheme[#f]} (code:line #:type ctype-expr method-id arg)])]{ Sends a message to the Objective-C object produced by -@scheme[obj-expr]. When a type is omitted for either the result or an -argument, the type is assumed to be @scheme[_id], otherwise it must +@racket[obj-expr]. When a type is omitted for either the result or an +argument, the type is assumed to be @racket[_id], otherwise it must be specified as an FFI C type (@seeCtype). -If a single @scheme[method-id] is provided with no arguments, then -@scheme[method-id] must not end with @litchar{:}; otherwise, each -@scheme[method-id] must end with @litchar{:}. +If a single @racket[method-id] is provided with no arguments, then +@racket[method-id] must not end with @litchar{:}; otherwise, each +@racket[method-id] must end with @litchar{:}. @examples[ #:eval objc-eval @@ -107,14 +95,14 @@ If a single @scheme[method-id] is provided with no arguments, then @defform*[[(tellv obj-expr method-id) (tellv obj-expr arg ...)]]{ -Like @scheme[tell], but with a result type @scheme[_void].} +Like @racket[tell], but with a result type @racket[_void].} @defform[(import-class class-id ...)]{ -Defines each @scheme[class-id] to the class (a value with FFI type -@scheme[_Class]) that is registered with the string form of -@scheme[class-id]. The registered class is obtained via -@scheme[objc_lookUpClass]. +Defines each @racket[class-id] to the class (a value with FFI type +@racket[_Class]) that is registered with the string form of +@racket[class-id]. The registered class is obtained via +@racket[objc_lookUpClass]. @examples[ #:eval objc-eval @@ -123,10 +111,10 @@ Defines each @scheme[class-id] to the class (a value with FFI type @defform[(import-protocol protocol-id ...)]{ -Defines each @scheme[protocol-id] to the protocol (a value with FFI type -@scheme[_Protocol]) that is registered with the string form of -@scheme[protocol-id]. The registered class is obtained via -@scheme[objc_getProtocol]. +Defines each @racket[protocol-id] to the protocol (a value with FFI type +@racket[_Protocol]) that is registered with the string form of +@racket[protocol-id]. The registered class is obtained via +@racket[objc_getProtocol]. @examples[ #:eval objc-eval @@ -148,46 +136,46 @@ Defines each @scheme[protocol-id] to the protocol (a value with FFI type [mode + - +a -a] [arg (code:line method-id [ctype-expr arg-id])])]{ -Defines @scheme[class-id] as a new, registered Objective-C class (of -FFI type @scheme[_Class]). The @scheme[superclass-expr] should produce -an Objective-C class or @scheme[#f] for the superclass. An optional -@scheme[#:mixins] clause can specify mixins defined with -@scheme[define-objc-mixin]. An optional @scheme[#:protocols] clause +Defines @racket[class-id] as a new, registered Objective-C class (of +FFI type @racket[_Class]). The @racket[superclass-expr] should produce +an Objective-C class or @racket[#f] for the superclass. An optional +@racket[#:mixins] clause can specify mixins defined with +@racket[define-objc-mixin]. An optional @racket[#:protocols] clause can specify Objective-C protocols to be implemented by the class. -Each @scheme[field-id] is an instance field that holds a Scheme value -and that is initialized to @scheme[#f] when the object is -allocated. The @scheme[field-id]s can be referenced and @scheme[set!] -directly when the method @scheme[body]s. Outside the object, they can -be referenced and set with @scheme[get-ivar] and @scheme[set-ivar!]. +Each @racket[field-id] is an instance field that holds a Racket value +and that is initialized to @racket[#f] when the object is +allocated. The @racket[field-id]s can be referenced and @racket[set!] +directly when the method @racket[body]s. Outside the object, they can +be referenced and set with @racket[get-ivar] and @racket[set-ivar!]. -Each @scheme[method] adds or overrides a method to the class (when -@scheme[mode] is @scheme[-] or @scheme[-a]) to be called on instances, -or it adds a method to the meta-class (when @scheme[mode] is -@scheme[+] or @scheme[+a]) to be called on the class itself. All +Each @racket[method] adds or overrides a method to the class (when +@racket[mode] is @racket[-] or @racket[-a]) to be called on instances, +or it adds a method to the meta-class (when @racket[mode] is +@racket[+] or @racket[+a]) to be called on the class itself. All result and argument types must be declared using FFI C types -(@seeCtype). When @scheme[mode] is @scheme[+a] or @scheme[-a], the -method is called in atomic mode (see @scheme[_cprocedure]). +(@seeCtype). When @racket[mode] is @racket[+a] or @racket[-a], the +method is called in atomic mode (see @racket[_cprocedure]). -If a @scheme[method] is declared with a single @scheme[method-id] and -no arguments, then @scheme[method-id] must not end with -@litchar{:}. Otherwise, each @scheme[method-id] must end with +If a @racket[method] is declared with a single @racket[method-id] and +no arguments, then @racket[method-id] must not end with +@litchar{:}. Otherwise, each @racket[method-id] must end with @litchar{:}. -If the special method @scheme[dealloc] is declared for mode -@scheme[-], it must not call the superclass method, because a -@scheme[(super-tell dealloc)] is added to the end of the method -automatically. In addition, before @scheme[(super-tell dealloc)], -space for each @scheme[field-id] within the instance is deallocated. +If the special method @racket[dealloc] is declared for mode +@racket[-], it must not call the superclass method, because a +@racket[(super-tell dealloc)] is added to the end of the method +automatically. In addition, before @racket[(super-tell dealloc)], +space for each @racket[field-id] within the instance is deallocated. @examples[ #:eval objc-eval (eval:alts (define-objc-class MyView NSView [bm] (code:comment @#,elem{<- one field}) - (- _scheme (swapBitwmap: [_scheme new-bm]) + (- _racket (swapBitwmap: [_racket new-bm]) (begin0 bm (set! bm new-bm))) - (- _void (drawRect: [@#,schemeidfont{_NSRect} exposed-rect]) + (- _void (drawRect: [@#,racketidfont{_NSRect} exposed-rect]) (super-tell drawRect: exposed-rect) (draw-bitmap-region bm exposed-rect)) (- _void (dealloc) @@ -201,45 +189,45 @@ space for each @scheme[field-id] within the instance is deallocated. [field-id ...] method)]{ -Like @scheme[define-objc-class], but defines a mixin to be combined +Like @racket[define-objc-class], but defines a mixin to be combined with other method definitions through either -@scheme[define-objc-class] or @scheme[define-objc-mixin]. The -specified @scheme[field-id]s are not added by the mixin, but must be a -subset of the @scheme[field-id]s declared for the class to which the +@racket[define-objc-class] or @racket[define-objc-mixin]. The +specified @racket[field-id]s are not added by the mixin, but must be a +subset of the @racket[field-id]s declared for the class to which the methods are added.} @defidform[self]{ -When used within the body of a @scheme[define-objc-class] or -@scheme[define-objc-mixin] method, refers to the object whose method +When used within the body of a @racket[define-objc-class] or +@racket[define-objc-mixin] method, refers to the object whose method was called. This form cannot be used outside of a -@scheme[define-objc-class] or @scheme[define-objc-mixin] method.} +@racket[define-objc-class] or @racket[define-objc-mixin] method.} @defform*[[(super-tell result-type method-id) (super-tell result-type arg ...)]]{ -When used within the body of a @scheme[define-objc-class] or -@scheme[define-objc-mixin] method, calls a superclass method. The -@scheme[result-type] and @scheme[arg] sub-forms have the same syntax -as in @scheme[tell]. This form cannot be used outside of a -@scheme[define-objc-class] or @scheme[define-objc-mixin] method.} +When used within the body of a @racket[define-objc-class] or +@racket[define-objc-mixin] method, calls a superclass method. The +@racket[result-type] and @racket[arg] sub-forms have the same syntax +as in @racket[tell]. This form cannot be used outside of a +@racket[define-objc-class] or @racket[define-objc-mixin] method.} @defform[(get-ivar obj-expr field-id)]{ -Extracts the Scheme value of a field in a class created with -@scheme[define-objc-class].} +Extracts the Racket value of a field in a class created with +@racket[define-objc-class].} @defform[(set-ivar! obj-expr field-id value-expr)]{ -Sets the Scheme value of a field in a class created with -@scheme[define-objc-class].} +Sets the Racket value of a field in a class created with +@racket[define-objc-class].} @defform[(selector method-id)]{ -Returns a selector (of FFI type @scheme[_SEL]) for the string form of -@scheme[method-id]. +Returns a selector (of FFI type @racket[_SEL]) for the string form of +@racket[method-id]. @examples[ (eval:alts (tellv button setAction: #:type _SEL (selector terminate:)) (void)) @@ -247,8 +235,8 @@ Returns a selector (of FFI type @scheme[_SEL]) for the string form of @defproc[(objc-is-a? [obj _id] [cls _Class]) boolean?]{ -Check whether @scheme[obj] is an instance of the Objective-C class -@scheme[cls].} +Check whether @racket[obj] is an instance of the Objective-C class +@racket[cls].} @; ---------------------------------------------------------------------- @@ -285,9 +273,9 @@ Returns the class of an object (or the meta-class of a class).} [type-encoding string?]) boolean?]{ -Adds a method to a class. The @scheme[type] argument must be a FFI C -type (@seeCtype) that matches both @scheme[imp] and the not -Objective-C type string @scheme[type-encoding].} +Adds a method to a class. The @racket[type] argument must be a FFI C +type (@seeCtype) that matches both @racket[imp] and the not +Objective-C type string @racket[type-encoding].} @defproc[(class_addIvar [cls _Class] [name string?] [size exact-nonnegative-integer?] [log-alignment exact-nonnegative-integer?] [type-encoding string?]) @@ -299,14 +287,14 @@ Adds an instance variable to an Objective-C class.} [name string?]) (values _Ivar any/c)]{ -Gets the value of an instance variable whose type is @scheme[_pointer].} +Gets the value of an instance variable whose type is @racket[_pointer].} @defproc[(object_setInstanceVariable [obj _id] [name string?] [val any/c]) _Ivar]{ -Sets the value of an instance variable whose type is @scheme[_pointer].} +Sets the value of an instance variable whose type is @racket[_pointer].} @defthing[_Ivar ctype?]{ @@ -318,9 +306,9 @@ The type of an Objective-C instance variable, an opaque pointer.} [arg any/c]) any/c]{ -Calls the Objective-C method on @scheme[_id] named by @scheme[sel]. -The @scheme[types] vector must contain one more than the number of -supplied @scheme[arg]s; the first FFI C type in @scheme[type] is used +Calls the Objective-C method on @racket[_id] named by @racket[sel]. +The @racket[types] vector must contain one more than the number of +supplied @racket[arg]s; the first FFI C type in @racket[type] is used as the result type.} @defproc[((objc_msgSendSuper/typed [types (vector/c result-ctype arg-ctype ...)]) @@ -329,7 +317,7 @@ as the result type.} [arg any/c]) any/c]{ -Like @scheme[objc_msgSend/typed], but for a super call.} +Like @racket[objc_msgSend/typed], but for a super call.} @deftogether[( @defproc[(make-objc_super [id _id] [super _Class]) _objc_super] @@ -337,3 +325,20 @@ Like @scheme[objc_msgSend/typed], but for a super call.} )]{ Constructor and FFI C type use for super calls.} + +@table-of-contents[] + +@; ---------------------------------------------------------------------- + +@section{Legacy Library} + +@defmodule[ffi/objc]{The @racketmodname[ffi/objc] library is a +deprecated entry point to @racketmodname[racket/unsafe/ffi/objc]. It +exports only safe operations directly, and unsafe operations are +imported using @racket[objc-unsafe!].} + +@defform[(objc-unsafe!)]{ + +Analogous to @racket[(unsafe!)], makes unsafe bindings of +@racketmodname[racket/unsafe/ffi/objc] available in the importing +module.} diff --git a/collects/scribblings/foreign/pointers.scrbl b/collects/scribblings/foreign/pointers.scrbl index 7f89e01118..437bd7e05c 100644 --- a/collects/scribblings/foreign/pointers.scrbl +++ b/collects/scribblings/foreign/pointers.scrbl @@ -48,7 +48,7 @@ offset is always in bytes.} @; ---------------------------------------------------------------------- -@section{Unsafe Pointer Operations} +@section{Pointer Dereferencing} @defproc[(set-ptr-offset! [cptr cpointer?][offset exact-integer?][ctype ctype? _byte]) void?]{ @@ -205,7 +205,7 @@ can contain other information).} @; ------------------------------------------------------------ -@section{Unsafe Memory Management} +@section{Memory Management} For general information on C-level memory management with PLT Scheme, see @|InsideMzScheme|. diff --git a/collects/scribblings/foreign/unsafe.scrbl b/collects/scribblings/foreign/unsafe.scrbl deleted file mode 100644 index a24b3b2307..0000000000 --- a/collects/scribblings/foreign/unsafe.scrbl +++ /dev/null @@ -1,5 +0,0 @@ -#lang scribble/doc -@(require "utils.ss") - -@title{Macros for Unsafety} -