suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

reorganize and extend FFI under racket/unsafe/ffi

Browse Source
This commit is contained in:
Matthew Flatt 2010-04-26 17:10:55 -06:00
parent e4f736c6a5
commit 4acba84b5b
18 changed files with 1270 additions and 814 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/ffi/info.ss
View File

@ -3,5 +3,3 @@
(define name "Sample FFIs")
(define compile-omit-paths '("examples"))
(define scribblings '(("objc.scrbl" (multi-page) (foreign))))

678
collects/ffi/objc.ss
View File

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

28
collects/ffi/private/objc-doc-unsafe.ss
View File

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

70
collects/racket/unsafe/ffi/alloc.rkt Normal file
View File

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

99
collects/racket/unsafe/ffi/atomic.rkt Normal file
View File

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

75
collects/racket/unsafe/ffi/define.rkt Normal file
View File

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

649
collects/racket/unsafe/ffi/objc.rkt Normal file
View File

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

72
collects/scribblings/foreign/alloc.scrbl Normal file
View File

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

44
collects/scribblings/foreign/atomic.scrbl Normal file
View File

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

101
collects/scribblings/foreign/define.scrbl Normal file
View File

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

32
collects/scribblings/foreign/derived.scrbl
View File

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

7
collects/scribblings/foreign/foreign.scrbl
View File

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

6
collects/scribblings/foreign/intro.scrbl
View File

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

4
collects/scribblings/foreign/libs.scrbl
View File

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

3
collects/scribblings/foreign/misc.scrbl
View File

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

205
collects/ffi/objc.scrbl → collects/scribblings/foreign/objc.scrbl
View File

@ -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.}

4
collects/scribblings/foreign/pointers.scrbl
View File

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

5
collects/scribblings/foreign/unsafe.scrbl
View File

@ -1,5 +0,0 @@
#lang scribble/doc
@(require "utils.ss")
@title{Macros for Unsafety}