some mz and ffi changes from the mr2 branch

svn: r18099

collects/ffi/objc.scrbl

@@ -54,6 +54,10 @@ The type of an Objective-C object, an opaque pointer.}
 
 The type of an Objective-C class, which is also an @scheme[_id].}
 
+@defthing[_Protocol ctype?]{
+
+The type of an Objective-C protocol, which is also an @scheme[_id].}
+
 @defthing[_SEL ctype?]{
 
 The type of an Objective-C selector, an opaque pointer.}
@@ -74,7 +78,7 @@ Synonym for @scheme[#f]}
 
 @; ----------------------------------------------------------------------
 
-@section{Syntactic Forms}
+@section{Syntactic Forms and Procedures}
 
 @defform*/subs[[(tell result-type obj-expr method-id)
                 (tell result-type obj-expr arg ...)]
@@ -117,18 +121,39 @@ Defines each @scheme[class-id] to the class (a value with FFI type
 (eval:alts (import-class NSString) (void))
 ]}
 
+@defform[(import-protocol protocol-id ...)]{
+
+Defines each @scheme[protocol-id] to the protocol (a value with FFI type
+@scheme[_Protocol]) that is registered with the string form of
+@scheme[protocol-id]. The registered class is obtained via
+@scheme[objc_getProtocol].
+
+@examples[
+#:eval objc-eval
+(eval:alts (import-protocol NSCoding) (void))
+]}
+
 @defform/subs[#:literals (+ - +a -a)
               (define-objc-class class-id superclass-expr
+                maybe-mixins
+                maybe-protocols
                 [field-id ...]
                 method)
-              ([method (mode result-ctype-expr (method-id) body ...+)
+              ([maybe-mixins code:blank
+                             (code:line #:mixins (mixin-expr ...))]
+               [maybe-protocols code:blank
+                                (code:line #:protocols (protocol-expr ...))]
+               [method (mode result-ctype-expr (method-id) body ...+)
                        (mode result-ctype-expr (arg ...+) body ...+)]
                [mode + - +a -a]
                [arg (code:line method-id [ctype-expr arg-id])])]{
 
 Defines @scheme[class-id] as a new, registered Objective-C class (of
-FFI type @scheme[_Class]). The @scheme[superclass-expr] should
+FFI type @scheme[_Class]). The @scheme[superclass-expr] should produce
-produce an Objective-C class or @scheme[#f] for the superclass.
+an Objective-C class or @scheme[#f] for the superclass. An optional
+@scheme[#:mixins] clause can specify mixins defined with
+@scheme[define-objc-mixin]. An optional @scheme[#:protocols] clause
+can specify Objective-C protocols to be implemented by the class.
 
 Each @scheme[field-id] is an instance field that holds a Scheme value
 and that is initialized to @scheme[#f] when the object is
@@ -170,19 +195,35 @@ space for each @scheme[field-id] within the instance is deallocated.
  (void))
 ]}
 
+@defform[(define-objc-mixin (class-id superclass-id)
+           maybe-mixins
+           maybe-protocols
+           [field-id ...]
+           method)]{
+
+Like @scheme[define-objc-class], but defines a mixin to be combined
+with other method definitions through either
+@scheme[define-objc-class] or @scheme[define-objc-mixin]. The
+specified @scheme[field-id]s are not added by the mixin, but must be a
+subset of the @scheme[field-id]s declared for the class to which the
+methods are added.}
+
+
 @defidform[self]{
 
-When used within the body of a @scheme[define-objc-class] method,
+When used within the body of a @scheme[define-objc-class] or
-refers to the object whose method was called. This form cannot be used
+@scheme[define-objc-mixin] method, refers to the object whose method
-outside of a @scheme[define-objc-class] method.}
+was called. This form cannot be used outside of a
+@scheme[define-objc-class] or @scheme[define-objc-mixin] method.}
 
 @defform*[[(super-tell result-type method-id)
            (super-tell result-type arg ...)]]{
 
-When used within the body of a @scheme[define-objc-class] method,
+When used within the body of a @scheme[define-objc-class] or
-calls a superclass method. The @scheme[result-type] and @scheme[arg]
+@scheme[define-objc-mixin] method, calls a superclass method. The
-sub-forms have the same syntax as in @scheme[tell]. This form cannot
+@scheme[result-type] and @scheme[arg] sub-forms have the same syntax
-be used outside of a @scheme[define-objc-class] method.}
+as in @scheme[tell]. This form cannot be used outside of a
+@scheme[define-objc-class] or @scheme[define-objc-mixin] method.}
 
 
 @defform[(get-ivar obj-expr field-id)]{
@@ -204,6 +245,11 @@ Returns a selector (of FFI type @scheme[_SEL]) for the string form of
 (eval:alts (tellv button setAction: #:type _SEL (selector terminate:)) (void))
 ]}
 
+@defproc[(objc-is-a? [obj _id] [cls _Class]) boolean?]{
+
+Check whether @scheme[obj] is an instance of the Objective-C class
+@scheme[cls].}
+
 @; ----------------------------------------------------------------------
 
 @section{Raw Runtime Functions}
@@ -212,6 +258,10 @@ Returns a selector (of FFI type @scheme[_SEL]) for the string form of
 
 Finds a registered class by name.}
 
+@defproc[(objc_getProtocol [s string?]) (or/c _Protocol #f)]{
+
+Finds a registered protocol by name.}
+
 @defproc[(sel_registerName [s string?]) _SEL]{
 
 Interns a selector given its name in string form.}
@@ -282,7 +332,7 @@ as the result type.}
 Like @scheme[objc_msgSend/typed], but for a super call.}
 
 @deftogether[(
-@defproc[(make-obj_csuper [id _id] [super _Class]) _objc_super]
+@defproc[(make-objc_super [id _id] [super _Class]) _objc_super]
 @defthing[_objc_super ctype?]
 )]{
 

collects/ffi/objc.ss

@@ -20,7 +20,7 @@
 
 ;; ----------------------------------------
 
-(provide _id _Class _BOOL _SEL _Ivar
+(provide _id _Class _Protocol _BOOL _SEL _Ivar
          make-objc_super _objc_super)
 
 (define _id (_cpointer/null 'id))
@@ -32,6 +32,11 @@
                            (lambda (p)
                              (when p (cpointer-push-tag! p 'Class))
                              p)))
+(define _Protocol (make-ctype _id
+                              (lambda (v) v)
+                              (lambda (p)
+                                (when p (cpointer-push-tag! p 'Protocol))
+                                p)))
 (define _BOOL (make-ctype _byte
                           (lambda (v) (if v 1 0))
                           (lambda (v) (not (eq? v 0)))))
@@ -46,6 +51,7 @@
 ;; ----------------------------------------
 
 (define-objc objc_lookUpClass (_fun _string -> _Class))
+(define-objc objc_getProtocol (_fun _string -> _Protocol))
 
 (define-objc sel_registerName (_fun _string -> _SEL))
 
@@ -65,15 +71,43 @@
                                               -> (values ivar p)))
 (define-objc object_setInstanceVariable (_fun _id _string _pointer -> _Ivar))
 
+(define-objc class_addProtocol (_fun _Class _Protocol -> _BOOL))
+
 (define-objc/private objc_msgSend _fpointer)
 (define-objc/private objc_msgSend_fpret _fpointer)
+(define-objc/private objc_msgSend_stret _fpointer)
 (define-objc/private objc_msgSendSuper _fpointer)
 (define objc_msgSendSuper_fpret objc_msgSendSuper) ; why no fpret variant?
+(define-objc/private objc_msgSendSuper_stret _fpointer)
 
-(define (lookup-send types msgSends msgSend msgSend_fpret first-arg-type)
+(define sizes-for-direct-struct-results
+  (case (string->symbol (path->string (system-library-subpath #f)))
+    [(i386-macosx i386-darwin) '(1 2 4 8)]
+    [(ppc-macosx ppc-darwin) '(1 2 3 4)]
+    [(x86_64-macosx x86_86-darwin) 
+     ;; Do we need more analysis for unaligned fields?
+     '(1 2 3 4 5 6 7 8)]))
+
+(define (lookup-send types msgSends msgSend msgSend_fpret msgSend_stret first-arg-type)
   ;; First type in `types' vector is the result type
   (or (hash-ref msgSends types #f)
-      (let ([m (function-ptr (if (memq (ctype->layout (vector-ref types 0))
+      (let ([ret-layout (ctype->layout (vector-ref types 0))])
+        (if (and (list? ret-layout)
+                 (not (memq (ctype-sizeof (vector-ref types 0)) 
+                            sizes-for-direct-struct-results)))
+            ;; Structure return type:
+            (let* ([pre-m (function-ptr msgSend_stret
+                                        (_cprocedure
+                                         (list* _pointer first-arg-type _SEL (cdr (vector->list types)))
+                                         _void))]
+                   [m (lambda args
+                        (let ([v (malloc (vector-ref types 0))])
+                          (apply pre-m v args)
+                          (ptr-ref v (vector-ref types 0))))])
+              (hash-set! msgSends types m)
+              m)
+            ;; Non-structure return type:
+            (let ([m (function-ptr (if (memq ret-layout
                                              '(float double double*))
                                        msgSend_fpret
                                        msgSend)
@@ -81,16 +115,16 @@
                                     (list* first-arg-type _SEL (cdr (vector->list types)))
                                     (vector-ref types 0)))])
               (hash-set! msgSends types m)
-        m)))
+              m)))))
 
 (define msgSends (make-hash))
 (define (objc_msgSend/typed types)
-  (lookup-send types msgSends objc_msgSend objc_msgSend_fpret _id))
+  (lookup-send types msgSends objc_msgSend objc_msgSend_fpret objc_msgSend_stret _id))
 (provide* (unsafe objc_msgSend/typed))
 
 (define msgSendSupers (make-hash))
 (define (objc_msgSendSuper/typed types)
-  (lookup-send types msgSendSupers objc_msgSendSuper objc_msgSendSuper_fpret _pointer))
+  (lookup-send types msgSendSupers objc_msgSendSuper objc_msgSendSuper_fpret objc_msgSendSuper_stret _pointer))
 (provide* (unsafe objc_msgSendSuper/typed))
 
 ;; ----------------------------------------
@@ -104,6 +138,15 @@
     [(_ id ...)
      (syntax/loc stx (begin (import-class id) ...))]))
 
+(provide* (unsafe import-protocol))
+(define-syntax (import-protocol stx)
+  (syntax-case stx ()
+    [(_ id)
+     (quasisyntax/loc stx
+       (define id (objc_getProtocol #,(symbol->string (syntax-e #'id)))))]
+    [(_ id ...)
+     (syntax/loc stx (begin (import-protocol id) ...))]))
+
 ;; ----------------------------------------
 ;; iget-value and set-ivar! work only with fields that contain Scheme values
 
@@ -329,23 +372,23 @@
 
 ;; ----------------------------------------
 
-(provide* (unsafe define-objc-class) self super-tell)
+(provide* (unsafe define-objc-class) 
+          (unsafe define-objc-mixin) 
+          self super-tell)
+
+(define-for-syntax ((check-id stx what) id)
+  (unless (identifier? id)
+    (raise-syntax-error #f
+                        (format "expected an identifier for ~a" what)
+                        stx
+                        id)))
 
 (define-syntax (define-objc-class stx)
   (syntax-case stx ()
-    [(_ id superclass (ivar ...) method ...)
+    [(_ id superclass #:mixins (mixin ...) #:protocols (proto ...) (ivar ...) method ...)
      (begin
-       (unless (identifier? #'id)
+       ((check-id stx "class definition") #'id)
-         (raise-syntax-error #f
+       (for-each (check-id stx "instance variable")
-                             "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 ...))])
@@ -369,12 +412,56 @@
              (begin
                (define superclass-id superclass)
                (define id (objc_allocateClassPair superclass-id id-str 0))
+               (void (class_addProtocol id proto)) ...
                (add-ivar id 'ivar) ...
                (let-syntax ([ivar (make-ivar-form 'ivar)] ...)
                  (add-method whole-stx id superclass-id method) ...
+                 (mixin id superclass-id '(ivar ...)) ...
                  (add-method whole-stx id superclass-id dealloc-method) ...
                  (void))
-               (objc_registerClassPair id))))))]))
+               (objc_registerClassPair id))))))]
+    [(_ id superclass (ivar ...) method ...)
+     #'(define-objc-class id superclass #:mixins () #:protocols () (ivar ...) method ...)]
+    [(_ id superclass #:mixins (mixin ...) (ivar ...) method ...)
+     #'(define-objc-class id superclass #:mixins (mixin ...) #:protocols () (ivar ...) method ...)]
+    [(_ id superclass #:protocols (proto ...) (ivar ...) method ...)
+     #'(define-objc-class id superclass #:mixins () #:protocols (proto ...) (ivar ...) method ...)]))
+
+(define (check-expected-ivars id got-ivars expected-ivars)
+  (when (ormap (lambda (s) (not (memq s got-ivars)))
+               expected-ivars)
+    (error id "expected to mix into class with at least ivars: ~s; mixed into class with ivars: ~s"
+           expected-ivars
+           got-ivars)))
+
+(define-syntax (define-objc-mixin stx)
+  (syntax-case stx ()
+    [(_ (id superclass-id) #:mixins (mixin ...) #:protocols (proto ...) (ivar ...) method ...)
+     (begin
+       ((check-id stx "class definition") #'id)
+       ((check-id stx "superclass") #'superclass-id)
+       (for-each (check-id stx "instance variable")
+                 (syntax->list #'(ivar ...)))
+       (with-syntax ([whole-stx stx]
+                     [(mixin-id ...) (generate-temporaries #'(mixin ...))]
+                     [(proto-id ...) (generate-temporaries #'(proto ...))])
+         (syntax/loc stx
+           (define id
+             (let ([mixin-id mixin] ...
+                   [protocol-id proto] ...)
+               (lambda (to-id superclass-id ivars)
+                 (check-expected-ivars 'id ivars '(ivar ...))
+                 (void (class_addProtocol to-id proto-id)) ...
+                 (let-syntax ([ivar (make-ivar-form 'ivar)] ...)
+                   (add-method whole-stx to-id superclass-id method) ...
+                   (void))
+                 (mixin-id to-id superclass-id ivars) ...))))))]
+    [(_ (id superclass) (ivar ...) method ...)
+     #'(define-objc-mixin (id superclass) #:mixins () #:protocols () (ivar ...) method ...)]
+    [(_ (id superclass) #:mixins (mixin ...) (ivar ...) method ...)
+     #'(define-objc-mixin (id superclass) #:mixins (mixin ...) #:protocols () (ivar ...) method ...)]
+    [(_ (id superclass) #:protocols (proto ...) (ivar ...) method ...)
+     #'(define-objc-mixin (id superclass) #:mixins () #:protocols (proto ...) (ivar ...) method ...)]))
 
 (define-for-syntax (make-ivar-form sym)
   (with-syntax ([sym sym])
@@ -477,7 +564,7 @@
                             [(dealloc-body ...)
                              (if (eq? (syntax-e id) 'dealloc)
                                  (syntax-case stx ()
-                                   [(_ _ _ [ivar ...] . _)
+                                   [(_ _ _ #:mixins _ #:protocols _ [ivar ...] . _)
                                     (with-syntax ([(ivar-str ...)
                                                    (map (lambda (ivar)
                                                           (symbol->string (syntax-e ivar)))
@@ -491,19 +578,19 @@
                                         #'cls)]
                             [atomic? (or (free-identifier=? #'kind #'+a)
                                          (free-identifier=? #'kind #'-a))])
-                (syntax/loc stx
+                (quasisyntax/loc stx
                   (let ([rt result-type]
                         [arg-id arg-type] ...)
                     (void (class_addMethod in-cls
                                            (sel_registerName id-str)
-                                           (save-method!
+                                           #,(syntax/loc #'m
                                                (lambda (self-id cmd arg-id ...)
                                                  (syntax-parameterize ([self (make-id-stx #'self-id)]
                                                                        [super-class (make-id-stx #'superclass-id)]
                                                                        [super-tell do-super-tell])
                                                    body0 body ...
                                                    dealloc-body ...)))
-                                           (_fun #:atomic? atomic? _id _id arg-type ... -> rt)
+                                           (_fun #:atomic? atomic? #:keep save-method! _id _id arg-type ... -> rt)
                                            (generate-layout rt (list arg-id ...)))))))))]
          [else (raise-syntax-error #f
                                    "bad method form"
@@ -557,5 +644,12 @@
 
 ;; --------------------------------------------------
 
+(provide* (unsafe objc-is-a?))
+
+(define (objc-is-a? v c)
+  (ptr-equal? (object_getClass v) c))
+
+;; ----------------------------------------
+
 (define-unsafer objc-unsafe!)
 

collects/ffi/private/objc-doc-unsafe.ss

@@ -9,8 +9,20 @@
 (provide (protect-out objc_msgSend/typed
                       objc_msgSendSuper/typed
                       import-class
+                      import-protocol
                       get-ivar set-ivar!
                       selector
                       tell tellv
-                      define-objc-class)
+                      define-objc-class
+                      define-objc-mixin
+                      objc_lookUpClass
+                      objc_getProtocol
+                      sel_registerName
+                      objc_allocateClassPair
+                      objc_registerClassPair
+                      object_getClass
+                      class_addIvar
+                      object_getInstanceVariable
+                      object_setInstanceVariable
+                      objc-is-a?)
          (all-from-out ffi/objc))

collects/scheme/foreign.ss

@@ -2,7 +2,8 @@
 
 ;; Foreign Scheme interface
 (require '#%foreign setup/dirs scheme/unsafe/ops
-         (for-syntax scheme/base scheme/list syntax/stx))
+         (for-syntax scheme/base scheme/list syntax/stx
+                     scheme/struct-info))
 
 ;; This module is full of unsafe bindings that are not provided to requiring
 ;; modules.  Instead, an `unsafe!' binding is provided that makes these unsafe
@@ -1451,6 +1452,7 @@
          [struct-string        (format "struct:~a" name)]
          [(slot ...)           slot-names-stx]
          [(slot-type ...)      slot-types-stx]
+         [TYPE                 (id name)]
          [_TYPE                _TYPE-stx]
          [_TYPE-pointer        (id "_"name"-pointer")]
          [_TYPE-pointer/null   (id "_"name"-pointer/null")]
@@ -1475,7 +1477,17 @@
                        #'(values #f '() #f #f #f #f)
                        #`(cstruct-info #,1st-type
                            (lambda () (values #f '() #f #f #f #f))))])
-        #'(define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
+        #'(begin
+            (define-syntax TYPE
+              (make-struct-info
+               (lambda ()
+                 (list #f ; no struct:
+                       (quote-syntax make-TYPE)
+                       (quote-syntax TYPE?)
+                       (reverse (list (quote-syntax TYPE-SLOT) ...))
+                       (reverse (list (quote-syntax set-TYPE-SLOT!) ...))
+                       #t))))
+            (define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
                                   make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
                                   list->TYPE list*->TYPE TYPE->list TYPE->list*)
               (let-values ([(super-pointer super-tags super-types super-offsets
@@ -1577,7 +1589,7 @@
                    _TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE)
                   (values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
                           make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
-                        list->TYPE list*->TYPE TYPE->list TYPE->list*)))))))
+                          list->TYPE list*->TYPE TYPE->list TYPE->list*))))))))
   (define (identifiers? stx)
     (andmap identifier? (syntax->list stx)))
   (define (_-identifier? id stx)

collects/scribblings/foreign/types.scrbl

@@ -1,5 +1,6 @@
 #lang scribble/doc
-@(require "utils.ss")
+@(require "utils.ss"
+          (for-label scheme/match))
 
 @title[#:tag "types" #:style 'toc]{C Types}
 
@@ -780,6 +781,11 @@ The resulting bindings are as follows:
  @item{@schemeidfont{set-}@schemevarfont{id}@schemeidfont{-}@scheme[field-id]@schemeidfont{!}
   : a mutator function for each @scheme[field-id].}
 
+ @item{@schemevarfont{id}: structure-type information compatible with
+  @scheme[struct-out] or @scheme[match] (but not @scheme[define-struct]);
+  currently, this information is correct only when no @scheme[super-id]
+  is specified.}
+
 ]
 
 Objects of the new type are actually C pointers, with a type tag that

collects/scribblings/reference/syntax.scrbl

@@ -776,7 +776,7 @@ follows.
  @defsubform[(struct-out id)]{Exports the bindings associated with a
  structure type @scheme[id]. Typically, @scheme[id] is bound with
  @scheme[(define-struct id ....)] or @scheme[(define-struct (id
- super-id) ....)]; more generally, @scheme[id] must have a
+ _super-id) ....)]; more generally, @scheme[id] must have a
  @tech{transformer binding} of structure-type information at
  @tech{phase level} 0; see @secref["structinfo"].  Furthermore, for
  each identifier mentioned in the structure-type information, the

src/mzscheme/include/mzscheme.exp

@@ -79,6 +79,9 @@ scheme_pop_kill_action
 scheme_set_can_break
 scheme_push_break_enable
 scheme_pop_break_enable
+scheme_with_stack_freeze
+scheme_frozen_run_some
+scheme_is_in_frozen_stack
 scheme_signal_error
 scheme_raise_exn
 scheme_warning
@@ -485,7 +488,6 @@ scheme_print_utf8
 scheme_print_string
 scheme_read_byte_string
 scheme_make_namespace
-scheme_add_namespace_option
 scheme_add_global
 scheme_add_global_symbol
 scheme_make_envunbox

src/mzscheme/include/mzscheme3m.exp

@@ -79,6 +79,9 @@ scheme_pop_kill_action
 scheme_set_can_break
 scheme_push_break_enable
 scheme_pop_break_enable
+scheme_with_stack_freeze
+scheme_frozen_run_some
+scheme_is_in_frozen_stack
 scheme_signal_error
 scheme_raise_exn
 scheme_warning
@@ -491,7 +494,6 @@ scheme_print_utf8
 scheme_print_string
 scheme_read_byte_string
 scheme_make_namespace
-scheme_add_namespace_option
 scheme_add_global
 scheme_add_global_symbol
 scheme_make_envunbox

src/mzscheme/include/mzwin.def

@@ -81,6 +81,9 @@ EXPORTS
  scheme_set_can_break
  scheme_push_break_enable
  scheme_pop_break_enable
+ scheme_with_stack_freeze
+ scheme_frozen_run_some
+ scheme_is_in_frozen_stack
  scheme_signal_error
  scheme_raise_exn
  scheme_warning
@@ -468,7 +471,6 @@ EXPORTS
  scheme_print_string
  scheme_read_byte_string
  scheme_make_namespace
- scheme_add_namespace_option
  scheme_add_global
  scheme_add_global_symbol
  scheme_make_envunbox

src/mzscheme/include/mzwin3m.def

@@ -81,6 +81,9 @@ EXPORTS
  scheme_set_can_break
  scheme_push_break_enable
  scheme_pop_break_enable
+ scheme_with_stack_freeze
+ scheme_frozen_run_some
+ scheme_is_in_frozen_stack
  scheme_signal_error
  scheme_raise_exn
  scheme_warning
@@ -483,7 +486,6 @@ EXPORTS
  scheme_print_string
  scheme_read_byte_string
  scheme_make_namespace
- scheme_add_namespace_option
  scheme_add_global
  scheme_add_global_symbol
  scheme_make_envunbox

src/mzscheme/include/scheme.h

@@ -1137,6 +1137,7 @@ typedef void (*Scheme_Kill_Action_Func)(void *);
       thread->error_buf = savebuf; \
       thread = NULL; } }
 
+typedef int (*Scheme_Frozen_Stack_Proc)(void *);
 
 /*========================================================================*/
 /*                             parameters                                 */

src/mzscheme/src/mzmark.c

@@ -4432,6 +4432,39 @@ static int mark_thread_cell_FIXUP(void *p) {
 #define mark_thread_cell_IS_CONST_SIZE 1
 
 
+static int mark_frozen_tramp_SIZE(void *p) {
+  return
+  gcBYTES_TO_WORDS(sizeof(FrozenTramp));
+}
+
+static int mark_frozen_tramp_MARK(void *p) {
+  FrozenTramp *f = (FrozenTramp *)p;
+ 
+  gcMARK(f->do_data);
+  gcMARK(f->old_param);
+  gcMARK(f->config);
+  gcMARK(f->progress_cont);
+
+  return
+  gcBYTES_TO_WORDS(sizeof(FrozenTramp));
+}
+
+static int mark_frozen_tramp_FIXUP(void *p) {
+  FrozenTramp *f = (FrozenTramp *)p;
+ 
+  gcFIXUP(f->do_data);
+  gcFIXUP(f->old_param);
+  gcFIXUP(f->config);
+  gcFIXUP(f->progress_cont);
+
+  return
+  gcBYTES_TO_WORDS(sizeof(FrozenTramp));
+}
+
+#define mark_frozen_tramp_IS_ATOMIC 0
+#define mark_frozen_tramp_IS_CONST_SIZE 1
+
+
 #endif  /* THREAD */
 
 /**********************************************************************/

src/mzscheme/src/mzmarksrc.c

@@ -1804,6 +1804,19 @@ mark_thread_cell {
   gcBYTES_TO_WORDS(sizeof(Thread_Cell));
 }
 
+mark_frozen_tramp {
+ mark:
+  FrozenTramp *f = (FrozenTramp *)p;
+ 
+  gcMARK(f->do_data);
+  gcMARK(f->old_param);
+  gcMARK(f->config);
+  gcMARK(f->progress_cont);
+
+ size:
+  gcBYTES_TO_WORDS(sizeof(FrozenTramp));
+}
+
 END thread;
 
 /**********************************************************************/

src/mzscheme/src/schemef.h

@@ -176,6 +176,10 @@ MZ_EXTERN void scheme_set_can_break(int on);
 MZ_EXTERN void scheme_push_break_enable(Scheme_Cont_Frame_Data *cframe, int on, int pre_check);
 MZ_EXTERN void scheme_pop_break_enable(Scheme_Cont_Frame_Data *cframe, int post_check);
 
+MZ_EXTERN int scheme_with_stack_freeze(Scheme_Frozen_Stack_Proc wha_f, void *wha_data);
+MZ_EXTERN int scheme_frozen_run_some(Scheme_Frozen_Stack_Proc do_f, void *do_data, int run_msecs);
+MZ_EXTERN int scheme_is_in_frozen_stack();
+
 /*========================================================================*/
 /*                              error handling                            */
 /*========================================================================*/

src/mzscheme/src/schemex.h

@@ -139,6 +139,9 @@ void (*scheme_pop_kill_action)();
 void (*scheme_set_can_break)(int on);
 void (*scheme_push_break_enable)(Scheme_Cont_Frame_Data *cframe, int on, int pre_check);
 void (*scheme_pop_break_enable)(Scheme_Cont_Frame_Data *cframe, int post_check);
+int (*scheme_with_stack_freeze)(Scheme_Frozen_Stack_Proc wha_f, void *wha_data);
+int (*scheme_frozen_run_some)(Scheme_Frozen_Stack_Proc do_f, void *do_data, int run_msecs);
+int (*scheme_is_in_frozen_stack)();
 /*========================================================================*/
 /*                              error handling                            */
 /*========================================================================*/

src/mzscheme/src/schemex.inc

@@ -87,6 +87,9 @@
   scheme_extension_table->scheme_set_can_break = scheme_set_can_break;
   scheme_extension_table->scheme_push_break_enable = scheme_push_break_enable;
   scheme_extension_table->scheme_pop_break_enable = scheme_pop_break_enable;
+  scheme_extension_table->scheme_with_stack_freeze = scheme_with_stack_freeze;
+  scheme_extension_table->scheme_frozen_run_some = scheme_frozen_run_some;
+  scheme_extension_table->scheme_is_in_frozen_stack = scheme_is_in_frozen_stack;
   scheme_extension_table->scheme_signal_error = scheme_signal_error;
   scheme_extension_table->scheme_raise_exn = scheme_raise_exn;
   scheme_extension_table->scheme_warning = scheme_warning;

src/mzscheme/src/schemexm.h

@@ -87,6 +87,9 @@
 #define scheme_set_can_break (scheme_extension_table->scheme_set_can_break)
 #define scheme_push_break_enable (scheme_extension_table->scheme_push_break_enable)
 #define scheme_pop_break_enable (scheme_extension_table->scheme_pop_break_enable)
+#define scheme_with_stack_freeze (scheme_extension_table->scheme_with_stack_freeze)
+#define scheme_frozen_run_some (scheme_extension_table->scheme_frozen_run_some)
+#define scheme_is_in_frozen_stack (scheme_extension_table->scheme_is_in_frozen_stack)
 #define scheme_signal_error (scheme_extension_table->scheme_signal_error)
 #define scheme_raise_exn (scheme_extension_table->scheme_raise_exn)
 #define scheme_warning (scheme_extension_table->scheme_warning)

src/mzscheme/src/stypes.h

@@ -249,6 +249,7 @@ enum {
   scheme_rt_sfs_info,                   /* 227 */
   scheme_rt_validate_clearing,          /* 228 */
   scheme_rt_rb_node,                    /* 229 */
+  scheme_rt_frozen_tramp,               /* 230 */
 #endif
 
 

src/mzscheme/src/thread.c

@@ -100,7 +100,7 @@ extern HANDLE scheme_break_semaphore;
 # define SENORA_GC_NO_FREE
 #endif
 
-/* If a finalization callback in MrEd invokes Scheme code,
+/* If a finalization callback invokes Scheme code,
    we can end up with a thread swap in the middle of a thread
    swap (where the outer swap was interrupted by GC). The
    following is a debugging flag to help detect and fix
@@ -209,8 +209,7 @@ HOOK_SHARED_OK void (*scheme_on_atomic_timeout)(void);
 
 ROSYM static Scheme_Object *read_symbol, *write_symbol, *execute_symbol, *delete_symbol, *exists_symbol;
 ROSYM static Scheme_Object *client_symbol, *server_symbol;
-
+ROSYM static Scheme_Object *froz_key;
-	
 
 THREAD_LOCAL_DECL(static int do_atomic = 0);
 THREAD_LOCAL_DECL(static int missed_context_switch = 0);
@@ -448,6 +447,9 @@ void scheme_init_thread(Scheme_Env *env)
   client_symbol = scheme_intern_symbol("client");
   server_symbol = scheme_intern_symbol("server");
   
+  REGISTER_SO(froz_key);
+  froz_key = scheme_make_symbol("frozen"); /* uninterned */
+
   scheme_add_global_constant("dump-memory-stats",
 			     scheme_make_prim_w_arity(scheme_dump_gc_stats,
 						      "dump-memory-stats",
@@ -3215,7 +3217,7 @@ Scheme_Object *scheme_thread_w_details(Scheme_Object *thunk,
     Scheme_Thread *p = scheme_current_thread;
 
     /* Don't mangle the stack if we're in atomic mode, because that
-       probably means a MrEd HET trampoline, etc. */
+       probably means a stack-freeze trampoline, etc. */
     wait_until_suspend_ok();
 
     p->ku.k.p1 = thunk;
@@ -7631,6 +7633,266 @@ void scheme_free_gmp(void *p, void **mem_pool)
   *mem_pool = SCHEME_CDR(*mem_pool);
 }
 
+/*========================================================================*/
+/*                             stack freezer                              */
+/*========================================================================*/
+
+/* When interacting with certain libraries that can lead to Scheme
+   callbacks, the stack region used by the library should not be
+   modified by Scheme thread swaps. In that case, the callback must be
+   constrained. Completely disallowing synchornization with ther
+   threads or unbounded computation, however, is sometimes too
+   difficult. A stack-freezer sequence offer a compromise, where the
+   callback is run as much as possible, but it can be suspended to
+   allow the library call to return so that normal Scheme-thread
+   scheduling can resume. The callback is then completed in a normal
+   scheduling context, where it is no longer specially constrained.
+   
+   The call process is
+    scheme_with_stack_freeze(f, data)
+     -> f(data) in frozen mode
+         -> ... frozen_run_some(g, data2)          \
+             -> Scheme code, may finish or may not  | maybe loop
+         froz->in_progress inicates whether done   /
+     -> continue scheme if not finished
+
+   In this process, it's the call stack between f(data) and the call
+   to frozen_run_some() that won't be copied in or out until f(data)
+   returns.
+
+   Nesting scheme_with_stack_freeze() calls should be safe, but it
+   won't achieve the goal, which is to limit the amount of work done
+   before returning (because the inner scheme_with_stack_freeze() will
+   have to run to completion). */
+
+static unsigned long get_deeper_base();
+
+typedef struct FrozenTramp {
+  MZTAG_IF_REQUIRED
+  Scheme_Frozen_Stack_Proc do_f;
+  void *do_data;
+  int val;
+  int in_progress;
+  int progress_is_resumed;
+  Scheme_Object *old_param;
+  Scheme_Config *config;
+  void *progress_base_addr;
+  mz_jmp_buf progress_base;
+  Scheme_Jumpup_Buf_Holder *progress_cont;
+  int timer_on;
+  double continue_until;
+#ifdef MZ_PRECISE_GC
+  void *fixup_var_stack_chain;
+#endif
+}  FrozenTramp;
+
+int scheme_with_stack_freeze(Scheme_Frozen_Stack_Proc wha_f, void *wha_data)
+{
+  FrozenTramp *froz;
+  Scheme_Cont_Frame_Data cframe;
+  Scheme_Object *bx;
+  int retval;
+  Scheme_Jumpup_Buf_Holder *pc;
+
+  froz = MALLOC_ONE_RT(FrozenTramp);
+  SET_REQUIRED_TAG(froz->type = scheme_rt_frozen_tramp);
+
+  bx = scheme_make_raw_pair((Scheme_Object *)froz, NULL);
+
+  scheme_push_continuation_frame(&cframe);
+  scheme_set_cont_mark(froz_key, bx);
+
+  pc = scheme_new_jmpupbuf_holder();
+  froz->progress_cont = pc;
+
+  scheme_init_jmpup_buf(&froz->progress_cont->buf);
+
+  scheme_start_atomic();
+  retval = wha_f(wha_data);
+  froz->val = retval;
+
+  if (froz->in_progress) {
+    /* We have leftover work; jump and finish it (non-atomically).
+       But don't swap until we've jumped back in, because the jump-in
+       point might be trying to suspend the thread (and that should
+       complete before any swap). */
+    scheme_end_atomic_no_swap();
+    SCHEME_CAR(bx) = NULL;
+    froz->in_progress = 0;
+    froz->progress_is_resumed = 1;
+    if (!scheme_setjmp(froz->progress_base)) {
+#ifdef MZ_PRECISE_GC
+      froz->fixup_var_stack_chain = &__gc_var_stack__;
+#endif
+      scheme_longjmpup(&froz->progress_cont->buf);
+    }
+  } else {
+    scheme_end_atomic();
+  }
+
+  scheme_pop_continuation_frame(&cframe);
+
+  froz->old_param = NULL;
+  froz->progress_cont = NULL;
+  froz->do_data = NULL;
+
+  return froz->val;
+}
+
+static void suspend_froz_progress(void)
+{
+  FrozenTramp * volatile froz;
+  double msecs;
+  Scheme_Object *v;
+
+  v = scheme_extract_one_cc_mark(NULL, froz_key);
+  froz = (FrozenTramp *)SCHEME_CAR(v);
+  v = NULL;
+
+  msecs = scheme_get_inexact_milliseconds();
+  if (msecs < froz->continue_until)
+    return;
+
+  scheme_on_atomic_timeout = NULL;
+
+  froz->in_progress = 1;
+  if (scheme_setjmpup(&froz->progress_cont->buf, (void*)froz->progress_cont, froz->progress_base_addr)) {
+    /* we're back */
+    scheme_reset_jmpup_buf(&froz->progress_cont->buf);
+#ifdef MZ_PRECISE_GC
+    /* Base addr points to the last valid gc_var_stack address.
+       Fixup that link to skip over the part of the stack we're
+       not using right now. */
+    ((void **)froz->progress_base_addr)[0] = froz->fixup_var_stack_chain;
+    ((void **)froz->progress_base_addr)[1] = NULL;
+#endif
+  } else {
+    /* we're leaving */
+    scheme_longjmp(froz->progress_base, 1);
+  }
+}
+
+static void froz_run_new(FrozenTramp * volatile froz, int run_msecs)
+{
+  double msecs;
+
+  /* We're willing to start new work that is specific to this thread */
+  froz->progress_is_resumed = 0;
+
+  msecs = scheme_get_inexact_milliseconds();
+  froz->continue_until = msecs + run_msecs;
+  
+  if (!scheme_setjmp(froz->progress_base)) {
+    Scheme_Frozen_Stack_Proc do_f;
+    scheme_start_atomic();
+    scheme_on_atomic_timeout = suspend_froz_progress;
+    do_f = froz->do_f;
+    do_f(froz->do_data);
+  }
+
+  if (froz->progress_is_resumed) {
+    /* we've already returned once; jump out to new progress base */
+    scheme_longjmp(froz->progress_base, 1);
+  } else {
+    scheme_on_atomic_timeout = NULL;
+    scheme_end_atomic_no_swap();
+  }
+}
+
+static void froz_do_run_new(FrozenTramp * volatile froz, int *iteration, int run_msecs)
+{
+  /* This function just makes room on the stack, eventually calling
+     froz_run_new(). */
+  int new_iter[32];
+
+  if (iteration[0] == 3) {
+#ifdef MZ_PRECISE_GC
+    froz->progress_base_addr = (void *)&__gc_var_stack__;
+#else
+    froz->progress_base_addr = (void *)new_iter;
+#endif
+    froz_run_new(froz, run_msecs);
+  } else {
+    new_iter[0] = iteration[0] + 1;
+    froz_do_run_new(froz, new_iter, run_msecs);
+  }
+}
+
+int scheme_frozen_run_some(Scheme_Frozen_Stack_Proc do_f, void *do_data, int run_msecs)
+{
+  FrozenTramp * volatile froz;
+  int more = 0;
+  Scheme_Object *v;
+  
+  v = scheme_extract_one_cc_mark(NULL, froz_key);
+  if (v)
+    froz = (FrozenTramp *)SCHEME_CAR(v);
+  else
+    froz = NULL;
+  v = NULL;
+
+  if (froz) {
+    if (froz->in_progress) {
+      /* We have work in progress. */
+      if ((unsigned long)froz->progress_base_addr < get_deeper_base()) {
+	/* We have stack space to resume the old work: */
+        double msecs;
+	froz->in_progress = 0;
+	froz->progress_is_resumed = 1;
+        msecs = scheme_get_inexact_milliseconds();
+        froz->continue_until = msecs + run_msecs;
+	scheme_start_atomic();
+	scheme_on_atomic_timeout = suspend_froz_progress;
+	if (!scheme_setjmp(froz->progress_base)) {
+#ifdef MZ_PRECISE_GC
+	  froz->fixup_var_stack_chain = &__gc_var_stack__;
+#endif
+	  scheme_longjmpup(&froz->progress_cont->buf);
+	} else {
+	  scheme_on_atomic_timeout = NULL;
+	  scheme_end_atomic_no_swap();
+	}
+      }
+    } else {
+      int iter[1];
+      iter[0] = 0;
+      froz->do_f = do_f;
+      froz->do_data = do_data;
+      froz_do_run_new(froz, iter, run_msecs);
+    }
+
+    more = froz->in_progress;
+  }
+
+  return more;
+}
+
+int scheme_is_in_frozen_stack()
+{
+  Scheme_Object *v;
+  
+  v = scheme_extract_one_cc_mark(NULL, froz_key);
+  if (v)
+    return 1;
+  else
+    return 0;
+}
+
+/* Disable warning for returning address of local variable: */
+#ifdef _MSC_VER
+#pragma warning (disable:4172)
+#endif
+
+static unsigned long get_deeper_base()
+{
+  long here;
+  return (unsigned long)&here;
+}
+
+#ifdef _MSC_VER
+#pragma warning (default:4172)
+#endif
+
 /*========================================================================*/
 /*                               precise GC                               */
 /*========================================================================*/
@@ -7638,7 +7900,7 @@ void scheme_free_gmp(void *p, void **mem_pool)
 Scheme_Jumpup_Buf_Holder *scheme_new_jmpupbuf_holder(void)
 /* Scheme_Jumpup_Buf_Holder exists for precise GC, and for external
    programs that want to store Jumpup_Bufs, because the GC interaction
-   is tricky. For example, MrEd uses it for a special trampoline
+   is tricky. For example, we use it above for a special trampoline
    implementation. */
 {
   Scheme_Jumpup_Buf_Holder *h;
@@ -7683,6 +7945,7 @@ static void register_traversers(void)
   GC_REG_TRAV(scheme_rt_evt, mark_evt);
   GC_REG_TRAV(scheme_rt_syncing, mark_syncing);
   GC_REG_TRAV(scheme_rt_parameterization, mark_parameterization);
+  GC_REG_TRAV(scheme_rt_frozen_tramp, mark_frozen_tramp);
 }
 
 END_XFORM_SKIP;