Sync

svn: r12898

collects/ffi/info.ss

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

collects/ffi/objc.scrbl

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

collects/ffi/objc.ss

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

collects/mzlib/foreign.ss

@@ -58,7 +58,7 @@
           (unsafe malloc) (unsafe free) (unsafe end-stubborn-change)
           cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!)
           ptr-offset ptr-add! offset-ptr? set-ptr-offset!
-          ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string)
+          ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string) ctype->layout
           _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64
           _fixint _ufixint _fixnum _ufixnum
           _float _double _double*
@@ -1494,6 +1494,26 @@
                     (if v (apply values v) (msg/fail-thunk))))]
             [else (msg/fail-thunk)]))))
 
+;; ----------------------------------------------------------------------------
+;;
+
+(define prim-synonyms
+  #hasheq((double* . double)
+          (fixint . long)
+          (ufixint . ulong)
+          (fixnum . long)
+          (ufixnum . ulong)
+          (path . bytes)
+          (symbol . bytes)
+          (scheme . pointer)))
+
+(define (ctype->layout c)
+  (let ([b (ctype-basetype c)])
+    (cond
+     [(ctype? b) (ctype->layout b)]
+     [(list? b) (map ctype->layout b)]
+     [else (hash-ref prim-synonyms b b)])))
+
 ;; ----------------------------------------------------------------------------
 ;; Misc utilities
 

collects/scheme/sandbox.ss

@@ -77,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
@@ -310,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
@@ -323,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])
+    (define timeout? #f)
-      (call-in-nested-thread*
+    (define r
-       (lambda ()
+      (parameterize ([current-custodian cust])
-         ;; time limit
+        (if sec
-         (when sec
+          (nested
-           (let ([t (current-thread)])
+           (lambda ()
-             (thread (lambda ()
+             ;; time limit
-                       (unless (sync/timeout sec t) (set! r 'time))
+             (when sec
-                       (kill-thread t)))))
+               (let ([t (current-thread)])
-         (set! r (with-handlers ([void (lambda (e) (list raise e))])
+                 (thread (lambda ()
-                   (call-with-values thunk (lambda vs (list* values vs))))))
+                           (unless (sync/timeout sec t) (set! timeout? #t))
-       ;; The thread might be killed by the timer thread, so don't let
+                           (kill-thread t)))))
-       ;; call-in-nested-thread* kill it -- if user code did so, then just
+             (thunk)))
-       ;; register the request and kill it below.  Do this for a
+          (nested thunk))))
-       ;; custodian-shutdown to, just in case.
+    (cond [timeout? (set! r 'time)]
-       (lambda ()
+          [(and cust-box (not (custodian-box-value cust-box)))
-         (unless r (set! r 'kill))
+           (if (memq r '(kill shut)) ; should always be 'shut
-         ;; (kill-thread (current-thread))
+             (set! r 'memory)
-         )
+             (format "cust died with: ~a" r))]) ; throw internal error below
-       (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
     (case r
       [(kill) (kill-thread (current-thread))]
       [(shut) (custodian-shutdown-all (current-custodian))]
@@ -369,21 +373,23 @@
 ;; other resource utilities
 
 (define (call-with-custodian-shutdown thunk)
-  (let ([cust (make-custodian (current-custodian))])
+  (let* ([cust (make-custodian (current-custodian))]
-    (dynamic-wind
+         [r (parameterize ([current-custodian cust]) (nested thunk))])
-      void
+    (case r
-      (lambda () (parameterize ([current-custodian cust]) (thunk)))
+      [(kill) (kill-thread (current-thread))]
-      (lambda () (custodian-shutdown-all cust)))))
+      [(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 (kill-all x)
+    (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)]))
-    (dynamic-wind
+    (case r
-      void
+      [(kill) (kill-thread (current-thread))]
-      (lambda () (parameterize ([current-custodian sub]) (thunk)))
+      [(shut) (custodian-shutdown-all (current-custodian))]
-      (lambda () (kill-all sub)))))
+      [else (apply (car r) (cdr r))])))
 
 (define sandbox-eval-handlers
   (make-parameter (list #f call-with-custodian-shutdown)))

collects/scribblings/foreign/types.scrbl

@@ -13,7 +13,7 @@ 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))]
@@ -35,12 +35,29 @@ otherwise.}
 
 
 @defproc*[([(ctype-sizeof [type ctype?]) exact-nonnegative-integer?]
-           [(ctype-alignof [ctype ctype?]) exact-nonnegative-integer?])]{
+           [(ctype-alignof [type ctype?]) exact-nonnegative-integer?])]{
 
 Returns the size or alignment of a given @scheme[type] for the current
 platform.}
 
 
+@defproc[(ctype->layout [type ctype?]) (flat-rec-contract rep
+                                         symbol?
+                                         (listof rep))]{
+
+Returns a value to describe the eventual C representation of the
+type. It can be any of the following symbols:
+
+@schemeblock[
+  'int8 'uint8 'int16 'uint16 'int32 'uint32 'int64 'uint64
+  'float 'double 'bool 'void 'pointer 'fpointer 
+  'bytes 'string/ucs-4 'string/utf-16
+]
+
+The result can also be a list, which describes a C struct whose
+element representations are provided in order within the list.}
+
+
 @defproc[(compiler-sizeof [sym symbol?]) exact-nonnegative-integer?]{
 
 Possible values for @scheme[symbol] are @scheme['int], @scheme['char],

collects/scribblings/reference/sandbox.scrbl

@@ -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
+evaluator.  The call is performed under the resource limits and
-used for evaluating expressions.
+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

src/foreign/foreign.c

@@ -1222,13 +1222,6 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
  * is used for both the function definition and calls, but the actual code in
  * the function is different: in the relevant cases zero an int and offset the
  * ptr */
-#ifdef SCHEME_BIG_ENDIAN
-#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \
-          scheme_to_c(typ,dst,delta,val,basep,_offset,retloc)
-#else
-#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \
-          scheme_to_c(typ,dst,delta,val,basep,_offset)
-#endif
 
 /* Usually writes the C object to dst and returns NULL.  When basetype_p is not
  * NULL, then any pointer value (any pointer or a struct) is returned, and the
@@ -1257,7 +1250,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
          scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val);
   } else switch (CTYPE_PRIMLABEL(type)) {
     case FOREIGN_void:
-      scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type));
+      if (!ret_loc) scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type));
+      break;
     case FOREIGN_int8:
 #ifdef SCHEME_BIG_ENDIAN
       if (sizeof(Tsint8)<sizeof(int) && ret_loc) {
@@ -1600,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);
@@ -2628,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 */
 
@@ -2647,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);

src/foreign/foreign.ssc

@@ -1016,13 +1016,6 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
  * is used for both the function definition and calls, but the actual code in
  * the function is different: in the relevant cases zero an int and offset the
  * ptr */
-#ifdef SCHEME_BIG_ENDIAN
-#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \
-          scheme_to_c(typ,dst,delta,val,basep,_offset,retloc)
-#else
-#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \
-          scheme_to_c(typ,dst,delta,val,basep,_offset)
-#endif
 
 /* Usually writes the C object to dst and returns NULL.  When basetype_p is not
  * NULL, then any pointer value (any pointer or a struct) is returned, and the
@@ -1099,7 +1092,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
                 (error 'scheme->c "unhandled pointer type: ~s" ctype)
                 (~ "  if (!("(pred "val" x)")) "(wrong-type "val" stype) \\
                    "  return NULL;"))))
-          (~ "  "(wrong-type "type" "non-void-C-type")))):}
+          (~ "  if (!ret_loc) "(wrong-type "type" "non-void-C-type")
+             ~ "  break;"))):}
     case FOREIGN_struct:
       if (!SCHEME_FFIANYPTRP(val))
         scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);
@@ -2067,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 */
 
@@ -2085,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

src/mzscheme/gc2/mem_account.c

@@ -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)) 
+  i = custodian_to_owner_set(gc, (Scheme_Custodian *)custodian);
-      retval += owner_table[i]->memory_use;
+  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;