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

Sync

Browse Source 
svn: r12899
This commit is contained in:
Stevie Strickland 2008-12-19 05:43:50 +00:00
commit d81776083f
15 changed files with 1203 additions and 154 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/drscheme/private/main.ss
View File

@ -94,7 +94,7 @@
(number? (car x))
(number? (cdr x))))))
(preferences:set-default 'drscheme:child-only-memory-limit (* 1024 1024 64)
(preferences:set-default 'drscheme:child-only-memory-limit (* 1024 1024 128)
(λ (x) (or (boolean? x)
(integer? x)
(x . >= . (* 1024 1024 1)))))

2
collects/drscheme/private/rep.ss
View File

@ -925,7 +925,7 @@ TODO
(field (need-interaction-cleanup? #f))
(define/private (no-user-evaluation-message frame exit-code memory-killed?)
(let* ([new-limit (and custodian-limit (+ (* 1024 1024 32) custodian-limit))]
(let* ([new-limit (and custodian-limit (+ custodian-limit custodian-limit))]
[ans (message-box/custom
(string-constant evaluation-terminated)
(string-append

2
collects/ffi/info.ss
View File

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

271
collects/ffi/objc.scrbl Normal file
View File

@ -0,0 +1,271 @@
#lang scribble/doc
@(require scribble/manual
scribble/eval
(for-label scheme/base
scheme/foreign
ffi/objc))
@(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"]})
@title{@bold{Objective-C} FFI}
@defmodule[ffi/objc]{The @schememodname[ffi/objc] library builds on
@schememodname[scheme/foreign] 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
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
argument and result types must be declared in terms of FFI C types
(@seeCtype).
@table-of-contents[]
@section{FFI Types and Constants}
@defthing[_id ctype?]{
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].}
@defthing[_SEL ctype?]{
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.}
@defthing[YES boolean?]{
Synonym for @scheme[#t]}
@defthing[NO boolean?]{
Synonym for @scheme[#f]}
@; ----------------------------------------------------------------------
@section{Syntactic Forms}
@defform*/subs[[(tell result-type obj-expr method-id)
(tell result-type obj-expr arg ...)]
([result-type code:blank
(code:line #:type ctype-expr)]
[arg (code:line method-id expr)
(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
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{:}.
@examples[
#:eval objc-eval
(eval:alts (tell NSString alloc) (make-cpointer:id))
(eval:alts (tell (tell NSString alloc)
initWithUTF8String: #:type _string "Hello")
(make-cpointer:id))
]}
@defform*[[(tellv obj-expr method-id)
(tellv obj-expr arg ...)]]{
Like @scheme[tell], but with a result type @scheme[_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].
@examples[
#:eval objc-eval
(eval:alts (import-class NSString) (void))
]}
@defform/subs[#:literals (+ -)
(define-objc-class class-id superclass-expr
[field-id ...]
method)
([method (mode result-ctype-expr (method-id) body ...+)
(mode result-ctype-expr (arg ...+) body ...+)]
[mode + -]
[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.
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 @scheme[method] adds or overrides a method to the class (when
@scheme[mode] is @scheme[-]) to be called on instances, or it adds a
method to the meta-class (when @scheme[mode] is @scheme[+]) to be
called on the class itself. All result and argument types must be
declared using FFI C types (@seeCtype).
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
@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.
@examples[
#:eval objc-eval
(eval:alts
(define-objc-class MyView NSView
[bm] (code:comment #, @elem{<- one field})
(- _scheme (swapBitwmap: [_scheme new-bm])
(begin0 bm (set! bm new-bm)))
(- _void (drawRect: [#, @schemeidfont{_NSRect} exposed-rect])
(super-tell drawRect: exposed-rect)
(draw-bitmap-region bm exposed-rect))
(- _void (dealloc)
(when bm (done-with-bm bm))))
(void))
]}
@defidform[self]{
When used within the body of a @scheme[define-objc-class] method,
refers to the object whose method was called. This form cannot be used
outside of a @scheme[define-objc-class] method.}
@defform*[[(super-tell result-type method-id)
(super-tell result-type arg ...)]]{
When used within the body of a @scheme[define-objc-class] 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] method.}
@defform[(get-ivar obj-expr field-id)]{
Extracts the Scheme value of a field in a class created with
@scheme[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].}
@defform[(selector method-id)]{
Returns a selector (of FFI type @scheme[_SEL]) for the string form of
@scheme[method-id].
@examples[
(eval:alts (tellv button setAction: #:type _SEL (selector terminate:)) (void))
]}
@; ----------------------------------------------------------------------
@section{Raw Runtime Functions}
@defproc[(objc_lookUpClass [s string?]) (or/c _Class #f)]{
Finds a registered class by name.}
@defproc[(sel_registerName [s string?]) _SEL]{
Interns a selector given its name in string form.}
@defproc[(objc_allocateClassPair [cls _Class] [s string?] [extra integer?])
_Class]{
Allocates a new Objective-C class.}
@defproc[(objc_registerClassPair [cls _Class]) void?]{
Registers an Objective-C class.}
@defproc[(object_getClass [obj _id]) _Class]{
Returns the class of an object (or the meta-class of a class).}
@defproc[(class_addMethod [cls _Class] [sel _SEL]
[imp procedure?]
[type ctype?]
[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 and the not
Objective-C type string @scheme[type-encoding].}
@defproc[(class_addIvar [cls _Class] [name string?] [size exact-nonnegative-integer?]
[log-alignment exact-nonnegative-integer?] [type-encoding string?])
boolean?]{
Adds an instance variable to an Objective-C class.}
@defproc[(object_getInstanceVariable [obj _id]
[name string?])
(values _Ivar any/c)]{
Gets the value of an instance variable whose type is @scheme[_pointer].}
@defproc[(object_setInstanceVariable [obj _id]
[name string?]
[val any/c])
_Ivar]{
Sets the value of an instance variable whose type is @scheme[_pointer].}
@defthing[_Ivar ctype?]{
The type of an Objective-C instance variable, an opaque pointer.}
@defproc[((objc_msgSend/typed [types (vector/c result-ctype arg-ctype ...)])
[obj _id]
[sel _SEL]
[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
as the result type.}
@defproc[((objc_msgSendSuper/typed [types (vector/c result-ctype arg-ctype ...)])
[super _objc_super]
[sel _SEL]
[arg any/c])
any/c]{
Like @scheme[objc_msgSend/typed], but for a super call.}
@deftogether[(
@defproc[(make-obj_csuper [id _id] [super _Class]) _objc_super]
@defthing[_objc_super ctype?]
)]{
Constructor and FFI C type use for super calls.}

550
collects/ffi/objc.ss Normal file
View File

@ -0,0 +1,550 @@
#lang scheme/base
(require scheme/foreign (only-in '#%foreign ffi-call)
scheme/stxparam
(for-syntax scheme/base))
(unsafe!)
(define objc-lib (ffi-lib "libobjc"))
(define-syntax define-objc/private
(syntax-rules ()
[(_ id type)
(define-objc/private id id type)]
[(_ id c-id type)
(define id (get-ffi-obj 'c-id objc-lib type))]))
(define-syntax-rule (define-objc id type)
(begin
(provide id)
(define-objc/private id id type)))
;; ----------------------------------------
(provide _id _Class _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 _BOOL (make-ctype _byte
(lambda (v) (if v 1 0))
(lambda (v) (not (eq? v 0)))))
(define _IMP (_fun _id _id -> _id))
(define-cstruct _objc_super ([receiver _id][class _Class]))
(provide YES NO)
(define YES #t)
(define NO #f)
;; ----------------------------------------
(define-objc objc_lookUpClass (_fun _string -> _Class))
(define-objc sel_registerName (_fun _string -> _SEL))
(define-objc objc_allocateClassPair (_fun _Class _string _long -> _Class))
(define-objc objc_registerClassPair (_fun _Class -> _void))
(define-objc object_getClass (_fun _id -> _Class))
(provide class_addMethod)
(define (class_addMethod cls sel imp ty enc)
((get-ffi-obj 'class_addMethod objc-lib (_fun _Class _SEL ty _string -> _BOOL))
cls sel imp enc))
(define-objc class_addIvar (_fun _Class _string _long _uint8 _string -> _BOOL))
(define-objc object_getInstanceVariable (_fun _id _string [p : (_ptr o _pointer)]
-> [ivar : _Ivar]
-> (values ivar p)))
(define-objc object_setInstanceVariable (_fun _id _string _pointer -> _Ivar))
(define-objc/private objc_msgSend _fpointer)
(define-objc/private objc_msgSend_fpret _fpointer)
(define-objc/private objc_msgSendSuper _fpointer)
(define objc_msgSendSuper_fpret objc_msgSendSuper) ; why no fpret variant?
(define (lookup-send types msgSends msgSend msgSend_fpret first-arg-type)
;; First type in `types' vector is the result type
(or (hash-ref msgSends types #f)
(let ([m (ffi-call (if (memq (ctype->layout (vector-ref types 0))
'(float double double*))
msgSend_fpret
msgSend)
(list* first-arg-type _SEL (cdr (vector->list types)))
(vector-ref types 0))])
(hash-set! msgSends types m)
m)))
(define msgSends (make-hash))
(define (objc_msgSend/typed types)
(lookup-send types msgSends objc_msgSend objc_msgSend_fpret _id))
(provide objc_msgSend/typed)
(define msgSendSupers (make-hash))
(define (objc_msgSendSuper/typed types)
(lookup-send types msgSendSupers objc_msgSendSuper objc_msgSendSuper_fpret _pointer))
(provide objc_msgSendSuper/typed)
;; ----------------------------------------
(provide import-class)
(define-syntax (import-class stx)
(syntax-case stx ()
[(_ id)
(quasisyntax/loc stx
(define id (objc_lookUpClass #,(symbol->string (syntax-e #'id)))))]
[(_ id ...)
(syntax/loc stx (begin (import-class id) ...))]))
;; ----------------------------------------
;; iget-value and set-ivar! work only with fields that contain Scheme 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 _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 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 self super-tell)
(define-syntax (define-objc-class stx)
(syntax-case stx ()
[(_ id superclass (ivar ...) method ...)
(begin
(unless (identifier? #'id)
(raise-syntax-error #f
"expected an identifier for class definition"
stx
#'id))
(for-each (lambda (ivar)
(unless (identifier? ivar)
(raise-syntax-error #f
"expected an identifier for an instance variable"
stx
ivar)))
(syntax->list #'(ivar ...)))
(let ([ivars (syntax->list #'(ivar ...))]
[methods (syntax->list #'(method ...))])
(with-syntax ([id-str (symbol->string (syntax-e #'id))]
[whole-stx stx]
[(dealloc-method ...)
(if (null? ivars)
;; no need to override dealloc:
#'()
;; add dealloc if it's not here:
(if (ormap (lambda (m)
(syntax-case m ()
[(+/- result-type (id . _) . _)
(eq? (syntax-e #'id) 'dealloc)]))
methods)
;; Given a dealloc extension:
#'()
;; Need to add one explicitly:
#'((- _void (dealloc) (void)))))])
(syntax/loc stx
(begin
(define superclass-id superclass)
(define id (objc_allocateClassPair superclass-id id-str 0))
(add-ivar id 'ivar) ...
(let-syntax ([ivar (make-ivar-form 'ivar)] ...)
(add-method whole-stx id superclass-id method) ...
(add-method whole-stx id superclass-id dealloc-method) ...
(void))
(objc_registerClassPair id))))))]))
(define-for-syntax (make-ivar-form sym)
(with-syntax ([sym sym])
(make-set!-transformer
(lambda (stx)
(syntax-case stx (set!)
[(set! _ val)
(syntax/loc stx (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 #'-))
(let ([id #'id]
[args (syntax->list #'(arg ...))]
[in-class? (free-identifier=? #'kind #'+)])
(when (null? args)
(unless (identifier? id)
(raise-syntax-error #f
"expected an identifier for method name"
stx
id)))
(with-syntax ([((arg-tag arg-type arg-id) ...)
(if (null? args)
null
(parse-arg-list (cons id args) stx #t))])
(with-syntax ([id-str (if (null? args)
(symbol->string (syntax-e id))
(symbol->string (combine #'(arg-tag ...))))]
[(dealloc-body ...)
(if (eq? (syntax-e id) 'dealloc)
(syntax-case stx ()
[(_ _ _ [ivar ...] . _)
(with-syntax ([(ivar-str ...)
(map (lambda (ivar)
(symbol->string (syntax-e ivar)))
(syntax->list #'(ivar ...)))])
#'((free-fields self '(ivar-str ...))
(super-tell #:type _void dealloc)))]
[_ (error "oops")])
'())]
[in-cls (if in-class?
#'(object_getClass cls)
#'cls)])
(syntax/loc stx
(let ([rt result-type]
[arg-id arg-type] ...)
(void (class_addMethod in-cls
(sel_registerName id-str)
(save-method!
(lambda (self-id cmd arg-id ...)
(syntax-parameterize ([self (make-id-stx #'self-id)]
[super-class (make-id-stx #'superclass-id)]
[super-tell do-super-tell])
body0 body ...
dealloc-body ...)))
(_fun _id _id arg-type ... -> rt)
(generate-layout rt (list arg-id ...)))))))))]
[else (raise-syntax-error #f
"bad method form"
stx
#'m)]))]))
(define methods (make-hasheq))
(define (save-method! m)
;; Methods are never GCed, since classes are never unregistered
(hash-set! methods m #t)
m)
(define (add-ivar cls name)
(void (class_addIvar cls
(symbol->string name)
(ctype-sizeof _pointer)
(sub1 (integer-length (ctype-alignof _pointer)))
(layout->string (ctype->layout _pointer)))))
(define-for-syntax (do-super-tell stx)
(syntax-case stx ()
[(_ #:type t)
(raise-syntax-error #f
"method name missing"
stx)]
[(_ #:type t method)
(let ([m #'method])
(check-method-name m stx)
(quasisyntax/loc stx
((objc_msgSendSuper/typed (type-vector t))
(make-objc_super self super-class)
#,(register-selector (syntax-e m)))))]
[(_ method)
(not (keyword? (syntax-e #'method)))
(let ([m #'method])
(check-method-name m stx)
(quasisyntax/loc stx
((objc_msgSendSuper/typed (type-vector _id))
(make-objc_super self super-class)
#,(register-selector (syntax-e m)))))]
[(_ #:type result-type method/arg ...)
(build-send stx #'result-type
#'objc_msgSendSuper/typed
#'((make-objc_super self super-class))
#'(method/arg ...))]
[(_ method/arg ...)
(build-send stx #'_id
#'objc_msgSendSuper/typed
#'((make-objc_super self super-class))
#'(method/arg ...))]))

24
collects/mzlib/foreign.ss
View File

@ -58,7 +58,7 @@
(unsafe malloc) (unsafe free) (unsafe end-stubborn-change)
cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!)
ptr-offset ptr-add! offset-ptr? set-ptr-offset!
ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string)
ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string) ctype->layout
_void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64
_fixint _ufixint _fixnum _ufixnum
_float _double _double*
@ -1494,13 +1494,33 @@
(if v (apply values v) (msg/fail-thunk))))]
[else (msg/fail-thunk)]))))
;; ----------------------------------------------------------------------------
;;
(define prim-synonyms
#hasheq((double* . double)
(fixint . long)
(ufixint . ulong)
(fixnum . long)
(ufixnum . ulong)
(path . bytes)
(symbol . bytes)
(scheme . pointer)))
(define (ctype->layout c)
(let ([b (ctype-basetype c)])
(cond
[(ctype? b) (ctype->layout b)]
[(list? b) (map ctype->layout b)]
[else (hash-ref prim-synonyms b b)])))
;; ----------------------------------------------------------------------------
;; Misc utilities
;; Used by set-ffi-obj! to get the actual value so it can be kept around
(define (get-lowlevel-object x type)
(let ([basetype (ctype-basetype type)])
(if basetype
(if (ctype? basetype)
(let ([s->c (ctype-scheme->c type)])
(get-lowlevel-object (if s->c (s->c x) x) basetype))
(values x type))))

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "17dec2008")
#lang scheme/base (provide stamp) (define stamp "18dec2008")

133
collects/scheme/sandbox.ss
View File

@ -25,11 +25,13 @@
sandbox-make-logger
sandbox-memory-limit
sandbox-eval-limits
sandbox-eval-handlers
call-with-trusted-sandbox-configuration
evaluator-alive?
kill-evaluator
break-evaluator
set-eval-limits
set-eval-handler
put-input
get-output
get-error-output
@ -40,6 +42,8 @@
call-in-nested-thread*
call-with-limits
with-limits
call-with-custodian-shutdown
call-with-killing-threads
exn:fail:sandbox-terminated?
exn:fail:sandbox-terminated-reason
exn:fail:resource?
@ -73,7 +77,8 @@
[sandbox-make-code-inspector current-code-inspector]
[sandbox-make-logger current-logger]
[sandbox-memory-limit #f]
[sandbox-eval-limits #f])
[sandbox-eval-limits #f]
[sandbox-eval-handlers '(#f #f)])
(thunk)))
(define sandbox-namespace-specs
@ -306,6 +311,17 @@
(set! p (current-preserved-thread-cell-values))))))))
(lambda () (when p (current-preserved-thread-cell-values p))))))))
;; useful wrapper around the above: run thunk, return one of:
;; - (list values val ...)
;; - (list raise exn)
;; - 'kill or 'shut
(define (nested thunk)
(call-in-nested-thread*
(lambda ()
(with-handlers ([void (lambda (e) (list raise e))])
(call-with-values thunk (lambda vs (list* values vs)))))
(lambda () 'kill) (lambda () 'shut)))
(define (call-with-limits sec mb thunk)
;; note that when the thread is killed after using too much memory or time,
;; then all thread-local changes (parameters and thread cells) are discarded
@ -319,33 +335,25 @@
c (inexact->exact (round (* mb 1024 1024))) c)
(values c (make-custodian-box c #t)))
(values (current-custodian) #f)))
(parameterize ([current-custodian cust])
(call-in-nested-thread*
(lambda ()
;; time limit
(when sec
(let ([t (current-thread)])
(thread (lambda ()
(unless (sync/timeout sec t) (set! r 'time))
(kill-thread t)))))
(set! r (with-handlers ([void (lambda (e) (list raise e))])
(call-with-values thunk (lambda vs (list* values vs))))))
;; The thread might be killed by the timer thread, so don't let
;; call-in-nested-thread* kill it -- if user code did so, then just
;; register the request and kill it below. Do this for a
;; custodian-shutdown to, just in case.
(lambda ()
(unless r (set! r 'kill))
;; (kill-thread (current-thread))
)
(lambda ()
(unless r (set! r 'shut))
;; (custodian-shutdown-all (current-custodian))
)))
(when (and cust-box (not (custodian-box-value cust-box)))
(if (memq r '(kill shut)) ; should always be 'shut
(set! r 'memory)
(format "cust died with: ~a" r))) ; throw internal error below
(define timeout? #f)
(define r
(parameterize ([current-custodian cust])
(if sec
(nested
(lambda ()
;; time limit
(when sec
(let ([t (current-thread)])
(thread (lambda ()
(unless (sync/timeout sec t) (set! timeout? #t))
(kill-thread t)))))
(thunk)))
(nested thunk))))
(cond [timeout? (set! r 'time)]
[(and cust-box (not (custodian-box-value cust-box)))
(if (memq r '(kill shut)) ; should always be 'shut
(set! r 'memory)
(format "cust died with: ~a" r))]) ; throw internal error below
(case r
[(kill) (kill-thread (current-thread))]
[(shut) (custodian-shutdown-all (current-custodian))]
@ -362,6 +370,30 @@
[(with-limits sec mb body ...)
(call-with-limits sec mb (lambda () body ...))]))
;; other resource utilities
(define (call-with-custodian-shutdown thunk)
(let* ([cust (make-custodian (current-custodian))]
[r (parameterize ([current-custodian cust]) (nested thunk))])
(case r
[(kill) (kill-thread (current-thread))]
[(shut) (custodian-shutdown-all (current-custodian))]
[else (apply (car r) (cdr r))])))
(define (call-with-killing-threads thunk)
(let* ([cur (current-custodian)] [sub (make-custodian cur)])
(define r (parameterize ([current-custodian sub]) (nested thunk)))
(let kill-all ([x sub])
(cond [(custodian? x) (for-each kill-all (custodian-managed-list x cur))]
[(thread? x) (kill-thread x)]))
(case r
[(kill) (kill-thread (current-thread))]
[(shut) (custodian-shutdown-all (current-custodian))]
[else (apply (car r) (cdr r))])))
(define sandbox-eval-handlers
(make-parameter (list #f call-with-custodian-shutdown)))
;; Execution ----------------------------------------------------------------
(define (literal-identifier=? x y)
@ -555,12 +587,14 @@
(define-evaluator-messenger kill-evaluator 'kill)
(define-evaluator-messenger break-evaluator 'break)
(define-evaluator-messenger (set-eval-limits secs mb) 'limits)
(define-evaluator-messenger (set-eval-handler handler) 'handler)
(define-evaluator-messenger (put-input . xs) 'input)
(define-evaluator-messenger get-output 'output)
(define-evaluator-messenger get-error-output 'error-output)
(define-evaluator-messenger (get-uncovered-expressions . xs) 'uncovered)
(define-evaluator-messenger (call-in-sandbox-context thunk) 'thunk)
(define (call-in-sandbox-context evaluator thunk [unrestricted? #f])
(evaluator (make-evaluator-message (if unrestricted? 'thunk* 'thunk)
(list thunk))))
(define-struct (exn:fail:sandbox-terminated exn:fail) (reason) #:transparent)
(define (make-terminated reason)
@ -585,13 +619,18 @@
(define output #f)
(define error-output #f)
(define limits (sandbox-eval-limits))
(define eval-handler (car (sandbox-eval-handlers))) ; 1st handler on startup
(define user-thread #t) ; set later to the thread
(define user-done-evt #t) ; set in the same place
(define terminated? #f) ; set to an exception value when the sandbox dies
(define (limit-thunk thunk)
(let* ([sec (and limits (car limits))]
[mb (and limits (cadr limits))])
(if (or sec mb) (lambda () (call-with-limits sec mb thunk)) thunk)))
[mb (and limits (cadr limits))]
[thunk (if (or sec mb)
(lambda () (call-with-limits sec mb thunk))
thunk)]
[thunk (if eval-handler (lambda () (eval-handler thunk)) thunk)])
thunk))
(define (terminated! reason)
(unless terminated?
(set! terminated?
@ -632,6 +671,7 @@
limit-thunk
(and coverage? (lambda (es+get) (set! uncovered es+get))))
(channel-put result-ch 'ok))
(set! eval-handler (cadr (sandbox-eval-handlers))) ; interactions handler
;; finally wait for interaction expressions
(let ([n 0])
(let loop ()
@ -641,11 +681,12 @@
(with-handlers ([void (lambda (exn)
(channel-put result-ch (cons 'exn exn)))])
(define run
(limit-thunk (if (evaluator-message? expr)
(lambda ()
(apply (evaluator-message-msg expr)
(evaluator-message-args expr)))
(lambda ()
(if (evaluator-message? expr)
(case (evaluator-message-msg expr)
[(thunk) (limit-thunk (car (evaluator-message-args expr)))]
[(thunk*) (car (evaluator-message-args expr))]
[else (error 'sandbox "internal error (bad message)")])
(limit-thunk (lambda ()
(set! n (add1 n))
(eval* (input->code (list expr) 'eval n))))))
(channel-put result-ch (cons 'vals (call-with-values run list))))
@ -682,7 +723,7 @@
(filter (lambda (x) (equal? src (syntax-source x))) uncovered)
uncovered))]))
(define (output-getter p)
(if (procedure? p) (user-eval (make-evaluator-message p '())) p))
(if (procedure? p) (user-eval (make-evaluator-message 'thunk (list p))) p))
(define input-putter
(case-lambda
[() (input-putter input)]
@ -696,16 +737,16 @@
(if (evaluator-message? expr)
(let ([msg (evaluator-message-msg expr)])
(case msg
[(alive?) (and user-thread (not (thread-dead? user-thread)))]
[(kill) (terminate+kill! 'evaluator-killed #f)]
[(break) (user-break)]
[(limits) (set! limits (evaluator-message-args expr))]
[(input) (apply input-putter (evaluator-message-args expr))]
[(output) (output-getter output)]
[(alive?) (and user-thread (not (thread-dead? user-thread)))]
[(kill) (terminate+kill! 'evaluator-killed #f)]
[(break) (user-break)]
[(limits) (set! limits (evaluator-message-args expr))]
[(handler) (set! eval-handler (car (evaluator-message-args expr)))]
[(input) (apply input-putter (evaluator-message-args expr))]
[(output) (output-getter output)]
[(error-output) (output-getter error-output)]
[(uncovered) (apply get-uncovered (evaluator-message-args expr))]
[(thunk) (user-eval (make-evaluator-message
(car (evaluator-message-args expr)) '()))]
[(thunk thunk*) (user-eval expr)]
[else (error 'evaluator "internal error, bad message: ~e" msg)]))
(user-eval expr)))
(define (make-output what out set-out! allow-link?)

37
collects/scribblings/foreign/types.scrbl
View File

@ -13,16 +13,18 @@ along with conversion functions to and from the existing types.
@; ----------------------------------------------------------------------
@section{Type Constructors}
@section[#:tag "ctype"]{Type Constructors}
@defproc[(make-ctype [type ctype?]
[scheme-to-c (or/c #f (any/c . -> . any))]
[c-to-scheme (or/c #f (any/c . -> . any))])
ctype?]{
Creates a new @tech{C type} value, with the given conversions
functions. The conversion functions can be @scheme[#f] meaning that
there is no conversion for the corresponding direction. If both
Creates a new @tech{C type} value whose representation for foreign
code is the same as @scheme[type]'s. The given conversions functions
convert to and from the Scheme representation of @scheme[type]. Either
conversion function can be @scheme[#f], meaning that the conversion
for the corresponding direction is the identity function. If both
functions are @scheme[#f], @scheme[type] is returned.}
@ -33,12 +35,29 @@ otherwise.}
@defproc*[([(ctype-sizeof [type ctype?]) exact-nonnegative-integer?]
[(ctype-alignof [ctype ctype?]) exact-nonnegative-integer?])]{
[(ctype-alignof [type ctype?]) exact-nonnegative-integer?])]{
Returns the size or alignment of a given @scheme[type] for the current
platform.}
@defproc[(ctype->layout [type ctype?]) (flat-rec-contract rep
symbol?
(listof rep))]{
Returns a value to describe the eventual C representation of the
type. It can be any of the following symbols:
@schemeblock[
'int8 'uint8 'int16 'uint16 'int32 'uint32 'int64 'uint64
'float 'double 'bool 'void 'pointer 'fpointer
'bytes 'string/ucs-4 'string/utf-16
]
The result can also be a list, which describes a C struct whose
element representations are provided in order within the list.}
@defproc[(compiler-sizeof [sym symbol?]) exact-nonnegative-integer?]{
Possible values for @scheme[symbol] are @scheme['int], @scheme['char],
@ -338,7 +357,7 @@ values: @itemize[
the callback value will be stored in the box, overriding any value
that was in the box (making it useful for holding a single callback
value). When you know that it is no longer needed, you can
`release' the callback value by changing the box contents, or by
``release'' the callback value by changing the box contents, or by
allowing the box itself to be garbage-collected. This is can be
useful if the box is held for a dynamic extent that corresponds to
when the callback is needed; for example, you might encapsulate some
@ -400,7 +419,7 @@ used to access the actual foreign return value.
In rare cases where complete control over the input arguments is needed, the
wrapper's argument list can be specified as @scheme[args], in any form (including
a `rest' argument). Identifiers in this place are related to type labels, so
a ``rest'' argument). Identifiers in this place are related to type labels, so
if an argument is there is no need to use an expression.
For example,
@ -746,7 +765,7 @@ than the struct itself. The following works as expected:
As described above, @scheme[_list-struct]s should be used in cases where
efficiency is not an issue. We continue using @scheme[define-cstruct], first
define a type for @cpp{A} which makes it possible to use `@cpp{makeA}:
define a type for @cpp{A} which makes it possible to use @cpp{makeA}:
@schemeblock[
(define-cstruct #,(schemeidfont "_A") ([x _int] [y _byte]))
@ -785,7 +804,7 @@ We can access all values of @scheme[b] using a naive approach:
]
but this is inefficient as it allocates and copies an instance of
`@cpp{A}' on every access. Inspecting the tags @scheme[(cpointer-tag
@cpp{A} on every access. Inspecting the tags @scheme[(cpointer-tag
b)] we can see that @cpp{A}'s tag is included, so we can simply use
its accessors and mutators, as well as any function that is defined to
take an @cpp{A} pointer:

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

@ -39,8 +39,9 @@ These values can also be used as C pointer objects.}
[(ctype-c->scheme [type ctype?]) procedure?])]{
Accessors for the components of a C type object, made by
@scheme[make-ctype]. The @scheme[ctype-basetype] selector returns
@scheme[#f] for primitive types (including cstruct types).}
@scheme[make-ctype]. The @scheme[ctype-basetype] selector returns a
symbol for primitive types that names the type, a list of ctypes for
cstructs, and another ctype for user-defined ctypes.}
@defproc[(ffi-call [ptr any/c] [in-types (listof ctype?)] [out-type ctype?]

56
collects/scribblings/reference/sandbox.scrbl
View File

@ -629,6 +629,24 @@ then, assuming sufficiently small limits,
]}
@defparam[sandbox-eval-handlers handlers
(list/c (or/c #f ((-> any) . -> . any))
(or/c #f ((-> any) . -> . any)))]{
A parameter that determines two (optional) handlers that wrap
sandboxed evaluations. The first one is used when evaluating the
initial program when the sandbox is being set-up, and the second is
used for each interaction. Each of these handlers should expect a
thunk as an argument, and they should execute these thunks ---
possibly imposing further restrictions. The default values are
@scheme[#f] and @scheme[call-with-custodian-shutdown], meaning no
additional restrictions on initial sandbox code (e.g., it can start
background threads), and a custodian-shutdown around each interaction
that follows. Another useful function for this is
@scheme[call-with-killing-threads] which kills all threads, but leaves
other resources intact.}
@defparam[sandbox-make-inspector make (-> inspector?)]{
A parameter that determines the procedure used to create the inspector
@ -691,7 +709,8 @@ propagates the break to the evaluator's context.}
@defproc[(set-eval-limits [evaluator (any/c . -> . any)]
[secs (or/c exact-nonnegative-integer? #f)]
[mb (or/c exact-nonnegative-integer? #f)]) void?]{
[mb (or/c exact-nonnegative-integer? #f)])
void?]{
Changes the per-expression limits that @scheme[evaluator] uses to
@scheme[sec] seconds and @scheme[mb] megabytes (either one can be
@ -702,6 +721,33 @@ because changing the @scheme[sandbox-eval-limits] parameter does not
affect existing evaluators. See also @scheme[call-with-limits].}
@defproc[(set-eval-handler [evaluator (any/c . -> . any)]
[handler (or/c #f ((-> any) . -> . any))])
void?]{
Changes the per-expression handler that the @scheme[evaluator] uses
around each interaction. A @scheme[#f] value means no handler is
used.
This procedure should be used to modify an existing evaluator handler,
because changing the @scheme[sandbox-eval-handlers] parameter does not
affect existing evaluators. See also
@scheme[call-with-custodian-shutdown] and
@scheme[call-with-killing-threads] for two useful handlers that are
provided.}
@defproc*[([(call-with-custodian-shutdown [thunk (-> any)]) any]
[(call-with-killing-threads [thunk (-> any)]) any])]{
These functions are useful for use as an evaluation handler.
@scheme[call-with-custodian-shutdown] will execute the @scheme[thunk]
in a fresh custodian, then shutdown that custodian, making sure that
@scheme[thunk] could not have left behind any resources.
@scheme[call-with-killing-threads] is similar, except that it kills
threads that were left, but leaves other resources as is.}
@defproc*[([(put-input [evaluator (any/c . -> . any)]) output-port?]
[(put-input [evaluator (any/c . -> . any)]
[i/o (or/c bytes? string? eof-object?)]) void?])]{
@ -779,12 +825,14 @@ coverage results, since each expression may be assigned a single
source location.}
@defproc[(call-in-sandbox-context [evaluator (any/c . -> . any)]
[thunk (-> any)])
[thunk (-> any)]
[unrestricted? boolean? #f])
any]{
Calls the given @scheme[thunk] in the context of a sandboxed
evaluator. The call is performed under the resource limits that are
used for evaluating expressions.
evaluator. The call is performed under the resource limits and
evaluation handler that are used for evaluating expressions, unless
@scheme[unrestricted?] is specified as true.
This is usually similar to @scheme[(evaluator (list thunk))], except
that this relies on the common meaning of list expressions as function

4
collects/scribblings/reference/security-guards.scrbl
View File

@ -37,8 +37,8 @@ host platform.
(or/c (integer-in 1 65535) #f)
(or/c 'server 'client)
. -> . any)]
[link (or/c (symbol? path? path? . -> . any) #f)
#f])
[link-guard (or/c (symbol? path? path? . -> . any) #f)
#f])
security-guard?]{
Creates a new security guard as child of @scheme[parent].

145
src/foreign/foreign.c
View File

@ -810,9 +810,16 @@ typedef union _ForeignAny {
/* Type objects */
/* This struct is used for both user types and primitive types (including
* struct types). If it is a primitive type then basetype will be NULL, and
* struct types). If it is a user type then basetype will be another ctype,
* otherwise,
* - if it's a primitive type, then basetype will be a symbol naming that type
* - if it's a struct, then basetype will be the list of ctypes that
* made this struct
* scheme_to_c will have the &ffi_type pointer, and c_to_scheme will have an
* integer (a label value) for non-struct type. */
* integer (a label value) for non-struct type. (Note that the
* integer is not really needed, since it is possible to identify the
* type by the basetype field.)
*/
/* ctype structure definition */
static Scheme_Type ctype_tag;
typedef struct ctype_struct {
@ -849,8 +856,8 @@ END_XFORM_SKIP;
#endif
#define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype)
#define CTYPE_PRIMP(x) (NULL == (CTYPE_BASETYPE(x)))
#define CTYPE_USERP(x) (!(CTYPE_PRIMP(x)))
#define CTYPE_USERP(x) (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x)))
#define CTYPE_PRIMP(x) (!CTYPE_USERP(x))
#define CTYPE_PRIMTYPE(x) ((ffi_type*)(((ctype_struct*)(x))->scheme_to_c))
#define CTYPE_PRIMLABEL(x) ((long)(((ctype_struct*)(x))->c_to_scheme))
#define CTYPE_USER_S2C(x) (((ctype_struct*)(x))->scheme_to_c)
@ -861,12 +868,9 @@ END_XFORM_SKIP;
#define MYNAME "ctype-basetype"
static Scheme_Object *foreign_ctype_basetype(int argc, Scheme_Object *argv[])
{
Scheme_Object *base;
if (!SCHEME_CTYPEP(argv[0]))
scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
base = CTYPE_BASETYPE(argv[0]);
if (NULL == base) return scheme_false;
else return base;
return CTYPE_BASETYPE(argv[0]);
}
#undef MYNAME
@ -1046,7 +1050,7 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
type->so.type = ctype_tag;
type->basetype = (NULL);
type->basetype = (argv[0]);
type->scheme_to_c = ((Scheme_Object*)libffi_type);
type->c_to_scheme = ((Scheme_Object*)FOREIGN_struct);
scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
@ -1166,12 +1170,11 @@ END_XFORM_SKIP;
static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
int delta, int args_loc)
{
Scheme_Object *res, *base;
Scheme_Object *res;
if (!SCHEME_CTYPEP(type))
scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type);
base = CTYPE_BASETYPE(type);
if (base != NULL) {
res = C2SCHEME(base, src, delta, args_loc);
if (CTYPE_USERP(type)) {
res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc);
if (SCHEME_FALSEP(CTYPE_USER_C2S(type)))
return res;
else
@ -1219,13 +1222,6 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
* is used for both the function definition and calls, but the actual code in
* the function is different: in the relevant cases zero an int and offset the
* ptr */
#ifdef SCHEME_BIG_ENDIAN
#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \
scheme_to_c(typ,dst,delta,val,basep,_offset,retloc)
#else
#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \
scheme_to_c(typ,dst,delta,val,basep,_offset)
#endif
/* Usually writes the C object to dst and returns NULL. When basetype_p is not
* NULL, then any pointer value (any pointer or a struct) is returned, and the
@ -1254,7 +1250,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val);
} else switch (CTYPE_PRIMLABEL(type)) {
case FOREIGN_void:
scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type));
if (!ret_loc) scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type));
break;
case FOREIGN_int8:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(Tsint8)<sizeof(int) && ret_loc) {
@ -1597,7 +1594,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
return NULL; /* hush the compiler */
}
case FOREIGN_fpointer:
scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type));
if (!ret_loc) scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type));
break;
case FOREIGN_struct:
if (!SCHEME_FFIANYPTRP(val))
scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);
@ -2347,7 +2345,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
offset = 0;
p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype,
&offset, 0);
if (p != NULL) {
if ((p != NULL) || offset) {
avalues[i] = p;
ivals[i].x_fixnum = basetype; /* remember the base type */
} else {
@ -2370,7 +2368,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
/* We finished with all possible mallocs, clear up the avalues and offsets
* mess */
for (i=0; i<nargs; i++) {
if (avalues[i] == NULL) /* if this was a non-pointer... */
if ((avalues[i] == NULL) && !offsets[i]) /* if this was a non-pointer... */
avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
else if (ivals[i].x_fixnum != FOREIGN_struct) { /* if *not* a struct... */
/* ... set the ivals pointer (pointer type doesn't matter) and avalues */
@ -2625,6 +2623,28 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[])
return (Scheme_Object*)data;
}
/*****************************************************************************/
void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp)
{
char *str;
if (!SCHEME_CTYPEP(ctype))
scheme_wrong_type("Scheme->C", "C-type", 0, 1, &ctype);
if (CTYPE_PRIMP(ctype)) {
scheme_print_bytes(pp, "#<ctype:", 0, 8);
ctype = CTYPE_BASETYPE(ctype);
if (SCHEME_SYMBOLP(ctype)) {
str = SCHEME_SYM_VAL(ctype);
scheme_print_bytes(pp, str, 0, strlen(str));
} else {
scheme_print_bytes(pp, "cstruct", 0, 7);
}
scheme_print_bytes(pp, ">", 0, 1);
} else {
scheme_print_bytes(pp, "#<ctype>", 0, 8);
}
}
/*****************************************************************************/
/* Initialization */
@ -2632,6 +2652,7 @@ void scheme_init_foreign(Scheme_Env *env)
{
Scheme_Env *menv;
ctype_struct *t;
Scheme_Object *s;
menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
ffi_lib_tag = scheme_make_type("<ffi-lib>");
ffi_obj_tag = scheme_make_type("<ffi-obj>");
@ -2643,6 +2664,7 @@ void scheme_init_foreign(Scheme_Env *env)
GC_register_traversers(ctype_tag, ctype_SIZE, ctype_MARK, ctype_FIXUP, 1, 0);
GC_register_traversers(ffi_callback_tag, ffi_callback_SIZE, ffi_callback_MARK, ffi_callback_FIXUP, 1, 0);
#endif
scheme_set_type_printer(ctype_tag, ctype_printer);
MZ_REGISTER_STATIC(opened_libs);
opened_libs = scheme_make_hash_table(SCHEME_hash_string);
MZ_REGISTER_STATIC(default_sym);
@ -2749,153 +2771,178 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 4), menv);
scheme_add_global("ffi-callback",
scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 4), menv);
s = scheme_intern_symbol("void");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_void));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_void);
scheme_add_global("_void", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int8");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint8));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int8);
scheme_add_global("_int8", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint8");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint8));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint8);
scheme_add_global("_uint8", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint16));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int16);
scheme_add_global("_int16", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint16));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint16);
scheme_add_global("_uint16", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int32");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int32);
scheme_add_global("_int32", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint32");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint32);
scheme_add_global("_uint32", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int64");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint64));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int64);
scheme_add_global("_int64", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint64");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint64));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint64);
scheme_add_global("_uint64", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("fixint");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixint);
scheme_add_global("_fixint", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("ufixint");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixint);
scheme_add_global("_ufixint", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("fixnum");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_smzlong));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixnum);
scheme_add_global("_fixnum", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("ufixnum");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_umzlong));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixnum);
scheme_add_global("_ufixnum", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("float");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_float));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_float);
scheme_add_global("_float", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("double");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_double);
scheme_add_global("_double", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("double*");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_doubleS);
scheme_add_global("_double*", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("bool");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_bool);
scheme_add_global("_bool", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("string/ucs-4");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4);
scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("string/utf-16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16);
scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("bytes");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_bytes);
scheme_add_global("_bytes", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("path");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_path);
scheme_add_global("_path", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("symbol");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_symbol);
scheme_add_global("_symbol", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("pointer");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_pointer);
scheme_add_global("_pointer", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("scheme");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_scheme);
scheme_add_global("_scheme", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("fpointer");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (NULL);
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_fpointer);
scheme_add_global("_fpointer", (Scheme_Object*)t, menv);

92
src/foreign/foreign.ssc
View File

@ -10,6 +10,8 @@ exec mzpp -s "---begin" -o `echo "$0" | sed 's/ssc$/c/'` "$0"
** to make changes, edit that file and
** run it to generate an updated version
** of this file.
** NOTE: This is no longer true, foreign.ssc needs to be updated to work with
** the scribble/text preprocessor instead.
********************************************/
{:(load "ssc-utils.ss"):}
@ -445,7 +447,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
(define *type-counter* 0)
(define (describe-type stype cname ftype ctype pred s->c c->s offset)
(define (describe-type type stype cname ftype ctype pred s->c c->s offset)
(set! *type-counter* (add1 *type-counter*))
(~ "#define FOREIGN_"cname" ("*type-counter*")" \\
"/* Type Name: "stype (and (not (equal? cname stype))
@ -466,7 +468,10 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
" * C->Scheme: "(cond [(not c->s) "-none-"]
[(procedure? c->s) (c->s "<C>")]
[else (list c->s"(<C>)")]) \\
" */" \\))
" */" \\
;; no need for these, at least for now:
;; "static Scheme_Object *"cname"_sym;"\\
))
(define (make-ctype type args)
(define (prop p . default)
@ -491,7 +496,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
[s->c (prop 's->c (and macro (list "SCHEME_"macro"_VAL")))]
[c->s (prop 'c->s)]
[offset (prop 'offset #f)])
(describe-type stype cname ftype ctype pred s->c c->s offset)
(describe-type type stype cname ftype ctype pred s->c c->s offset)
`(,type (stype ,stype) (cname ,cname) (ftype ,ftype) (ctype ,ctype)
(macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s) (offset ,offset))))
@ -726,17 +731,24 @@ typedef union _ForeignAny {
/* Type objects */
/* This struct is used for both user types and primitive types (including
* struct types). If it is a primitive type then basetype will be NULL, and
* struct types). If it is a user type then basetype will be another ctype,
* otherwise,
* - if it's a primitive type, then basetype will be a symbol naming that type
* - if it's a struct, then basetype will be the list of ctypes that
* made this struct
* scheme_to_c will have the &ffi_type pointer, and c_to_scheme will have an
* integer (a label value) for non-struct type. */
* integer (a label value) for non-struct type. (Note that the
* integer is not really needed, since it is possible to identify the
* type by the basetype field.)
*/
{:(cdefstruct ctype
(basetype "Scheme_Object*")
(scheme_to_c "Scheme_Object*")
(c_to_scheme "Scheme_Object*")):}
#define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype)
#define CTYPE_PRIMP(x) (NULL == (CTYPE_BASETYPE(x)))
#define CTYPE_USERP(x) (!(CTYPE_PRIMP(x)))
#define CTYPE_USERP(x) (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x)))
#define CTYPE_PRIMP(x) (!CTYPE_USERP(x))
#define CTYPE_PRIMTYPE(x) ((ffi_type*)(((ctype_struct*)(x))->scheme_to_c))
#define CTYPE_PRIMLABEL(x) ((long)(((ctype_struct*)(x))->c_to_scheme))
#define CTYPE_USER_S2C(x) (((ctype_struct*)(x))->scheme_to_c)
@ -745,12 +757,9 @@ typedef union _ForeignAny {
/* Returns #f for primitive types. */
{:(cdefine ctype-basetype 1):}
{
Scheme_Object *base;
if (!SCHEME_CTYPEP(argv[0]))
scheme_wrong_type(MYNAME, "ctype", 0, argc, argv);
base = CTYPE_BASETYPE(argv[0]);
if (NULL == base) return scheme_false;
else return base;
return CTYPE_BASETYPE(argv[0]);
}
{:(cdefine ctype-scheme->c 1):}
@ -892,7 +901,7 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
dummy = &libffi_type;
if (ffi_prep_cif(&cif, abi, 1, &ffi_type_void, dummy) != FFI_OK)
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
{:(cmake-object "type" ctype "NULL"
{:(cmake-object "type" ctype "argv[0]"
"(Scheme_Object*)libffi_type"
"(Scheme_Object*)FOREIGN_struct"):}
scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL);
@ -974,12 +983,11 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
int delta, int args_loc)
{
Scheme_Object *res, *base;
Scheme_Object *res;
if (!SCHEME_CTYPEP(type))
scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type);
base = CTYPE_BASETYPE(type);
if (base != NULL) {
res = C2SCHEME(base, src, delta, args_loc);
if (CTYPE_USERP(type)) {
res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc);
if (SCHEME_FALSEP(CTYPE_USER_C2S(type)))
return res;
else
@ -1008,13 +1016,6 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
* is used for both the function definition and calls, but the actual code in
* the function is different: in the relevant cases zero an int and offset the
* ptr */
#ifdef SCHEME_BIG_ENDIAN
#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \
scheme_to_c(typ,dst,delta,val,basep,_offset,retloc)
#else
#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \
scheme_to_c(typ,dst,delta,val,basep,_offset)
#endif
/* Usually writes the C object to dst and returns NULL. When basetype_p is not
* NULL, then any pointer value (any pointer or a struct) is returned, and the
@ -1091,7 +1092,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
(error 'scheme->c "unhandled pointer type: ~s" ctype)
(~ " if (!("(pred "val" x)")) "(wrong-type "val" stype) \\
" return NULL;"))))
(~ " "(wrong-type "type" "non-void-C-type")))):}
(~ " if (!ret_loc) "(wrong-type "type" "non-void-C-type")
~ " break;"))):}
case FOREIGN_struct:
if (!SCHEME_FFIANYPTRP(val))
scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);
@ -1677,6 +1679,9 @@ static Scheme_Object *do_memop(const char *who, int mode,
len, 0);
}
/* *** Calling Scheme code while the GC is working leads to subtle bugs, so
*** this is implemented now in Scheme using will executors. */
/* internal: apply Scheme finalizer */
void do_scm_finalizer(void *p, void *finalizer)
{
@ -1707,9 +1712,6 @@ void do_ptr_finalizer(void *p, void *finalizer)
/* (Only needed in cases where pointer aliases might be created.) */
/*
*** Calling Scheme code while the GC is working leads to subtle bugs, so
*** this is implemented now in Scheme using will executors.
{:"(defsymbols pointer)":}
{:"(cdefine register-finalizer 2 3)":}
{
@ -1789,7 +1791,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
offset = 0;
p = SCHEME2C(SCHEME_CAR(itypes), &(ivals[i]), 0, argv[i], &basetype,
&offset, 0);
if (p != NULL) {
if ((p != NULL) || offset) {
avalues[i] = p;
ivals[i].x_fixnum = basetype; /* remember the base type */
} else {
@ -1812,7 +1814,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
/* We finished with all possible mallocs, clear up the avalues and offsets
* mess */
for (i=0; i<nargs; i++) {
if (avalues[i] == NULL) /* if this was a non-pointer... */
if ((avalues[i] == NULL) && !offsets[i]) /* if this was a non-pointer... */
avalues[i] = &(ivals[i]); /* ... set the avalues pointer */
else if (ivals[i].x_fixnum != FOREIGN_struct) { /* if *not* a struct... */
/* ... set the ivals pointer (pointer type doesn't matter) and avalues */
@ -1961,7 +1963,7 @@ typedef struct closure_and_cif_struct {
void free_cl_cif_args(void *ignored, void *p)
{
/*
scheme_warning("Releaseing cl+cif+args %V %V (%d)",
scheme_warning("Releasing cl+cif+args %V %V (%d)",
ignored,
(((closure_and_cif*)p)->data),
SAME_OBJ(ignored,(((closure_and_cif*)p)->data)));
@ -2059,6 +2061,28 @@ void free_cl_cif_args(void *ignored, void *p)
return (Scheme_Object*)data;
}
/*****************************************************************************/
void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp)
{
char *str;
if (!SCHEME_CTYPEP(ctype))
scheme_wrong_type("Scheme->C", "C-type", 0, 1, &ctype);
if (CTYPE_PRIMP(ctype)) {
scheme_print_bytes(pp, "#<ctype:", 0, 8);
ctype = CTYPE_BASETYPE(ctype);
if (SCHEME_SYMBOLP(ctype)) {
str = SCHEME_SYM_VAL(ctype);
scheme_print_bytes(pp, str, 0, strlen(str));
} else {
scheme_print_bytes(pp, "cstruct", 0, 7);
}
scheme_print_bytes(pp, ">", 0, 1);
} else {
scheme_print_bytes(pp, "#<ctype>", 0, 8);
}
}
/*****************************************************************************/
/* Initialization */
@ -2066,6 +2090,7 @@ void scheme_init_foreign(Scheme_Env *env)
{
Scheme_Env *menv;
ctype_struct *t;
Scheme_Object *s;
menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
{:(for-each (lambda (x)
(~ (cadr x)"_tag = scheme_make_type(\"<"(car x)">\");"))
@ -2076,6 +2101,7 @@ void scheme_init_foreign(Scheme_Env *env)
(cadr x)"_MARK, " (cadr x)"_FIXUP, 1, 0);"))
(reverse cstructs)):}
#endif
scheme_set_type_printer(ctype_tag, ctype_printer);
MZ_REGISTER_STATIC(opened_libs);
opened_libs = scheme_make_hash_table(SCHEME_hash_string);
{:(for-each
@ -2090,7 +2116,11 @@ void scheme_init_foreign(Scheme_Env *env)
(cadr x)", \""(car x)"\", "(caddr x)", "(cadddr x)"), menv);"))
(reverse! cfunctions))
(for-each-type
(cmake-object "t" ctype "NULL"
;; no need for these, at least for now:
;; (~ "MZ_REGISTER_STATIC("cname"_sym);" \\
;; cname"_sym = scheme_intern_symbol(\""stype"\");")
(~ "s = scheme_intern_symbol(\""stype"\");")
(cmake-object "t" ctype "s"
(list "(Scheme_Object*)(void*)(&ffi_type_"ftype")")
(list "(Scheme_Object*)FOREIGN_"cname))
(~ "scheme_add_global(\"_"stype"\", (Scheme_Object*)t, menv);")):}

32
src/mzscheme/gc2/mem_account.c
View File

@ -214,7 +214,6 @@ inline static void clean_up_owner_table(NewGC *gc)
inline static unsigned long custodian_usage(NewGC*gc, void *custodian)
{
OTEntry **owner_table = gc->owner_table;
const int table_size = gc->owner_table_size;
unsigned long retval = 0;
int i;
@ -225,9 +224,13 @@ inline static unsigned long custodian_usage(NewGC*gc, void *custodian)
custodian = gc->park[0];
gc->park[0] = NULL;
}
for(i = 1; i < table_size; i++)
if(owner_table[i] && custodian_member_owner_set(gc, custodian, i))
retval += owner_table[i]->memory_use;
i = custodian_to_owner_set(gc, (Scheme_Custodian *)custodian);
if (owner_table[i])
retval = owner_table[i]->memory_use;
else
retval = 0;
return gcWORDS_TO_BYTES(retval);
}
@ -416,7 +419,7 @@ static void BTC_do_accounting(NewGC *gc)
OTEntry **owner_table = gc->owner_table;
if(gc->really_doing_accounting) {
Scheme_Custodian *cur = owner_table[current_owner(gc, NULL)]->originator;
Scheme_Custodian *cur = owner_table[current_owner(gc, NULL)]->originator, *last, *parent;
Scheme_Custodian_Reference *box = cur->global_next;
int i;
@ -429,13 +432,14 @@ static void BTC_do_accounting(NewGC *gc)
for(i = 1; i < table_size; i++)
if(owner_table[i])
owner_table[i]->memory_use = 0;
/* start with root: */
while (cur->parent && SCHEME_PTR1_VAL(cur->parent)) {
cur = SCHEME_PTR1_VAL(cur->parent);
}
/* walk forward for the order we want (blame parents instead of children) */
last = cur;
while(cur) {
int owner = custodian_to_owner_set(gc, cur);
@ -447,9 +451,25 @@ static void BTC_do_accounting(NewGC *gc)
GCDEBUG((DEBUGOUTF, "Propagating accounting marks\n"));
propagate_accounting_marks(gc);
last = cur;
box = cur->global_next; cur = box ? SCHEME_PTR1_VAL(box) : NULL;
}
/* walk backward folding totals int parent */
cur = last;
while (cur) {
int owner = custodian_to_owner_set(gc, cur);
box = cur->parent; parent = box ? SCHEME_PTR1_VAL(box) : NULL;
if (parent) {
int powner = custodian_to_owner_set(gc, parent);
owner_table[powner]->memory_use += owner_table[owner]->memory_use;
}
box = cur->global_prev; cur = box ? SCHEME_PTR1_VAL(box) : NULL;
}
gc->in_unsafe_allocation_mode = 0;
gc->doing_memory_accounting = 0;
gc->old_btc_mark = gc->new_btc_mark;