878 lines
34 KiB
Racket
878 lines
34 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
racket/stxparam
|
|
(for-syntax racket/base)
|
|
"atomic.rkt"
|
|
"define.rkt")
|
|
|
|
(define objc-lib (ffi-lib "libobjc"))
|
|
|
|
(define-ffi-definer define-objc objc-lib
|
|
#:provide provide-protected)
|
|
(define-ffi-definer define-objc/private objc-lib)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(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 _Method (_cpointer/null 'Method))
|
|
(define _IMP (_fun _id _SEL -> _id))
|
|
|
|
(define-cstruct _objc_super ([receiver _id][class _Class]))
|
|
|
|
(provide YES NO)
|
|
(define YES #t)
|
|
(define NO #f)
|
|
|
|
;; ----------------------------------------
|
|
|
|
;; These structures and functions are used for Objective-C
|
|
;; version prior to 2.0:
|
|
|
|
(define-cstruct _objc_ivar
|
|
([name _pointer]
|
|
[ivar_type _pointer]
|
|
[ivar_offset _int]))
|
|
|
|
(define-cstruct _objc_ivar_list
|
|
([ivar_count _int]
|
|
;; and then an array of objc_ivar
|
|
))
|
|
|
|
(define-cstruct _objc_class
|
|
([isa _pointer] ; _objc_class-pointer
|
|
[super_class _pointer] ; _objc_class-pointer
|
|
[name _pointer] ; string
|
|
[version _long]
|
|
[info _long]
|
|
[instance_size _long]
|
|
[ivars (_or-null _objc_ivar_list-pointer)]
|
|
[methodLists _pointer]
|
|
[cache _pointer]
|
|
[protocols _pointer]))
|
|
|
|
(define-cstruct _objc_protocol_list
|
|
([next _pointer]
|
|
[count _int] ; 1
|
|
[protocol _pointer]))
|
|
|
|
(define-cstruct _objc_cache
|
|
([mask _uint] ; 0, since one bucket allocated
|
|
[occupied _uint]
|
|
[buckets _pointer] ; really an array
|
|
))
|
|
|
|
(define-cstruct _objc_method
|
|
([method_name _SEL]
|
|
[method_types _pointer]
|
|
[method_imp _fpointer]))
|
|
|
|
(define-cstruct _objc_method_list
|
|
([obsolete _pointer]
|
|
[method_count _int] ; 1
|
|
[method _objc_method]))
|
|
|
|
(define CLS_CLASS #x1)
|
|
(define CLS_META #x2)
|
|
|
|
(define (strcpy s)
|
|
(let* ([n (cast s _string _bytes)]
|
|
[p (malloc 'raw (add1 (bytes-length n)))])
|
|
(memcpy p n (add1 (bytes-length n)))
|
|
p))
|
|
|
|
(define (allocate-class-pair-the-hard-way superclass name)
|
|
(let* ([super (cast superclass _Class _objc_class-pointer)]
|
|
[root (let loop ([super super])
|
|
(let ([s (objc_class-super_class super)])
|
|
(if s
|
|
(loop (cast s _pointer _objc_class-pointer))
|
|
super)))]
|
|
[name (strcpy name)]
|
|
[malloc+memcpy (lambda (c)
|
|
(let ([p (malloc 'raw 1 _objc_class)])
|
|
(memcpy p c 1 _objc_class)
|
|
(set-cpointer-tag! p objc_class-tag)
|
|
p))]
|
|
[empty-cache (lambda ()
|
|
;; If you try things the hard way with Obj-C 2.0,
|
|
;; you need to set up the cache. For ealier
|
|
;; versions, you need to set the cache to #f.
|
|
#;
|
|
(let ([p (malloc 'raw 1 _objc_cache)])
|
|
(memset p 0 1 _objc_cache)
|
|
p)
|
|
#f)]
|
|
[meta-super (cast (objc_class-isa super) _pointer _objc_class-pointer)]
|
|
[new-meta (malloc+memcpy
|
|
(make-objc_class (objc_class-isa root)
|
|
meta-super
|
|
name
|
|
0
|
|
CLS_META
|
|
(objc_class-instance_size meta-super)
|
|
#f
|
|
#f
|
|
(empty-cache)
|
|
#f))]
|
|
[new (malloc+memcpy
|
|
(make-objc_class new-meta
|
|
super
|
|
name
|
|
0
|
|
CLS_CLASS
|
|
(objc_class-instance_size super)
|
|
#f
|
|
#f
|
|
(empty-cache)
|
|
#f))])
|
|
(cast new _objc_class-pointer _Class)))
|
|
|
|
(define (add-ivar-the-hard-way class field-name field-name-type)
|
|
(let* ([class (cast class _Class _objc_class-pointer)]
|
|
[ivars (or (objc_class-ivars class)
|
|
(make-objc_ivar_list 0))]
|
|
[count (objc_ivar_list-ivar_count ivars)]
|
|
[array-start (+ (ctype-sizeof _int)
|
|
(- (max (ctype-alignof _objc_ivar)
|
|
(ctype-sizeof _int))
|
|
(ctype-sizeof _int)))]
|
|
[old-size (+ array-start
|
|
(* count
|
|
(ctype-sizeof _objc_ivar)))]
|
|
[new-ivars (malloc 'raw (+ old-size (ctype-sizeof _objc_ivar)))]
|
|
[new-ivar (ptr-add new-ivars old-size)])
|
|
(set-cpointer-tag! new-ivars objc_ivar_list-tag)
|
|
(set-cpointer-tag! new-ivar objc_ivar-tag)
|
|
(memcpy new-ivars ivars old-size)
|
|
(set-objc_ivar_list-ivar_count! new-ivars (add1 (objc_ivar_list-ivar_count ivars)))
|
|
(set-objc_ivar-name! new-ivar (strcpy field-name))
|
|
(set-objc_ivar-ivar_type! new-ivar (strcpy field-name-type))
|
|
(set-objc_ivar-ivar_offset! new-ivar (objc_class-instance_size class))
|
|
(set-objc_class-ivars! class new-ivars)
|
|
(set-objc_class-instance_size! class (+ (objc_class-instance_size class)
|
|
;; Assumes pointer size:
|
|
(ctype-sizeof _pointer)))))
|
|
|
|
(define (add-protocol-the-hard-way c p)
|
|
(let* ([c (cast c _Class _objc_class-pointer)]
|
|
[malloc+memcpy (lambda (c)
|
|
(let ([p (malloc 'raw 1 _objc_protocol_list)])
|
|
(memcpy p c 1 _objc_protocol_list)
|
|
p))]
|
|
[protos (malloc+memcpy
|
|
(make-objc_protocol_list
|
|
(objc_class-protocols c)
|
|
1
|
|
p))])
|
|
(set-objc_class-protocols! c protos)
|
|
#t))
|
|
|
|
(define (add-method-the-hard-way class sel imp types)
|
|
(let* ([malloc+memcpy (lambda (c)
|
|
(let ([p (malloc 'raw 1 _objc_method_list)])
|
|
(memcpy p c 1 _objc_method_list)
|
|
(set-cpointer-tag! p objc_method_list-tag)
|
|
p))]
|
|
[methods (malloc+memcpy
|
|
(make-objc_method_list
|
|
#f
|
|
1
|
|
(make-objc_method sel (strcpy types) imp)))])
|
|
(class_addMethods class methods)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-objc objc_lookUpClass (_fun _string -> _Class))
|
|
|
|
(define-objc objc_getProtocol (_fun _string -> _Protocol)
|
|
#:fail (lambda () (lambda (name)
|
|
(cast (objc_lookUpClass name) _Class _Protocol))))
|
|
|
|
(define-objc sel_registerName (_fun _string -> _SEL))
|
|
|
|
(define-objc objc_allocateClassPair (_fun _Class _string _long -> _Class)
|
|
#:fail (lambda () #f))
|
|
(define-objc objc_registerClassPair (_fun _Class -> _void)
|
|
#:fail (lambda () #f))
|
|
|
|
(define-objc objc_addClass (_fun _objc_class-pointer -> _void)
|
|
#:fail (lambda () #f))
|
|
|
|
(define-objc object_getClass (_fun _id -> _Class)
|
|
#:fail (lambda () #f))
|
|
|
|
(define-objc class_addMethod/raw (_fun _Class _SEL _fpointer _string -> _BOOL)
|
|
#:c-id class_addMethod
|
|
#:fail (lambda () #f))
|
|
(define-objc class_addMethods (_fun _Class _objc_method_list-pointer -> _void)
|
|
#:fail (lambda () #f))
|
|
|
|
(define (class_addMethod cls sel imp ty enc)
|
|
(let ([imp (function-ptr imp ty)])
|
|
(if class_addMethod/raw
|
|
(class_addMethod/raw cls sel imp enc)
|
|
(add-method-the-hard-way cls sel imp enc))))
|
|
|
|
|
|
(define-objc class_addIvar (_fun _Class _string _long _uint8 _string -> _BOOL)
|
|
#:fail (lambda () #f))
|
|
|
|
(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)
|
|
#:fail (lambda () #f))
|
|
|
|
(define-objc/private objc_msgSend _fpointer)
|
|
(define-objc/private objc_msgSend_fpret _fpointer
|
|
#:fail (lambda ()
|
|
;; If objc_msgSend_fpret is not available, assume that
|
|
;; it's the same as objc_msgSend
|
|
objc_msgSend))
|
|
(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) (lambda (v) (memq (ctype-sizeof v) '(1 2 4 8)))]
|
|
[(ppc-macosx ppc-darwin) (lambda (v) (memq (ctype-sizeof v) '(1 2 3 4)))]
|
|
[(x86_64-macosx x86_64-darwin)
|
|
(lambda (v)
|
|
;; Remarkably complex rules govern sizes > 8 and <= 32.
|
|
;; But if we assume no unaligned data and that fancy types
|
|
;; like _m256 won't show up with ObjC, it seems to be as
|
|
;; simple as this:
|
|
((ctype-sizeof v) . <= . 16))]))
|
|
|
|
;; Make `msgSends' access atomic, so that a thread cannot be suspended
|
|
;; or killed during access, which would block other threads.
|
|
(define-syntax-rule (as-atomic e)
|
|
(begin (start-atomic) (begin0 e (end-atomic))))
|
|
|
|
(define (lookup-send types msgSends msgSend msgSend_fpret msgSend_stret first-arg-type)
|
|
;; First type in `types' vector is the result type
|
|
(or (as-atomic (hash-ref msgSends types #f))
|
|
(let ([ret-layout (ctype->layout (vector-ref types 0))])
|
|
(if (and (list? ret-layout)
|
|
(not (sizes-for-direct-struct-results (vector-ref types 0))))
|
|
;; 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))))])
|
|
(as-atomic (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)))])
|
|
(as-atomic (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
|
|
(object_setInstanceVariable obj name #f)
|
|
(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 (allocate-class-pair superclass-id id-str))
|
|
(void (add-protocol 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))
|
|
(register-class-pair 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] ...
|
|
[proto-id proto] ...)
|
|
(lambda (to-id superclass-id ivars)
|
|
(check-expected-ivars 'id ivars '(ivar ...))
|
|
(void (add-protocol 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 (allocate-class-pair superclass-id id-str)
|
|
(if objc_allocateClassPair
|
|
(objc_allocateClassPair superclass-id id-str 0)
|
|
(allocate-class-pair-the-hard-way superclass-id id-str)))
|
|
|
|
(define (register-class-pair id)
|
|
(if objc_registerClassPair
|
|
(objc_registerClassPair id)
|
|
(objc_addClass (cast id _Class _objc_class-pointer))))
|
|
|
|
(define (add-protocol id proto)
|
|
(if class_addProtocol
|
|
(class_addProtocol id proto)
|
|
(add-protocol-the-hard-way id proto)))
|
|
|
|
(define (object-get-class id)
|
|
(if object_getClass
|
|
(object_getClass id)
|
|
(ptr-ref id _Class)))
|
|
|
|
(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")])
|
|
'())]
|
|
[(async ...)
|
|
(if (eq? (syntax-e id) 'dealloc)
|
|
;; so that objects can be destroyed in foreign threads:
|
|
#'(#:async-apply apply-directly)
|
|
#'())]
|
|
[in-cls (if in-class?
|
|
#'(object-get-class 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! async ...
|
|
_id _id arg-type ... -> rt)
|
|
(generate-layout rt (list arg-id ...)))))))))]
|
|
[else (raise-syntax-error #f
|
|
"bad method form"
|
|
stx
|
|
#'m)]))]))
|
|
|
|
(define (apply-directly f) (f))
|
|
|
|
(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)
|
|
(if class_addIvar
|
|
(void (class_addIvar cls
|
|
(symbol->string name)
|
|
(ctype-sizeof _pointer)
|
|
(sub1 (integer-length (ctype-alignof _pointer)))
|
|
(layout->string (ctype->layout _pointer))))
|
|
(add-ivar-the-hard-way cls
|
|
(symbol->string name)
|
|
(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-get-class v) c))
|
|
|
|
;; --------------------------------------------------
|
|
|
|
(define-objc class_getInstanceMethod (_fun _Class _SEL -> _Method))
|
|
(define-objc method_setImplementation (_fun _Method _IMP -> _IMP)
|
|
#:fail (lambda () (lambda (meth imp)
|
|
(set-objc_method-method_imp!
|
|
(cast meth _Method _objc_method-pointer)
|
|
(function-ptr imp _IMP)))))
|