diff --git a/collects/ffi/objc.scrbl b/collects/ffi/objc.scrbl
index a43ccb9713..b2b984d44c 100644
--- a/collects/ffi/objc.scrbl
+++ b/collects/ffi/objc.scrbl
@@ -14,9 +14,7 @@
 
 @title{@bold{Objective-C} FFI}
 
-@declare-exporting[ffi/private/objc-doc-unsafe #:use-sources (ffi/objc)]
-
-@defmodule*/no-declare[(ffi/objc)]{The @schememodname[ffi/objc] library builds on
+@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}.}
 
diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss
index 5ca2e2446e..00d2ccebd7 100644
--- a/collects/mzlib/foreign.ss
+++ b/collects/mzlib/foreign.ss
@@ -1,1620 +1,4 @@
-#lang scheme/base
 
-;; Foreign Scheme interface
-(require '#%foreign setup/dirs
-         (for-syntax scheme/base scheme/list syntax/stx))
-
-;; This module is full of unsafe bindings that are not provided to requiring
-;; modules.  Instead, an `unsafe!' binding is provided that makes these unsafe
-;; bindings available.  The following two syntaxes do that: `provide*' is like
-;; `provide', but using `(unsafe id)' registers an unsafe binding.  Then,
-;; `define-unsafer' should be used with a binding that will expose the unsafe
-;; bindings.  This might move elsewhere at some point if it turns out to be
-;; useful in other contexts.
-(provide provide* define-unsafer)
-(define-syntaxes (provide* define-unsafer)
-  (let ((unsafe-bindings '()))
-    (values
-     (lambda (stx)
-       (syntax-case stx ()
-         [(_ p ...)
-          (let loop ([provides '()]
-                     [unsafes  '()]
-                     [ps (syntax->list #'(p ...))])
-            (if (null? ps)
-              (begin (set! unsafe-bindings
-                           (append unsafe-bindings (reverse unsafes)))
-                     (with-syntax ([(p ...) provides]) #'(provide p ...)))
-              (syntax-case (car ps) (unsafe)
-                [(unsafe u)
-                 (syntax-case #'u (rename-out)
-                   [(rename-out [from to])
-                    (loop provides (cons (cons #'from #'to) unsafes) (cdr ps))]
-                   [id (identifier? #'id)
-                    (loop provides (cons (cons #'id #'id) unsafes) (cdr ps))]
-                   [_
-                    (raise-syntax-error 'provide* "bad unsafe usage"
-                                        (car ps) stx)])]
-                [_ (loop (cons (car ps) provides) unsafes (cdr ps))])))]))
-     (lambda (stx)
-       (syntax-case stx ()
-         [(_ unsafe)
-          (with-syntax ([(from ...)  (map car unsafe-bindings)]
-                        [(to   ...)  (map cdr unsafe-bindings)]
-                        [(id   ...) (generate-temporaries unsafe-bindings)])
-            (set! unsafe-bindings '())
-            #'(begin
-                (provide (protect-out unsafe))
-                (define-syntax (unsafe stx)
-                  (syntax-case stx ()
-                    [(_) (with-syntax ([(id ...) (list (datum->syntax
-                                                        stx 'to stx)
-                                                       ...)])
-                           #'(begin (define-syntax id
-                                      (make-rename-transformer #'from))
-                                    ...))]))))])))))
-
-(provide* ctype-sizeof ctype-alignof compiler-sizeof
-          (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->layout
-          _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64
-          _fixint _ufixint _fixnum _ufixnum
-          _float _double _double*
-          _bool _pointer _scheme _fpointer function-ptr
-          (unsafe memcpy) (unsafe memmove) (unsafe memset)
-          (unsafe malloc-immobile-cell) (unsafe free-immobile-cell))
-
-(define-syntax define*
-  (syntax-rules ()
-    [(_ (name . args) body ...)
-     (begin (provide name) (define (name . args) body ...))]
-    [(_ name expr)
-     (begin (provide name) (define name expr))]))
-
-;; ----------------------------------------------------------------------------
-;; C integer types
-
-(define* _sint8  _int8)
-(define* _sint16 _int16)
-(define* _sint32 _int32)
-(define* _sint64 _int64)
-
-;; _byte etc is a convenient name for _uint8 & _sint8
-;; (_byte is unsigned)
-(define* _byte  _uint8)
-(define* _ubyte _uint8)
-(define* _sbyte _int8)
-
-;; _word etc is a convenient name for _uint16 & _sint16
-;; (_word is unsigned)
-(define* _word  _uint16)
-(define* _uword _uint16)
-(define* _sword _int16)
-
-;; _short etc is a convenient name for whatever is the compiler's `short'
-;; (_short is signed)
-(provide _short _ushort _sshort)
-(define-values (_short _ushort _sshort)
-  (case (compiler-sizeof 'short)
-    [(2) (values _int16 _uint16 _int16)]
-    [(4) (values _int32 _uint32 _int32)]
-    [else (error 'foreign "internal error: bad compiler size for `short'")]))
-
-;; _int etc is a convenient name for whatever is the compiler's `int'
-;; (_int is signed)
-(provide _int _uint _sint)
-(define-values (_int _uint _sint)
-  (case (compiler-sizeof 'int)
-    [(2) (values _int16 _uint16 _int16)]
-    [(4) (values _int32 _uint32 _int32)]
-    [(8) (values _int64 _uint64 _int64)]
-    [else (error 'foreign "internal error: bad compiler size for `int'")]))
-
-;; _long etc is a convenient name for whatever is the compiler's `long'
-;; (_long is signed)
-(provide _long _ulong _slong)
-(define-values (_long _ulong _slong)
-  (case (compiler-sizeof 'long)
-    [(4) (values _int32 _uint32 _int32)]
-    [(8) (values _int64 _uint64 _int64)]
-    [else (error 'foreign "internal error: bad compiler size for `long'")]))
-
-;; _llong etc is a convenient name for whatever is the compiler's `long long'
-;; (_llong is signed)
-(provide _llong _ullong _sllong)
-(define-values (_llong _ullong _sllong)
-  (case (compiler-sizeof '(long long))
-    [(4) (values _int32 _uint32 _int32)]
-    [(8) (values _int64 _uint64 _int64)]
-    [else (error 'foreign "internal error: bad compiler size for `llong'")]))
-
-;; ----------------------------------------------------------------------------
-;; Getting and setting library objects
-
-(define lib-suffix (bytes->string/latin-1 (subbytes (system-type 'so-suffix) 1)))
-(define lib-suffix-re (regexp (string-append "\\." lib-suffix "$")))
-(define suffix-before-version? (not (equal? lib-suffix "dylib")))
-
-(provide* (unsafe (rename-out [get-ffi-lib ffi-lib]))
-          ffi-lib? ffi-lib-name)
-(define get-ffi-lib
-  (case-lambda
-   [(name) (get-ffi-lib name "")]
-   [(name version/s)
-    (cond
-      [(not name) (ffi-lib name)] ; #f => NULL => open this executable
-      [(not (or (string? name) (path? name)))
-       (raise-type-error 'ffi-lib "library-name" name)]
-      [else
-       ;; A possible way that this might be misleading: say that there is a
-       ;; "foo.so" file in the current directory, which refers to some
-       ;; undefined symbol, trying to use this function with "foo.so" will try
-       ;; a dlopen with "foo.so" which isn't found, then it tries a dlopen with
-       ;; "/<curpath>/foo.so" which fails because of the undefined symbol, and
-       ;; since all fails, it will use (ffi-lib "foo.so") to raise the original
-       ;; file-not-found error.  This is because the dlopen doesn't provide a
-       ;; way to distinguish different errors (only dlerror, but that's
-       ;; unreliable).
-       (let* ([versions (if (list? version/s) version/s (list version/s))]
-              [versions (map (lambda (v)
-                               (if (or (not v) (zero? (string-length v)))
-                                 "" (string-append "." v)))
-                             versions)]
-              [fullpath (lambda (p) (path->complete-path (cleanse-path p)))]
-              [absolute? (absolute-path? name)]
-              [name0 (path->string (cleanse-path name))]     ; orig name
-              [names (map (if (regexp-match lib-suffix-re name0) ; name+suffix
-                            (lambda (v) (string-append name0 v))
-                            (lambda (v) 
-                              (if suffix-before-version?
-                                  (string-append name0 "." lib-suffix v)
-                                  (string-append name0 v "." lib-suffix))))
-                          versions)]
-              [ffi-lib*  (lambda (name) (ffi-lib name #t))])
-         (or ;; try to look in our library paths first
-             (and (not absolute?)
-                  (ormap (lambda (dir)
-                           ;; try good names first, then original
-                           (or (ormap (lambda (name)
-                                        (ffi-lib* (build-path dir name)))
-                                      names)
-                               (ffi-lib* (build-path dir name0))))
-                         (get-lib-search-dirs)))
-             ;; try a system search
-             (ormap ffi-lib* names)    ; try good names first
-             (ffi-lib* name0)          ; try original
-             (ormap (lambda (name)     ; try relative paths
-                      (and (file-exists? name) (ffi-lib* (fullpath name))))
-                    names)
-             (and (file-exists? name0) ; relative with original
-                  (ffi-lib* (fullpath name0)))
-             ;; give up: call ffi-lib so it will raise an error
-             (ffi-lib (car names))))])]))
-
-(define (get-ffi-lib-internal x)
-  (if (ffi-lib? x) x (get-ffi-lib x)))
-
-;; These internal functions provide the functionality to be used by
-;; get-ffi-obj, set-ffi-obj! and define-c below
-(define (ffi-get ffi-obj type)
-  (ptr-ref ffi-obj type))
-(define (ffi-set! ffi-obj type new)
-  (let-values ([(new type) (get-lowlevel-object new type)])
-    (hash-set! ffi-objects-ref-table ffi-obj new)
-    (ptr-set! ffi-obj type new)))
-
-;; This is better handled with `make-c-parameter'
-(provide* (unsafe ffi-obj-ref))
-(define ffi-obj-ref
-  (case-lambda
-   [(name lib) (ffi-obj-ref name lib #f)]
-   [(name lib failure)
-    (let ([name (get-ffi-obj-name 'ffi-obj-ref name)]
-          [lib  (get-ffi-lib-internal lib)])
-      (with-handlers ([exn:fail:filesystem?
-                       (lambda (e) (if failure (failure) (raise e)))])
-        (ffi-obj name lib)))]))
-
-;; get-ffi-obj is implemented as a syntax only to be able to propagate the
-;; foreign name into the type syntax, which allows generated wrappers to have a
-;; proper name.
-(provide* (unsafe get-ffi-obj))
-(define get-ffi-obj*
-  (case-lambda
-   [(name lib type) (get-ffi-obj* name lib type #f)]
-   [(name lib type failure)
-    (let ([name (get-ffi-obj-name 'get-ffi-obj name)]
-          [lib  (get-ffi-lib-internal lib)])
-      (let-values ([(obj error?)
-                    (with-handlers
-                        ([exn:fail:filesystem?
-                          (lambda (e)
-                            (if failure (values (failure) #t) (raise e)))])
-                      (values (ffi-obj name lib) #f))])
-        (if error? obj (ffi-get obj type))))]))
-(define-syntax (get-ffi-obj stx)
-  (syntax-case stx ()
-    [(_ name lib type)
-     #`(get-ffi-obj* name lib #,(syntax-property #`type 'ffi-name #'name))]
-    [(_ name lib type failure)
-     #`(get-ffi-obj* name lib #,(syntax-property #`type 'ffi-name #'name)
-                     failure)]
-    [x (identifier? #'x) #'get-ffi-obj*]))
-
-;; It is important to use the set-ffi-obj! wrapper because it takes care of
-;; keeping a handle on the object -- otherwise, setting a callback hook will
-;; crash when the Scheme function is gone.
-(provide* (unsafe set-ffi-obj!))
-(define (set-ffi-obj! name lib type new)
-  (ffi-set! (ffi-obj (get-ffi-obj-name 'set-ffi-obj! name)
-                     (get-ffi-lib-internal lib))
-            type new))
-
-;; Combining the above two in a `define-c' special form which makes a Scheme
-;; `binding', first a `parameter'-like constructor:
-(provide* (unsafe make-c-parameter))
-(define (make-c-parameter name lib type)
-  (let ([obj (ffi-obj (get-ffi-obj-name 'make-c-parameter name)
-                      (get-ffi-lib-internal lib))])
-    (case-lambda [()    (ffi-get  obj type)]
-                 [(new) (ffi-set! obj type new)])))
-;; Then the fake binding syntax, uses the defined identifier to name the
-;; object:
-(provide* (unsafe define-c))
-(define-syntax (define-c stx)
-  (syntax-case stx ()
-    [(_ var-name lib-name type-expr)
-     (with-syntax ([(p) (generate-temporaries (list #'var-name))])
-       (namespace-syntax-introduce
-        #'(begin (define p (make-c-parameter 'var-name lib-name type-expr))
-                 (define-syntax var-name
-                   (syntax-id-rules (set!)
-                     [(set! var val) (p val)]
-                     [(var . xs) ((p) . xs)]
-                     [var (p)])))))]))
-
-;; Used to convert strings and symbols to a byte-string that names an object
-(define (get-ffi-obj-name who objname)
-  (cond [(bytes? objname) objname]
-        [(symbol? objname) (get-ffi-obj-name who (symbol->string objname))]
-        [(string? objname) (string->bytes/utf-8 objname)]
-        [else (raise-type-error who "object-name" objname)]))
-
-;; This table keeps references to values that are set in foreign libraries, to
-;; avoid them being GCed.  See set-ffi-obj! above.
-(define ffi-objects-ref-table (make-hasheq))
-
-;; ----------------------------------------------------------------------------
-;; Compile-time support for fun-expanders
-
-(begin-for-syntax
-
-  ;; The `_fun' macro tears its input apart and reassemble it using pieces from
-  ;; custom function types (macros).  This whole deal needs some work to make
-  ;; it play nicely with code certificates, so Matthew wrote the following
-  ;; code.  The idea is to create a define-fun-syntax which makes the new
-  ;; syntax transformer be an object that carries extra information, later used
-  ;; by `expand-fun-syntax/fun'.
-
-  (define fun-cert-key (gensym))
-
-  ;; bug in begin-for-syntax (PR7104), see below
-  (define foo!!! (make-parameter #f))
-  (define (expand-fun-syntax/normal fun-stx stx)
-    ((foo!!!) fun-stx stx))
-
-  (define-values (make-fun-syntax fun-syntax?
-                  fun-syntax-proc fun-syntax-certifier fun-syntax-name)
-    (let-values ([(desc make pred? get set!)
-                  (make-struct-type
-                   'fun-syntax #f 3 0 #f '() (current-inspector)
-                   expand-fun-syntax/normal)])
-      (values make pred?
-              (make-struct-field-accessor get 0 'proc)
-              (make-struct-field-accessor get 1 'certifier)
-              (make-struct-field-accessor get 2 'name))))
-
-  ;; This is used to expand a fun-syntax in a _fun type context.
-  (define (expand-fun-syntax/fun stx)
-    (let loop ([stx stx])
-      (define (do-expand id id?) ; id? == are we expanding an identifier?
-        (define v           (syntax-local-value id (lambda () #f)))
-        (define set!-trans? (set!-transformer? v))
-        (define proc        (if set!-trans? (set!-transformer-procedure v) v))
-        (if (and (fun-syntax? proc) (or (not id?) set!-trans?))
-          ;; Do essentially the same thing that `local-expand' does.
-          ;;  First, create an "introducer" to mark introduced identifiers:
-          (let* ([introduce (make-syntax-introducer)]
-                 [expanded
-                  ;; Re-introduce mark related to expansion of `_fun':
-                  (syntax-local-introduce
-                   ;; Re-add mark specific to this expansion, cancelling
-                   ;;  some marks applied before expanding (leaving only
-                   ;;  introuced syntax marked)
-                   (introduce
-                    ;; Actually expand:
-                    ((fun-syntax-proc proc)
-                     ;; Add mark specific to this expansion:
-                     (introduce
-                      ;; Remove mark related to expansion of `_fun':
-                      (syntax-local-introduce stx)))))])
-            ;; Certify based on definition of expander, then loop
-            ;;  to continue expanding:
-            (loop ((fun-syntax-certifier proc)
-                   expanded fun-cert-key introduce)))
-          stx))
-      (syntax-case stx ()
-        [(id . rest) (identifier? #'id) (do-expand #'id #f)]
-        [id          (identifier? #'id) (do-expand #'id #t)]
-        [_else stx])))
-
-  ;; Use module-or-top-identifier=? because we use keywords like `=' and want
-  ;; to make it possible to play with it at the toplevel.
-  (define id=? module-or-top-identifier=?)
-
-  (define (split-by key args)
-    (let loop ([args args] [r (list '())])
-      (cond [(null? args) (reverse (map reverse r))]
-            [(eq? key (car args)) (loop (cdr args) (cons '() r))]
-            [else (loop (cdr args)
-                        (cons (cons (car args) (car r)) (cdr r)))])))
-
-  (define (add-renamer body from to)
-    (with-syntax ([body body] [from from] [to to])
-      #'(let-syntax ([to (syntax-id-rules ()
-                           [(_?_ . _rest_) (from . _rest_)] [_?_ from])])
-          body)))
-
-  (define (custom-type->keys type err)
-    (define stops (map (lambda (s) (datum->syntax type s #f))
-                       '(#%app #%top #%datum)))
-    ;; Expand `type' using expand-fun-syntax/fun
-    (define orig (expand-fun-syntax/fun type))
-    (define (with-arg x)
-      (syntax-case* x (=>) id=?
-        [(id => body) (identifier? #'id)
-         ;; Extract #'body from its context, use a key it needs certification:
-         (list (syntax-recertify #'id orig #f fun-cert-key)
-	       (syntax-recertify #'body orig #f fun-cert-key))]
-        [_else x]))
-    (define (cert-id id)
-      (syntax-recertify id orig #f fun-cert-key))
-   (let ([keys '()])
-     (define (setkey! key val . id?)
-       (cond
-         [(assq key keys)
-          (err "bad expansion of custom type (two `~a:'s)" key type)]
-         [(and (pair? id?) (car id?) (not (identifier? val)))
-          (err "bad expansion of custom type (`~a:' expects an identifier)"
-               key type)]
-         [else (set! keys (cons (cons key val) keys))]))
-     (let loop ([t orig])
-       (define (next rest . args) (apply setkey! args) (loop rest))
-       (syntax-case* t (type: expr: bind: 1st-arg: prev-arg: pre: post:) id=?
-         [(type: t x ...)      (next #'(x ...) 'type #'t)]
-         [(expr:     e  x ...) (next #'(x ...) 'expr #'e)]
-         [(bind:     id x ...) (next #'(x ...) 'bind (cert-id #'id) #t)]
-         [(1st-arg:  id x ...) (next #'(x ...) '1st  (cert-id #'id) #t)]
-         [(prev-arg: id x ...) (next #'(x ...) 'prev (cert-id #'id) #t)]
-         ;; in the following two cases pass along orig for recertifying
-         [(pre:      p  x ...) (next #'(x ...) 'pre  (with-arg #'p))]
-         [(post:     p  x ...) (next #'(x ...) 'post (with-arg #'p))]
-         [() (and (pair? keys) keys)]
-         [_else #f]))))
-
-  ;; This is used for a normal expansion of fun-syntax, when not in a _fun type
-  ;; context.
-  ;; bug in begin-for-syntax (PR7104), see above
-  ;;   should be (define (expand-fun-syntax/normal fun-stx stx) ...)
-  (foo!!! (lambda (fun-stx stx)
-    (define (err msg . sub)
-      (apply raise-syntax-error (fun-syntax-name fun-stx) msg stx sub))
-    (let ([keys (custom-type->keys stx err)])
-      (define (getkey key) (cond [(assq key keys) => cdr] [else #f]))
-      (define (notkey key)
-        (when (getkey key)
-          (err (format "this type must be used in a _fun expression (uses ~s)"
-                       key))))
-      (if keys
-        (let ([type (getkey 'type)] [pre (getkey 'pre)] [post (getkey 'post)])
-          (unless type
-            (err "this type must be used in a _fun expression (#f type)"))
-          (for-each notkey '(expr bind 1st prev))
-          (if (or pre post)
-            ;; a type with pre/post blocks
-            (let ([make-> (lambda (x what)
-                            (cond [(not x) #'#f]
-                                  [(and (list? x) (= 2 (length x))
-                                        (identifier? (car x)))
-                                   #`(lambda (#,(car x)) #,(cadr x))]
-                                  [else #`(lambda (_)
-                                            (error '#,(fun-syntax-name fun-stx)
-                                                   "cannot be used to ~a"
-                                                   #,what))]))])
-              (with-syntax ([type type]
-                            [scheme->c (make-> pre "send values to C")]
-                            [c->scheme (make-> post "get values from C")])
-                #'(make-ctype type scheme->c c->scheme)))
-            ;; simple type
-            type))
-        ;; no keys => normal expansion
-        ((fun-syntax-proc fun-stx) stx))))))
-
-;; Use define-fun-syntax instead of define-syntax for forms that
-;;  are to be expanded by `_fun':
-(provide define-fun-syntax)
-(define-syntax define-fun-syntax
-  (syntax-rules ()
-    [(_ id trans)
-     (define-syntax id
-       (let* ([xformer trans]
-              [set!-trans? (set!-transformer? xformer)])
-         (unless (or (and (procedure? xformer)
-                          (procedure-arity-includes? xformer 1))
-                     set!-trans?)
-           (raise-type-error 'define-fun-syntax
-                             "procedure (arity 1) or set!-transformer"
-                             xformer))
-         (let ([f (make-fun-syntax (if set!-trans?
-                                     (set!-transformer-procedure xformer)
-                                     xformer)
-                                   ;; Capture definition-time certificates:
-                                   (syntax-local-certifier)
-                                   'id)])
-           (if set!-trans? (make-set!-transformer f) f))))]))
-
-;; ----------------------------------------------------------------------------
-;; Function type
-
-;; Creates a simple function type that can be used for callouts and callbacks,
-;; optionally applying a wrapper function to modify the result primitive
-;; (callouts) or the input procedure (callbacks).
-(define* (_cprocedure itypes otype
-                      #:abi [abi #f] 
-                      #:wrapper [wrapper #f] 
-                      #:keep [keep #f]
-                      #:atomic? [atomic? #f])
-  (_cprocedure* itypes otype abi wrapper keep atomic?))
-
-;; for internal use
-(define held-callbacks (make-weak-hasheq))
-(define (_cprocedure* itypes otype abi wrapper keep atomic?)
-  (define-syntax-rule (make-it wrap)
-    (make-ctype _fpointer
-      (lambda (x)
-        (and x
-             (let ([cb (ffi-callback (wrap x) itypes otype abi atomic?)])
-               (cond [(eq? keep #t) (hash-set! held-callbacks x cb)]
-                     [(box? keep)
-                      (let ([x (unbox keep)])
-                        (set-box! keep
-                                  (if (or (null? x) (pair? x)) (cons cb x) cb)))]
-                     [(procedure? keep) (keep cb)])
-               cb)))
-      (lambda (x) (and x (wrap (ffi-call x itypes otype abi))))))
-  (if wrapper (make-it wrapper) (make-it begin)))
-
-;; Syntax for the special _fun type:
-;; (_fun [{(name ... [. name]) | name} [-> expr] ::]
-;;       {type | (name : type [= expr]) | ([name :] type = expr)} ...
-;;       -> {type | (name : type)}
-;;       [-> expr])
-;; Usage:
-;; `{(name ...) | ...} ::' specify explicit wrapper function formal arguments
-;;           `-> expr'     can be used instead of the last expr
-;; `type'                  input type (implies input, but see type macros next)
-;; `(name : type = expr)'  specify name and type, `= expr' means computed input
-;; `-> type'               output type (possibly with name)
-;; `-> expr'               specify different output, can use previous names
-;; Also, see below for custom function types.
-
-(provide ->) ; to signal better errors when trying to use this with contracts
-(define-syntax ->
-  (syntax-id-rules ()
-    [_ (raise-syntax-error '-> "should be used only in a _fun context")]))
-
-(provide _fun)
-(define-syntax (_fun stx)
-  (define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub))
-  (define xs     #f)
-  (define abi    #f)
-  (define keep   #f)
-  (define atomic? #f)
-  (define inputs #f)
-  (define output #f)
-  (define bind   '())
-  (define pre    '())
-  (define post   '())
-  (define input-names #f)
-  (define output-type #f)
-  (define output-expr #f)
-  (define 1st-arg     #f)
-  (define prev-arg    #f)
-  (define (bind! x) (set! bind (append bind (list x))))
-  (define (pre!  x) (set! pre  (append pre  (list x))))
-  (define (post! x) (set! post (append post (list x))))
-  (define ((t-n-e clause) type name expr)
-    (let ([keys (custom-type->keys type err)])
-      (define (getkey key) (cond [(assq key keys) => cdr] [else #f]))
-      (define (arg x . no-expr?)
-        (define use-expr?
-          (and (list? x) (= 2 (length x)) (identifier? (car x))))
-        ;; when the current expr is not used with a (x => ...) form,
-        ;; either check that no expression is given or just make it
-        ;; disappear from the inputs.
-        (unless use-expr?
-          (if (and (pair? no-expr?) (car no-expr?) expr)
-            (err "got an expression for a custom type that do not use it"
-                 clause)
-            (set! expr (void))))
-        (set! x (if use-expr? (add-renamer (cadr x) name (car x)) x))
-        (cond [(getkey '1st) =>
-               (lambda (v)
-                 (if 1st-arg
-                   (set! x (add-renamer x 1st-arg v))
-                   (err "got a custom type that wants 1st arg too early"
-                        clause)))])
-        (cond [(getkey 'prev) =>
-               (lambda (v)
-                 (if prev-arg
-                   (set! x (add-renamer x prev-arg v))
-                   (err "got a custom type that wants prev arg too early"
-                        clause)))])
-        x)
-      (when keys
-        (set! type (getkey 'type))
-        (cond [(and (not expr) (getkey 'expr)) => (lambda (x) (set! expr x))])
-        (cond [(getkey 'bind) => (lambda (x) (bind! #`[#,x #,name]))])
-        (cond [(getkey 'pre) => (lambda (x) (pre!  #`[#,name #,(arg x #t)]))])
-        (cond [(getkey 'post) => (lambda (x) (post! #`[#,name #,(arg x)]))]))
-      ;; turn a #f syntax to #f
-      (set! type (and type (syntax-case type () [#f #f] [_ type])))
-      (when type ; remember these for later usages
-        (unless 1st-arg (set! 1st-arg name))
-        (set! prev-arg name))
-      (list type name expr)))
-  (define (do-fun)
-    ;; parse keywords
-    (let loop ()
-      (let ([k (and (pair? xs) (pair? (cdr xs)) (syntax-e (car xs)))])
-        (define-syntax-rule (kwds [key var] ...)
-          (case k
-            [(key) (if var
-                     (err (format "got a second ~s keyword") 'key (car xs))
-                     (begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))]
-            ...
-            [else (err "unknown keyword" (car xs))]))
-        (when (keyword? k) (kwds [#:abi abi] [#:keep keep] [#:atomic? atomic?]))))
-    (unless abi  (set! abi  #'#f))
-    (unless keep (set! keep #'#t))
-    (unless atomic? (set! atomic? #'#f))
-    ;; parse known punctuation
-    (set! xs (map (lambda (x)
-                    (syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_  x]))
-                  xs))
-    ;; parse "::"
-    (let ([s (split-by ':: xs)])
-      (case (length s)
-        [(0) (err "something bad happened (::)")]
-        [(1) (void)]
-        [(2) (if (and (= 1 (length (car s))) (not (eq? '-> (caar s))))
-               (begin (set! xs (cadr s)) (set! input-names (caar s)))
-               (err "bad wrapper formals"))]
-        [else (err "saw two or more instances of `::'")]))
-    ;; parse "->"
-    (let ([s (split-by '-> xs)])
-      (case (length s)
-        [(0) (err "something bad happened (->)")]
-        [(1) (err "missing output type")]
-        [(2 3) (set! inputs (car s))
-               (case (length (cadr s))
-                 [(1) (set! output-type (caadr s))]
-                 [(0) (err "missing output type after `->'")]
-                 [else (err "extraneous output type" (cadadr s))])
-               (unless (null? (cddr s))
-                 (case (length (caddr s))
-                   [(1) (set! output-expr (caaddr s))]
-                   [(0) (err "missing output expression after `->'")]
-                   [else (err "extraneous output expression"
-                              (cadr (caddr s)))]))]
-        [else (err "saw three or more instances of `->'")]))
-    (set! inputs
-          (map (lambda (sub temp)
-                 (let ([t-n-e (t-n-e sub)])
-                   (syntax-case* sub (: =) id=?
-                     [(name : type)        (t-n-e #'type #'name #f)]
-                     [(type = expr)        (t-n-e #'type temp   #'expr)]
-                     [(name : type = expr) (t-n-e #'type #'name #'expr)]
-                     [type                 (t-n-e #'type temp   #f)])))
-               inputs
-               (generate-temporaries (map (lambda (x) 'tmp) inputs))))
-    ;; when processing the output type, only the post code matters
-    (set! pre! (lambda (x) #f))
-    (set! output
-          (let ([temp (car (generate-temporaries #'(ret)))]
-                [t-n-e (t-n-e output-type)])
-            (syntax-case* output-type (: =) id=?
-              [(name : type) (t-n-e #'type #'name output-expr)]
-              [(type = expr) (if output-expr
-                               (err "extraneous output expression" #'expr)
-                               (t-n-e #'type temp #'expr))]
-              [(name : type = expr)
-                             (if output-expr
-                               (err "extraneous output expression" #'expr)
-                               (t-n-e #'type #'name #'expr))]
-              [type          (t-n-e #'type temp output-expr)])))
-    (if (or (caddr output) input-names (ormap caddr inputs)
-            (ormap (lambda (x) (not (car x))) inputs)
-            (pair? bind) (pair? pre) (pair? post))
-      (let* ([input-names (or input-names
-                              (filter-map (lambda (i)
-                                            (and (not (caddr i)) (cadr i)))
-                                          inputs))]
-             [output-expr (let ([o (caddr output)])
-                            (or (and (not (void? o)) o)
-                                (cadr output)))]
-             [args (filter-map (lambda (i)
-                                 (and (caddr i)
-                                      (not (void? (caddr i)))
-                                      #`[#,(cadr i) #,(caddr i)]))
-                               inputs)]
-             [ffi-args (filter-map (lambda (x) (and (car x) (cadr x))) inputs)]
-             ;; the actual wrapper body
-             [body (quasisyntax/loc stx
-                     (lambda #,input-names
-                       (let* (#,@args
-                              #,@bind
-                              #,@pre
-                              [#,(cadr output) (ffi #,@ffi-args)]
-                              #,@post)
-                         #,output-expr)))]
-             ;; if there is a string 'ffi-name property, use it as a name
-             [body (let ([n (cond [(syntax-property stx 'ffi-name)
-                                   => syntax->datum]
-                                  [else #f])])
-                     (if (string? n)
-                       (syntax-property
-                        body 'inferred-name
-                        (string->symbol (string-append "ffi-wrapper:" n)))
-                       body))])
-        #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
-                        #,abi (lambda (ffi) #,body) #,keep #,atomic?))
-      #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
-                      #,abi #f #,keep #,atomic?)))
-  (syntax-case stx ()
-    [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))]))
-
-(define (function-ptr p fun-ctype)
-  (if (or (cpointer? p) (procedure? p))
-      (if (eq? (ctype->layout fun-ctype) 'fpointer)
-           (if (procedure? p)
-               ((ctype-scheme->c fun-ctype) p)
-               ((ctype-c->scheme fun-ctype) p))
-          (raise-type-error 'function-ptr "function ctype" fun-ctype))
-      (raise-type-error 'function-ptr "cpointer" p)))
-
-;; ----------------------------------------------------------------------------
-;; String types
-
-;; The internal _string type uses the native ucs-4 encoding, also providing a
-;; utf-16 type
-(provide _string/ucs-4 _string/utf-16)
-
-;; 8-bit string encodings, #f is NULL
-(define ((false-or-op op) x) (and x (op x)))
-(define* _string/utf-8
-  (make-ctype _bytes
-    (false-or-op string->bytes/utf-8) (false-or-op bytes->string/utf-8)))
-(define* _string/locale
-  (make-ctype _bytes
-    (false-or-op string->bytes/locale) (false-or-op bytes->string/locale)))
-(define* _string/latin-1
-  (make-ctype _bytes
-    (false-or-op string->bytes/latin-1) (false-or-op bytes->string/latin-1)))
-
-;; 8-bit string encodings, #f is NULL, can also use bytes and paths
-(define ((any-string-op op) x)
-  (cond [(not    x) x]
-        [(bytes? x) x]
-        [(path?  x) (path->bytes x)]
-        [else (op x)]))
-(define* _string*/utf-8
-  (make-ctype _bytes
-    (any-string-op string->bytes/utf-8) (false-or-op bytes->string/utf-8)))
-(define* _string*/locale
-  (make-ctype _bytes
-    (any-string-op string->bytes/locale) (false-or-op bytes->string/locale)))
-(define* _string*/latin-1
-  (make-ctype _bytes
-    (any-string-op string->bytes/latin-1) (false-or-op bytes->string/latin-1)))
-
-;; A generic _string type that usually does the right thing via a parameter
-(define* default-_string-type
-  (make-parameter _string*/utf-8
-    (lambda (x)
-      (if (ctype? x)
-        x (error 'default-_string-type "expecting a C type, got ~e" x)))))
-;; The type looks like an identifier, but it's actually using the parameter
-(provide _string)
-(define-syntax _string
-  (syntax-id-rules ()
-    [(_ . xs) ((default-_string-type) . xs)]
-    [_ (default-_string-type)]))
-
-;; _symbol is defined in C, since it uses simple C strings
-(provide _symbol)
-
-(provide _path)
-;; `file' type: path-expands a path string, provide _path too.
-(define* _file (make-ctype _path cleanse-path #f))
-
-;; `string/eof' type: converts an output #f (NULL) to an eof-object.
-(define string-type->string/eof-type
-  (let ([table (make-hasheq)])
-    (lambda (string-type)
-      (hash-ref table string-type
-        (lambda ()
-          (let ([new-type (make-ctype string-type
-                            (lambda (x) (and (not (eof-object? x)) x))
-                            (lambda (x) (or x eof)))])
-            (hash-set! table string-type new-type)
-            new-type))))))
-(provide _string/eof _bytes/eof)
-(define _bytes/eof
-  (make-ctype _bytes
-              (lambda (x) (and (not (eof-object? x)) x))
-              (lambda (x) (or x eof))))
-(define-syntax _string/eof ; make it a syntax so it depends on the _string type
-  (syntax-id-rules ()
-    [(_ . xs) ((string-type->string/eof-type _string) . xs)]
-    [_ (string-type->string/eof-type _string)]))
-
-;; ----------------------------------------------------------------------------
-;; Utility types
-
-;; Call this with a name (symbol) and a list of symbols, where a symbol can be
-;; followed by a '= and an integer to have a similar effect of C's enum.
-(define (_enum* name symbols . base?)
-  (define basetype (if (pair? base?) (car base?) _ufixint))
-  (define sym->int '())
-  (define int->sym '())
-  (define s->c
-    (if name (string->symbol (format "enum:~a->int" name)) 'enum->int))
-  (let loop ([i 0] [symbols symbols])
-    (unless (null? symbols)
-      (let-values ([(i rest)
-                    (if (and (pair? (cdr symbols))
-                             (eq? '= (cadr symbols))
-                             (pair? (cddr symbols)))
-                        (values (caddr symbols)
-                                (cdddr symbols))
-                        (values i
-                                (cdr symbols)))])
-        (set! sym->int (cons (cons (car symbols) i) sym->int))
-        (set! int->sym (cons (cons i (car symbols)) int->sym))
-        (loop (add1 i) rest))))
-  (make-ctype basetype
-    (lambda (x)
-      (let ([a (assq x sym->int)])
-        (if a
-          (cdr a)
-          (raise-type-error s->c (format "~a" (or name "enum")) x))))
-    (lambda (x) (cond [(assq x int->sym) => cdr] [else #f]))))
-
-;; Macro wrapper -- no need for a name
-(provide _enum)
-(define-syntax (_enum stx)
-  (syntax-case stx ()
-    [(_ syms)
-     (with-syntax ([name (syntax-local-name)])
-       #'(_enum* 'name syms))]
-    [(_ syms basetype)
-     (with-syntax ([name (syntax-local-name)])
-       #'(_enum* 'name syms basetype))]
-    [id (identifier? #'id)
-     #'(lambda (syms . base?) (apply _enum* #f syms base?))]))
-
-;; Call this with a name (symbol) and a list of (symbol int) or symbols like
-;; the above with '= -- but the numbers have to be specified in some way.  The
-;; generated type will convert a list of these symbols into the logical-or of
-;; their values and back.
-(define (_bitmask* name orig-symbols->integers . base?)
-  (define basetype (if (pair? base?) (car base?) _uint))
-  (define s->c
-    (if name (string->symbol (format "bitmask:~a->int" name)) 'bitmask->int))
-  (define symbols->integers
-    (let loop ([s->i orig-symbols->integers])
-      (cond
-       [(null? s->i)
-        null]
-       [(and (pair? (cdr s->i)) (eq? '= (cadr s->i)) (pair? (cddr s->i)))
-        (cons (list (car s->i) (caddr s->i))
-              (loop (cdddr s->i)))]
-       [(and (pair? (car s->i)) (pair? (cdar s->i)) (null? (cddar s->i))
-             (symbol? (caar s->i)) (integer? (cadar s->i)))
-        (cons (car s->i) (loop (cdr s->i)))]
-       [else
-        (error '_bitmask "bad spec in ~e" orig-symbols->integers)])))
-  (make-ctype basetype
-    (lambda (symbols)
-      (if (null? symbols) ; probably common
-        0
-        (let loop ([xs (if (pair? symbols) symbols (list symbols))] [n 0])
-          (cond [(null? xs) n]
-                [(assq (car xs) symbols->integers) =>
-                 (lambda (x) (loop (cdr xs) (bitwise-ior (cadr x) n)))]
-                [else (raise-type-error s->c (format "~a" (or name "bitmask"))
-                                        symbols)]))))
-    (lambda (n)
-      (if (zero? n) ; probably common
-        '()
-        (let loop ([s->i symbols->integers] [l '()])
-          (if (null? s->i)
-            (reverse l)
-            (loop (cdr s->i)
-                  (let ([i (cadar s->i)])
-                    (if (and (not (= i 0)) (= i (bitwise-and i n)))
-                      (cons (caar s->i) l)
-                      l)))))))))
-
-;; Macro wrapper -- no need for a name
-(provide _bitmask)
-(define-syntax (_bitmask stx)
-  (syntax-case stx ()
-    [(_ syms)
-     (with-syntax ([name (syntax-local-name)])
-       #'(_bitmask* 'name syms))]
-    [(_ syms basetype)
-     (with-syntax ([name (syntax-local-name)])
-       #'(_bitmask* 'name syms basetype))]
-    [id (identifier? #'id)
-     #'(lambda (syms . base?) (apply _bitmask* #f syms base?))]))
-
-;; ----------------------------------------------------------------------------
-;; Custom function type macros
-
-;; These macros get expanded by the _fun type.  They can expand to a form that
-;; looks like (keyword: value ...), where the keyword is one of:
-;; * `type:'     for the type that will be used,
-;; * `expr:'     an expression that will always be used for these arguments, as
-;;               if `= expr' is always given, when an expression is actually
-;;               given in an argument specification, it supersedes this.
-;; * `bind:'     for an additional binding that holds the initial value,
-;; * `1st-arg:'  is used to name an identifier that will be bound to the value
-;;               of the 1st foreign argument in pre/post chunks (good for
-;;               common cases where the first argument has a special meaning,
-;;               eg, for method calls),
-;; * `prev-arg:' similar to 1st-arg: but for the previous argument,
-;; * `pre:'      for a binding that will be inserted before the ffi call,
-;; * `post:'     for a binding after the ffi call.
-;; The pre: and post: bindings can be of the form (id => expr) to use the
-;; existing value.  Note that if the pre: expression is not (id => expr), then
-;; it means that there is no input for this argument.  Also note that if a
-;; custom type is used as an output type of a function, then only the post:
-;; code is used -- for example, this is useful for foreign functions that
-;; allocate a memory block and return it to the user.  The resulting wrapper
-;; looks like:
-;;   (let* (...bindings for arguments...
-;;          ...bindings for bind: identifiers...
-;;          ...bindings for pre-code...
-;;          (ret-name ffi-call)
-;;          ...bindings for post-code...)
-;;     return-expression)
-;;
-;; Finally, the code in a custom-function macro needs special treatment when it
-;; comes to dealing with code certificates, so instead of using
-;; `define-syntax', you should use `define-fun-syntax' (used in the same way).
-
-;; _?
-;; This is not a normal ffi type -- it is a marker for expressions that should
-;; not be sent to the ffi function.  Use this to bind local values in a
-;; computation that is part of an ffi wrapper interface.
-(provide _?)
-(define-fun-syntax _?
-  (syntax-id-rules () [(_ . xs) ((type: #f) . xs)] [_ (type: #f)]))
-
-;; (_ptr <mode> <type>)
-;; This is for pointers, where mode indicates input or output pointers (or
-;; both).  If the mode is `o' (output), then the wrapper will not get an
-;; argument for it, instead it generates the matching argument.
-(provide _ptr)
-(define-fun-syntax _ptr
-  (syntax-rules (i o io)
-    [(_ i  t) (type: _pointer
-               pre:  (x => (let ([p (malloc t)]) (ptr-set! p t x) p)))]
-    [(_ o  t) (type: _pointer
-               pre:  (malloc t)
-               post: (x => (ptr-ref x t)))]
-    [(_ io t) (type: _pointer
-               pre:  (x => (let ([p (malloc t)]) (ptr-set! p t x) p))
-               post: (x => (ptr-ref x t)))]))
-
-;; (_box <type>)
-;; This is similar to a (_ptr io <type>) argument, where the input is expected
-;; to be a box, which is unboxed on entry and modified on exit.
-(provide _box)
-(define-fun-syntax _box
-  (syntax-rules ()
-    [(_ t) (type: _pointer
-            bind: tmp ; need to save the box so we can get back to it
-            pre:  (x => (let ([p (malloc t)]) (ptr-set! p t (unbox x)) p))
-            post: (x => (begin (set-box! tmp (ptr-ref x t)) tmp)))]))
-
-;; (_list <mode> <type> [<len>])
-;; Similar to _ptr, except that it is used for converting lists to/from C
-;; vectors.  The length is needed for output values where it is used in the
-;; post code, and in the pre code of an output mode to allocate the block.  In
-;; any case it can refer to a previous binding for the length of the list which
-;; the C function will most likely require.
-(provide _list)
-(define-fun-syntax _list
-  (syntax-rules (i o io)
-    [(_ i  t  ) (type: _pointer
-                 pre:  (x => (list->cblock x t)))]
-    [(_ o  t n) (type: _pointer
-                 pre:  (malloc n t)
-                 post: (x => (cblock->list x t n)))]
-    [(_ io t n) (type: _pointer
-                 pre:  (x => (list->cblock x t))
-                 post: (x => (cblock->list x t n)))]))
-
-;; (_vector <mode> <type> [<len>])
-;; Same as _list, except that it uses Scheme vectors.
-(provide _vector)
-(define-fun-syntax _vector
-  (syntax-rules (i o io)
-    [(_ i  t  ) (type: _pointer
-                 pre:  (x => (vector->cblock x t)))]
-    [(_ o  t n) (type: _pointer
-                 pre:  (malloc n t)
-                 post: (x => (cblock->vector x t n)))]
-    [(_ io t n) (type: _pointer
-                 pre:  (x => (vector->cblock x t))
-                 post: (x => (cblock->vector x t n)))]))
-
-;; _bytes or (_bytes o n) is for a memory block represented as a Scheme byte
-;; string.  _bytes is just like a byte-string, and (_bytes o n) is for
-;; pre-malloc of the string.  There is no need for other modes: i or io would
-;; be just like _bytes since the string carries its size information (so there
-;; is no real need for the `o', but it's there for consistency with the above
-;; macros).
-(provide (rename-out [_bytes* _bytes]))
-(define-fun-syntax _bytes*
-  (syntax-id-rules (o)
-    [(_ o n) (type: _bytes
-              pre:  (make-sized-byte-string (malloc n) n)
-              ;; post is needed when this is used as a function output type
-              post: (x => (make-sized-byte-string x n)))]
-    [(_ . xs) (_bytes . xs)]
-    [_ _bytes]))
-
-;; ----------------------------------------------------------------------------
-;; Safe raw vectors
-
-(define-struct cvector (ptr type length))
-
-(provide* cvector? cvector-length cvector-type cvector-ptr
-          ;; make-cvector* is a dangerous operation
-          (unsafe (rename-out [make-cvector make-cvector*])))
-
-(define _cvector* ; used only as input types
-  (make-ctype _pointer cvector-ptr
-    (lambda (x)
-      (error '_cvector
-             "cannot automatically convert a C pointer to a cvector"))))
-
-;; (_cvector <mode> [<type> <len>]) | _cevector
-;; Same as _list etc above, except that it uses C vectors.
-(provide _cvector)
-(define-fun-syntax _cvector
-  (syntax-id-rules (i o io)
-    [(_ i     ) _cvector*]
-    [(_ o  t n) (type: _pointer ; needs to be a pointer, not a cvector*
-                 pre:  (malloc n t)
-                 post: (x => (make-cvector x t n)))]
-    [(_ io    ) (type: _cvector*
-                 bind: tmp
-                 pre:  (x => (cvector-ptr x))
-                 post: (x => tmp))]
-    [(_ . xs)   (_cvector* . xs)]
-    [_          _cvector*]))
-
-(provide (rename-out [allocate-cvector make-cvector]))
-(define (allocate-cvector type len)
-  (make-cvector (if (zero? len) #f ; 0 => NULL
-                    (malloc len type))
-                type len))
-
-(provide (rename-out [cvector-args cvector]))
-(define (cvector-args type . args)
-  (list->cvector args type))
-
-(define* (cvector-ref v i)
-  (if (and (exact-nonnegative-integer? i) (< i (cvector-length v)))
-    (ptr-ref (cvector-ptr v) (cvector-type v) i)
-    (error 'cvector-ref "bad index ~e for cvector bounds of 0..~e"
-           i (sub1 (cvector-length v)))))
-
-(define* (cvector-set! v i x)
-  (if (and (exact-nonnegative-integer? i) (< i (cvector-length v)))
-    (ptr-set! (cvector-ptr v) (cvector-type v) i x)
-    (error 'cvector-ref "bad index ~e for cvector bounds of 0..~e"
-           i (sub1 (cvector-length v)))))
-
-(define* (cvector->list v)
-  (cblock->list (cvector-ptr v) (cvector-type v) (cvector-length v)))
-
-(define* (list->cvector l type)
-  (make-cvector (list->cblock l type) type (length l)))
-
-;; ----------------------------------------------------------------------------
-;; SRFI-4 implementation
-
-(define-syntax (srfi-4-define/provide stx)
-  (syntax-case stx ()
-    [(_ TAG type)
-     (identifier? #'TAG)
-     (let ([name (format "~avector" (syntax->datum #'TAG))])
-       (define (id prefix suffix)
-         (let* ([name (if prefix (string-append prefix name) name)]
-                [name (if suffix (string-append name suffix) name)])
-           (datum->syntax #'TAG (string->symbol name) #'TAG)))
-       (with-syntax ([TAG?         (id "" "?")]
-                     [TAG          (id "" "")]
-                     [s:TAG        (id "s:" "")]
-                     [make-TAG     (id "make-" "")]
-                     [TAG-ptr      (id "" "-ptr")]
-                     [TAG-length   (id "" "-length")]
-                     [allocate-TAG (id "allocate-" "")]
-                     [TAG*         (id "" "*")]
-                     [list->TAG    (id "list->" "")]
-                     [TAG->list    (id "" "->list")]
-                     [TAG-ref      (id "" "-ref")]
-                     [TAG-set!     (id "" "-set!")]
-                     [_TAG         (id "_" "")]
-                     [_TAG*        (id "_" "*")]
-                     [TAGname      name])
-         #'(begin
-             (define-struct TAG (ptr length))
-             (provide TAG? TAG-length (rename-out [TAG s:TAG]))
-             (provide (rename-out [allocate-TAG make-TAG]))
-             (define (allocate-TAG n . init)
-               (let* ([p (if (eq? n 0) #f (malloc n type))]
-                      [v (make-TAG p n)])
-                 (when (and p (pair? init))
-                   (let ([init (car init)])
-                     (let loop ([i (sub1 n)])
-                       (unless (< i 0)
-                         (ptr-set! p type i init)
-                         (loop (sub1 i))))))
-                 v))
-             (provide (rename-out [TAG* TAG]))
-             (define (TAG* . vals)
-               (list->TAG vals))
-             (define* (TAG-ref v i)
-               (if (TAG? v)
-                   (if (and (exact-nonnegative-integer? i) (< i (TAG-length v)))
-                       (ptr-ref (TAG-ptr v) type i)
-                       (error 'TAG-ref "bad index ~e for ~a bounds of 0..~e"
-                              i 'TAG (sub1 (TAG-length v))))
-                   (raise-type-error 'TAG-ref TAGname v)))
-             (define* (TAG-set! v i x)
-               (if (TAG? v)
-                   (if (and (exact-nonnegative-integer? i) (< i (TAG-length v)))
-                       (ptr-set! (TAG-ptr v) type i x)
-                       (error 'TAG-set! "bad index ~e for ~a bounds of 0..~e"
-                              i 'TAG (sub1 (TAG-length v))))
-                   (raise-type-error 'TAG-set! TAGname v)))
-             (define* (TAG->list v)
-               (if (TAG? v)
-                   (cblock->list (TAG-ptr v) type (TAG-length v))
-                   (raise-type-error 'TAG->list TAGname v)))
-             (define* (list->TAG l)
-               (make-TAG (list->cblock l type) (length l)))
-             ;; same as the _cvector implementation
-             (provide _TAG)
-             (define _TAG*
-               (make-ctype _pointer TAG-ptr
-                           (lambda (x)
-                             (error
-                              '_TAG
-                              "cannot automatically convert a C pointer to a ~a"
-                              TAGname))))
-             (define-fun-syntax _TAG
-               (syntax-id-rules (i o io)
-                 [(_ i   ) _TAG*]
-                 [(_ o  n) (type: _pointer
-                                  pre:  (malloc n type)
-                                  post: (x => (make-TAG x n)))]
-                 [(_ io  ) (type: _cvector*
-                                  bind: tmp
-                                  pre:  (x => (TAG-ptr x))
-                                  post: (x => tmp))]
-                 [(_ . xs)   (_TAG* . xs)]
-                 [_          _TAG*])))))]
-    [(_ TAG type)
-     (identifier? #'TAG)]))
-
-;; check that the types that were used above have the proper sizes
-(unless (= 4 (ctype-sizeof _float))
-  (error 'foreign "internal error: float has a bad size (~s)"
-         (ctype-sizeof _float)))
-(unless (= 8 (ctype-sizeof _double*))
-  (error 'foreign "internal error: double has a bad size (~s)"
-         (ctype-sizeof _double*)))
-
-(srfi-4-define/provide s8  _int8)
-(srfi-4-define/provide s16 _int16)
-(srfi-4-define/provide u16 _uint16)
-(srfi-4-define/provide s32 _int32)
-(srfi-4-define/provide u32 _uint32)
-(srfi-4-define/provide s64 _int64)
-(srfi-4-define/provide u64 _uint64)
-(srfi-4-define/provide f32 _float)
-(srfi-4-define/provide f64 _double*)
-
-;; simply rename bytes* to implement the u8vector type
-(provide (rename-out [bytes?       u8vector?      ]
-                     [bytes-length u8vector-length]
-                     [make-bytes   make-u8vector  ]
-                     [bytes        u8vector       ]
-                     [bytes-ref    u8vector-ref   ]
-                     [bytes-set!   u8vector-set!  ]
-                     [bytes->list  u8vector->list ]
-                     [list->bytes  list->u8vector ]
-                     [_bytes       _u8vector      ]))
-;; additional `u8vector' bindings for srfi-66
-(provide (rename-out [bytes-copy u8vector-copy] [bytes=? u8vector=?]))
-(define* (u8vector-compare v1 v2)
-  (cond [(bytes<? v1 v2) -1]
-        [(bytes>? v1 v2)  1]
-        [else             0]))
-(define* (u8vector-copy! src src-start dest dest-start n)
-  (bytes-copy! dest dest-start src src-start (+ src-start n)))
-
-;; ----------------------------------------------------------------------------
-;; Tagged pointers
-
-;; Make these operations available for unsafe interfaces (they can be used to
-;; grab a hidden tag value and break code).
-(provide* (unsafe cpointer-tag) (unsafe set-cpointer-tag!)
-          (unsafe cpointer-has-tag?) (unsafe cpointer-push-tag!))
-
-;; Defined as syntax for efficiency, but can be used as procedures too.
-(define-syntax (cpointer-has-tag? stx)
-  (syntax-case stx ()
-    [(_ cptr tag)
-     #'(let ([ptag (cpointer-tag cptr)])
-         (if (pair? ptag) (memq tag ptag) (eq? tag ptag)))]
-    [id (identifier? #'id)
-     #'(lambda (cptr tag) (cpointer-has-tag? cptr tag))]))
-(define-syntax (cpointer-push-tag! stx)
-  (syntax-case stx ()
-    [(_ cptr tag)
-     #'(let ([ptag (cpointer-tag cptr)])
-         (set-cpointer-tag! cptr
-           (cond [(not ptag) tag]
-                 [(pair? ptag) (cons tag ptag)]
-                 [else (list tag ptag)])))]
-    [id (identifier? #'id)
-     #'(lambda (cptr tag) (cpointer-push-tag! cptr tag))]))
-
-(define (cpointer-maker nullable?)
-  (case-lambda
-   [(tag) ((cpointer-maker nullable?) tag #f #f #f)]
-   [(tag ptr-type) ((cpointer-maker nullable?) tag ptr-type #f #f)]
-   [(tag ptr-type scheme->c c->scheme)
-    (let* ([tag->C (string->symbol (format "~a->C" tag))]
-           [error-str (format "~a`~a' pointer"
-                              (if nullable? "" "non-null ") tag)]
-           [error* (lambda (p) (raise-type-error tag->C error-str p))])
-      (define-syntax-rule (tag-or-error ptr t)
-        (let ([p ptr])
-          (if (cpointer? p)
-            (if (cpointer-has-tag? p t) p (error* p))
-            (error* p))))
-      (define-syntax-rule (tag-or-error/null ptr t)
-        (let ([p ptr])
-          (if (cpointer? p)
-            (and p (if (cpointer-has-tag? p t) p (error* p)))
-            (error* p))))
-      (make-ctype (or ptr-type _pointer)
-        ;; bad hack: `if's outside the lambda for efficiency
-        (if nullable?
-          (if scheme->c
-            (lambda (p) (tag-or-error/null (scheme->c p) tag))
-            (lambda (p) (tag-or-error/null p tag)))
-          (if scheme->c
-            (lambda (p) (tag-or-error (scheme->c p) tag))
-            (lambda (p) (tag-or-error p tag))))
-        (if nullable?
-          (if c->scheme
-            (lambda (p) (when p (cpointer-push-tag! p tag)) (c->scheme p))
-            (lambda (p) (when p (cpointer-push-tag! p tag)) p))
-          (if c->scheme
-            (lambda (p)
-              (if p (cpointer-push-tag! p tag) (error* p))
-              (c->scheme p))
-            (lambda (p)
-              (if p (cpointer-push-tag! p tag) (error* p))
-              p)))))]))
-
-;; This is a kind of a pointer that gets a specific tag when converted to
-;; Scheme, and accepts only such tagged pointers when going to C.  An optional
-;; `ptr-type' can be given to be used as the base pointer type, instead of
-;; _pointer, `scheme->c' and `c->scheme' can be used for adding conversion
-;; hooks.
-(define* _cpointer (cpointer-maker #f))
-
-;; Similar to the above, but can tolerate null pointers (#f).
-(define* _cpointer/null (cpointer-maker #t))
-
-;; A macro version of the above two functions, using the defined name for a tag
-;; string, and defining a predicate too.  The name should look like `_foo', the
-;; predicate will be `foo?', and the tag will be "foo".  In addition, `foo-tag'
-;; is bound to the tag.  The optional `ptr-type', `scheme->c', and `c->scheme'
-;; arguments are the same as those of `_cpointer'.  `_foo' will be bound to the
-;; _cpointer type, and `_foo/null' to the _cpointer/null type.
-(provide define-cpointer-type)
-(define-syntax (define-cpointer-type stx)
-  (syntax-case stx ()
-    [(_ _TYPE) #'(define-cpointer-type _TYPE #f #f #f)]
-    [(_ _TYPE ptr-type) #'(define-cpointer-type _TYPE ptr-type #f #f)]
-    [(_ _TYPE ptr-type scheme->c c->scheme)
-     (and (identifier? #'_TYPE)
-          (regexp-match #rx"^_.+" (symbol->string (syntax-e #'_TYPE))))
-     (let ([name (cadr (regexp-match #rx"^_(.+)$"
-                                     (symbol->string (syntax-e #'_TYPE))))])
-       (define (id . strings)
-         (datum->syntax
-          #'_TYPE (string->symbol (apply string-append strings)) #'_TYPE))
-       (with-syntax ([name-string name]
-                     [TYPE?      (id name "?")]
-                     [TYPE-tag   (id name "-tag")]
-                     [_TYPE/null (id "_" name "/null")])
-         #'(define-values (_TYPE _TYPE/null TYPE? TYPE-tag)
-             (let ([TYPE-tag name-string])
-               (values (_cpointer      TYPE-tag ptr-type scheme->c c->scheme)
-                       (_cpointer/null TYPE-tag ptr-type scheme->c c->scheme)
-                       (lambda (x)
-                         (and (cpointer? x) (cpointer-has-tag? x TYPE-tag)))
-                       TYPE-tag)))))]))
-
-;; ----------------------------------------------------------------------------
-;; Struct wrappers
-
-(define (compute-offsets types)
-  (let loop ([ts types] [cur 0] [r '()])
-    (if (null? ts)
-      (reverse r)
-      (let* ([algn (ctype-alignof (car ts))]
-             [pos  (+ cur (modulo (- (modulo cur algn)) algn))])
-        (loop (cdr ts)
-              (+ pos (ctype-sizeof (car ts)))
-              (cons pos r))))))
-
-;; Simple structs: call this with a list of types, and get a type that marshals
-;; C structs to/from Scheme lists.
-(define* (_list-struct . types)
-  (let ([stype   (make-cstruct-type types)]
-        [offsets (compute-offsets types)]
-        [len     (length types)])
-    (make-ctype stype
-      (lambda (vals)
-        (unless (and (list vals) (= len (length vals)))
-          (raise-type-error 'list-struct (format "list of ~a items" len) vals))
-        (let ([block (malloc stype)])
-          (for-each (lambda (type ofs val) (ptr-set! block type 'abs ofs val))
-                    types offsets vals)
-          block))
-      (lambda (block)
-        (map (lambda (type ofs) (ptr-ref block type 'abs ofs))
-             types offsets)))))
-
-;; (define-cstruct _foo ([slot type] ...))
-;; or
-;; (define-cstruct (_foo _super) ([slot type] ...))
-;; defines a type called _foo for a C struct, with user-procedues: make-foo,
-;; foo? foo-slot... and set-foo-slot!....  The `_' prefix is required.  Objects
-;; of this new type are actually cpointers, with a type tag that is "foo" and
-;; (possibly more if the first type is itself a cstruct type or if a super type
-;; is given,) provided as foo-tag, and tags of pointers are checked before
-;; attempting to use them (see define-cpointer-type above).  Note that since
-;; structs are implemented as pointers, they can be used for a _pointer input
-;; to a foreign function: their address will be used, to make this possible,
-;; the corresponding cpointer type is defined as _foo-pointer.  If a super
-;; cstruct type is given, the constructor function expects values for every
-;; field of the super type as well as other fields that are specified, and a
-;; slot named `super' can be used to extract this initial struct -- although
-;; pointers to the new struct type can be used as pointers to the super struct
-;; type.
-(provide define-cstruct)
-(define-syntax (define-cstruct stx)
-  (define (make-syntax _TYPE-stx has-super? slot-names-stx slot-types-stx)
-    (define name
-      (cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx)))))
-    (define slot-names (map (lambda (x) (symbol->string (syntax-e x)))
-                            (syntax->list slot-names-stx)))
-    (define 1st-type
-      (let ([xs (syntax->list slot-types-stx)]) (and (pair? xs) (car xs))))
-    (define (id . strings)
-      (datum->syntax
-       _TYPE-stx (string->symbol (apply string-append strings)) _TYPE-stx))
-    (define (ids name-func)
-      (map (lambda (s)
-             (datum->syntax
-              _TYPE-stx
-              (string->symbol (apply string-append (name-func s)))
-              _TYPE-stx))
-           slot-names))
-    (define (safe-id=? x y)
-      (and (identifier? x) (identifier? y) (free-identifier=? x y)))
-    (with-syntax
-        ([has-super?           has-super?]
-         [name-string          name]
-         [struct-string        (format "struct:~a" name)]
-         [(slot ...)           slot-names-stx]
-         [(slot-type ...)      slot-types-stx]
-         [_TYPE                _TYPE-stx]
-         [_TYPE-pointer        (id "_"name"-pointer")]
-         [_TYPE-pointer/null   (id "_"name"-pointer/null")]
-         [_TYPE/null           (id "_"name"/null")]
-         [_TYPE*               (id "_"name"*")]
-         [TYPE?                (id name"?")]
-         [make-TYPE            (id "make-"name)]
-         [list->TYPE           (id "list->"name)]
-         [list*->TYPE          (id "list*->"name)]
-         [TYPE->list           (id name"->list")]
-         [TYPE->list*          (id name"->list*")]
-         [TYPE-tag             (id name"-tag")]
-         [(stype ...)          (ids (lambda (s) `(,name"-",s"-type")))]
-         [(TYPE-SLOT ...)      (ids (lambda (s) `(,name"-",s)))]
-         [(set-TYPE-SLOT! ...) (ids (lambda (s) `("set-",name"-",s"!")))]
-         [(offset ...) (generate-temporaries
-                               (ids (lambda (s) `(,s"-offset"))))])
-      (with-syntax ([get-super-info
-                     ;; the 1st-type might be a pointer to this type
-                     (if (or (safe-id=? 1st-type #'_TYPE-pointer/null)
-                             (safe-id=? 1st-type #'_TYPE-pointer))
-                       #'(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
-                          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
-                                         super->list* list*->super)
-                          get-super-info])
-              (define-cpointer-type _TYPE super-pointer)
-              ;; these makes it possible to use recursive pointer definitions
-              (define _TYPE-pointer      _TYPE)
-              (define _TYPE-pointer/null _TYPE/null)
-              (let*-values ([(stype ...)  (values slot-type ...)]
-                            [(types)      (list stype ...)]
-                            [(offsets)    (compute-offsets types)]
-                            [(offset ...) (apply values offsets)])
-                (define all-tags (cons TYPE-tag super-tags))
-                (define _TYPE*
-                  ;; c->scheme adjusts all tags
-                  (let* ([cst (make-cstruct-type types)]
-                         [t (_cpointer TYPE-tag cst)]
-                         [c->s (ctype-c->scheme t)])
-                    (make-ctype cst (ctype-scheme->c t)
-                      ;; hack: modify & reuse the procedure made by _cpointer
-                      (lambda (p)
-                        (if p (set-cpointer-tag! p all-tags) (c->s p))
-                        p))))
-                (define-values (all-types all-offsets)
-                  (if (and has-super? super-types super-offsets)
-                    (values (append super-types   (cdr types))
-                            (append super-offsets (cdr offsets)))
-                    (values types offsets)))
-                (define (TYPE-SLOT x)
-                  (unless (TYPE? x)
-                    (raise-type-error 'TYPE-SLOT struct-string x))
-                  (ptr-ref x stype 'abs offset))
-                ...
-                (define (set-TYPE-SLOT! x slot)
-                  (unless (TYPE? x)
-                    (raise-type-error 'set-TYPE-SLOT! struct-string 0 x slot))
-                  (ptr-set! x stype 'abs offset slot))
-                ...
-                (define make-TYPE
-                  (if (and has-super? super-types super-offsets)
-                    ;; init using all slots
-                    (lambda vals
-                      (if (= (length vals) (length all-types))
-                        (let ([block (malloc _TYPE*)])
-                          (set-cpointer-tag! block all-tags)
-                          (for-each (lambda (type ofs value)
-                                      (ptr-set! block type 'abs ofs value))
-                                    all-types all-offsets vals)
-                          block)
-                        (error '_TYPE "expecting ~s values, got ~s: ~e"
-                               (length all-types) (length vals) vals)))
-                    ;; normal initializer
-                    (lambda (slot ...)
-                      (let ([block (malloc _TYPE*)])
-                        (set-cpointer-tag! block all-tags)
-                        (ptr-set! block stype 'abs offset slot)
-                        ...
-                        block))))
-                (define (list->TYPE vals) (apply make-TYPE vals))
-                (define (list*->TYPE vals)
-                  (cond
-                    [(TYPE? vals) vals]
-                    [(= (length vals) (length all-types))
-                     (let ([block (malloc _TYPE*)])
-                       (set-cpointer-tag! block all-tags)
-                       (for-each
-                        (lambda (type ofs value)
-                          (let-values
-                              ([(ptr tags types offsets T->list* list*->T)
-                                (cstruct-info
-                                 type
-                                 (lambda () (values #f '() #f #f #f #f)))])
-                            (ptr-set! block type 'abs ofs
-                                      (if list*->T (list*->T value) value))))
-                        all-types all-offsets vals)
-                       block)]
-                    [else (error '_TYPE "expecting ~s values, got ~s: ~e"
-                                 (length all-types) (length vals) vals)]))
-                (define (TYPE->list x)
-                  (unless (TYPE? x)
-                    (raise-type-error 'TYPE-list struct-string x))
-                  (map (lambda (type ofs) (ptr-ref x type 'abs ofs))
-                       all-types all-offsets))
-                (define (TYPE->list* x)
-                  (unless (TYPE? x)
-                    (raise-type-error 'TYPE-list struct-string x))
-                  (map (lambda (type ofs)
-                         (let-values
-                             ([(v) (ptr-ref x type 'abs ofs)]
-                              [(ptr tags types offsets T->list* list*->T)
-                               (cstruct-info
-                                type
-                                (lambda () (values #f '() #f #f #f #f)))])
-                           (if T->list* (T->list* v) v)))
-                       all-types all-offsets))
-                (cstruct-info
-                 _TYPE* 'set!
-                 _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*)))))))
-  (define (identifiers? stx)
-    (andmap identifier? (syntax->list stx)))
-  (define (_-identifier? id stx)
-    (and (identifier? id)
-         (or (regexp-match #rx"^_." (symbol->string (syntax-e id)))
-             (raise-syntax-error #f "cstruct name must begin with a `_'"
-                                 stx id))))
-  (syntax-case stx ()
-    [(_ _TYPE ([slot slot-type] ...))
-     (and (_-identifier? #'_TYPE stx)
-          (identifiers? #'(slot ...)))
-     (make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...))]
-    [(_ (_TYPE _SUPER) ([slot slot-type] ...))
-     (and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...)))
-     (with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)])
-       (make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...)))]))
-
-;; helper for the above: keep runtime information on structs
-(define cstruct-info
-  (let ([table (make-weak-hasheq)])
-    (lambda (cstruct msg/fail-thunk . args)
-      (cond [(eq? 'set! msg/fail-thunk)
-             (hash-set! table cstruct (make-ephemeron cstruct args))]
-            [(and cstruct ; might get a #f if there were no slots
-                  (hash-ref table cstruct (lambda () #f)))
-             => (lambda (xs)
-                  (let ([v (ephemeron-value xs)])
-                    (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 (ctype? basetype)
-      (let ([s->c (ctype-scheme->c type)])
-        (get-lowlevel-object (if s->c (s->c x) x) basetype))
-      (values x type))))
-
-;; Converting Scheme lists to/from C vectors (going back requires a length)
-(define* (list->cblock l type)
-  (if (null? l)
-    #f ; null => NULL
-    (let ([cblock (malloc (length l) type)])
-      (let loop ([l l] [i 0])
-        (unless (null? l)
-          (ptr-set! cblock type i (car l))
-          (loop (cdr l) (add1 i))))
-      cblock)))
-(provide* (unsafe cblock->list))
-(define (cblock->list cblock type len)
-  (cond [(zero? len) '()]
-        [(cpointer? cblock)
-         (let loop ([i (sub1 len)] [r '()])
-           (if (< i 0)
-             r
-             (loop (sub1 i) (cons (ptr-ref cblock type i) r))))]
-        [else (error 'cblock->list
-                     "expecting a non-void pointer, got ~s" cblock)]))
-
-;; Converting Scheme vectors to/from C vectors
-(define* (vector->cblock v type)
-  (let ([len (vector-length v)])
-    (if (zero? len)
-      #f ; #() => NULL
-      (let ([cblock (malloc len type)])
-        (let loop ([i 0])
-          (when (< i len)
-            (ptr-set! cblock type i (vector-ref v i))
-            (loop (add1 i))))
-        cblock))))
-(provide* (unsafe cblock->vector))
-(define (cblock->vector cblock type len)
-  (cond [(zero? len) '#()]
-        [(cpointer? cblock)
-         (let ([v (make-vector len)])
-           (let loop ([i (sub1 len)])
-             (unless (< i 0)
-               (vector-set! v i (ptr-ref cblock type i))
-               (loop (sub1 i))))
-           v)]
-        [else (error 'cblock->vector
-                     "expecting a non-void pointer, got ~s" cblock)]))
-
-;; Useful for automatic definitions
-;; If a provided regexp begins with a "^" or ends with a "$", then
-;; `regexp-replace' is used, otherwise use `regexp-replace*'.
-(define* (regexp-replaces x rs)
-  (let loop ([str (if (bytes? x) (bytes->string/utf-8 x) (format "~a" x))]
-             [rs rs])
-    (if (null? rs)
-      str
-      (loop ((if (regexp-match #rx"^\\^|\\$$"
-                               (if (regexp? (caar rs))
-                                 (object-name (caar rs)) (caar rs)))
-               regexp-replace regexp-replace*)
-             (caar rs) str (cadar rs)) (cdr rs)))))
-
-;; A facility for running finalizers using executors.  #%foreign has a C-based
-;; version that uses finalizers, but that leads to calling Scheme from the GC
-;; which is not a good idea.
-(define killer-executor (make-will-executor))
-(define killer-thread #f)
-
-(define* (register-finalizer obj finalizer)
-  (unless killer-thread
-    (set! killer-thread
-          (thread (lambda ()
-                    (let loop () (will-execute killer-executor) (loop))))))
-  (will-register killer-executor obj finalizer))
-
-(define-unsafer unsafe!)
+(module foreign scheme/base
+  (require scheme/foreign)
+  (provide (all-from-out scheme/foreign)))
diff --git a/collects/scheme/foreign.ss b/collects/scheme/foreign.ss
index 1a2b729546..5ca2e2446e 100644
--- a/collects/scheme/foreign.ss
+++ b/collects/scheme/foreign.ss
@@ -1,4 +1,1620 @@
+#lang scheme/base
 
-(module foreign scheme/base
-  (require mzlib/foreign)
-  (provide (all-from-out mzlib/foreign)))
+;; Foreign Scheme interface
+(require '#%foreign setup/dirs
+         (for-syntax scheme/base scheme/list syntax/stx))
+
+;; This module is full of unsafe bindings that are not provided to requiring
+;; modules.  Instead, an `unsafe!' binding is provided that makes these unsafe
+;; bindings available.  The following two syntaxes do that: `provide*' is like
+;; `provide', but using `(unsafe id)' registers an unsafe binding.  Then,
+;; `define-unsafer' should be used with a binding that will expose the unsafe
+;; bindings.  This might move elsewhere at some point if it turns out to be
+;; useful in other contexts.
+(provide provide* define-unsafer)
+(define-syntaxes (provide* define-unsafer)
+  (let ((unsafe-bindings '()))
+    (values
+     (lambda (stx)
+       (syntax-case stx ()
+         [(_ p ...)
+          (let loop ([provides '()]
+                     [unsafes  '()]
+                     [ps (syntax->list #'(p ...))])
+            (if (null? ps)
+              (begin (set! unsafe-bindings
+                           (append unsafe-bindings (reverse unsafes)))
+                     (with-syntax ([(p ...) provides]) #'(provide p ...)))
+              (syntax-case (car ps) (unsafe)
+                [(unsafe u)
+                 (syntax-case #'u (rename-out)
+                   [(rename-out [from to])
+                    (loop provides (cons (cons #'from #'to) unsafes) (cdr ps))]
+                   [id (identifier? #'id)
+                    (loop provides (cons (cons #'id #'id) unsafes) (cdr ps))]
+                   [_
+                    (raise-syntax-error 'provide* "bad unsafe usage"
+                                        (car ps) stx)])]
+                [_ (loop (cons (car ps) provides) unsafes (cdr ps))])))]))
+     (lambda (stx)
+       (syntax-case stx ()
+         [(_ unsafe)
+          (with-syntax ([(from ...)  (map car unsafe-bindings)]
+                        [(to   ...)  (map cdr unsafe-bindings)]
+                        [(id   ...) (generate-temporaries unsafe-bindings)])
+            (set! unsafe-bindings '())
+            #'(begin
+                (provide (protect-out unsafe))
+                (define-syntax (unsafe stx)
+                  (syntax-case stx ()
+                    [(_) (with-syntax ([(id ...) (list (datum->syntax
+                                                        stx 'to stx)
+                                                       ...)])
+                           #'(begin (define-syntax id
+                                      (make-rename-transformer #'from))
+                                    ...))]))))])))))
+
+(provide* ctype-sizeof ctype-alignof compiler-sizeof
+          (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->layout
+          _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64
+          _fixint _ufixint _fixnum _ufixnum
+          _float _double _double*
+          _bool _pointer _scheme _fpointer function-ptr
+          (unsafe memcpy) (unsafe memmove) (unsafe memset)
+          (unsafe malloc-immobile-cell) (unsafe free-immobile-cell))
+
+(define-syntax define*
+  (syntax-rules ()
+    [(_ (name . args) body ...)
+     (begin (provide name) (define (name . args) body ...))]
+    [(_ name expr)
+     (begin (provide name) (define name expr))]))
+
+;; ----------------------------------------------------------------------------
+;; C integer types
+
+(define* _sint8  _int8)
+(define* _sint16 _int16)
+(define* _sint32 _int32)
+(define* _sint64 _int64)
+
+;; _byte etc is a convenient name for _uint8 & _sint8
+;; (_byte is unsigned)
+(define* _byte  _uint8)
+(define* _ubyte _uint8)
+(define* _sbyte _int8)
+
+;; _word etc is a convenient name for _uint16 & _sint16
+;; (_word is unsigned)
+(define* _word  _uint16)
+(define* _uword _uint16)
+(define* _sword _int16)
+
+;; _short etc is a convenient name for whatever is the compiler's `short'
+;; (_short is signed)
+(provide _short _ushort _sshort)
+(define-values (_short _ushort _sshort)
+  (case (compiler-sizeof 'short)
+    [(2) (values _int16 _uint16 _int16)]
+    [(4) (values _int32 _uint32 _int32)]
+    [else (error 'foreign "internal error: bad compiler size for `short'")]))
+
+;; _int etc is a convenient name for whatever is the compiler's `int'
+;; (_int is signed)
+(provide _int _uint _sint)
+(define-values (_int _uint _sint)
+  (case (compiler-sizeof 'int)
+    [(2) (values _int16 _uint16 _int16)]
+    [(4) (values _int32 _uint32 _int32)]
+    [(8) (values _int64 _uint64 _int64)]
+    [else (error 'foreign "internal error: bad compiler size for `int'")]))
+
+;; _long etc is a convenient name for whatever is the compiler's `long'
+;; (_long is signed)
+(provide _long _ulong _slong)
+(define-values (_long _ulong _slong)
+  (case (compiler-sizeof 'long)
+    [(4) (values _int32 _uint32 _int32)]
+    [(8) (values _int64 _uint64 _int64)]
+    [else (error 'foreign "internal error: bad compiler size for `long'")]))
+
+;; _llong etc is a convenient name for whatever is the compiler's `long long'
+;; (_llong is signed)
+(provide _llong _ullong _sllong)
+(define-values (_llong _ullong _sllong)
+  (case (compiler-sizeof '(long long))
+    [(4) (values _int32 _uint32 _int32)]
+    [(8) (values _int64 _uint64 _int64)]
+    [else (error 'foreign "internal error: bad compiler size for `llong'")]))
+
+;; ----------------------------------------------------------------------------
+;; Getting and setting library objects
+
+(define lib-suffix (bytes->string/latin-1 (subbytes (system-type 'so-suffix) 1)))
+(define lib-suffix-re (regexp (string-append "\\." lib-suffix "$")))
+(define suffix-before-version? (not (equal? lib-suffix "dylib")))
+
+(provide* (unsafe (rename-out [get-ffi-lib ffi-lib]))
+          ffi-lib? ffi-lib-name)
+(define get-ffi-lib
+  (case-lambda
+   [(name) (get-ffi-lib name "")]
+   [(name version/s)
+    (cond
+      [(not name) (ffi-lib name)] ; #f => NULL => open this executable
+      [(not (or (string? name) (path? name)))
+       (raise-type-error 'ffi-lib "library-name" name)]
+      [else
+       ;; A possible way that this might be misleading: say that there is a
+       ;; "foo.so" file in the current directory, which refers to some
+       ;; undefined symbol, trying to use this function with "foo.so" will try
+       ;; a dlopen with "foo.so" which isn't found, then it tries a dlopen with
+       ;; "/<curpath>/foo.so" which fails because of the undefined symbol, and
+       ;; since all fails, it will use (ffi-lib "foo.so") to raise the original
+       ;; file-not-found error.  This is because the dlopen doesn't provide a
+       ;; way to distinguish different errors (only dlerror, but that's
+       ;; unreliable).
+       (let* ([versions (if (list? version/s) version/s (list version/s))]
+              [versions (map (lambda (v)
+                               (if (or (not v) (zero? (string-length v)))
+                                 "" (string-append "." v)))
+                             versions)]
+              [fullpath (lambda (p) (path->complete-path (cleanse-path p)))]
+              [absolute? (absolute-path? name)]
+              [name0 (path->string (cleanse-path name))]     ; orig name
+              [names (map (if (regexp-match lib-suffix-re name0) ; name+suffix
+                            (lambda (v) (string-append name0 v))
+                            (lambda (v) 
+                              (if suffix-before-version?
+                                  (string-append name0 "." lib-suffix v)
+                                  (string-append name0 v "." lib-suffix))))
+                          versions)]
+              [ffi-lib*  (lambda (name) (ffi-lib name #t))])
+         (or ;; try to look in our library paths first
+             (and (not absolute?)
+                  (ormap (lambda (dir)
+                           ;; try good names first, then original
+                           (or (ormap (lambda (name)
+                                        (ffi-lib* (build-path dir name)))
+                                      names)
+                               (ffi-lib* (build-path dir name0))))
+                         (get-lib-search-dirs)))
+             ;; try a system search
+             (ormap ffi-lib* names)    ; try good names first
+             (ffi-lib* name0)          ; try original
+             (ormap (lambda (name)     ; try relative paths
+                      (and (file-exists? name) (ffi-lib* (fullpath name))))
+                    names)
+             (and (file-exists? name0) ; relative with original
+                  (ffi-lib* (fullpath name0)))
+             ;; give up: call ffi-lib so it will raise an error
+             (ffi-lib (car names))))])]))
+
+(define (get-ffi-lib-internal x)
+  (if (ffi-lib? x) x (get-ffi-lib x)))
+
+;; These internal functions provide the functionality to be used by
+;; get-ffi-obj, set-ffi-obj! and define-c below
+(define (ffi-get ffi-obj type)
+  (ptr-ref ffi-obj type))
+(define (ffi-set! ffi-obj type new)
+  (let-values ([(new type) (get-lowlevel-object new type)])
+    (hash-set! ffi-objects-ref-table ffi-obj new)
+    (ptr-set! ffi-obj type new)))
+
+;; This is better handled with `make-c-parameter'
+(provide* (unsafe ffi-obj-ref))
+(define ffi-obj-ref
+  (case-lambda
+   [(name lib) (ffi-obj-ref name lib #f)]
+   [(name lib failure)
+    (let ([name (get-ffi-obj-name 'ffi-obj-ref name)]
+          [lib  (get-ffi-lib-internal lib)])
+      (with-handlers ([exn:fail:filesystem?
+                       (lambda (e) (if failure (failure) (raise e)))])
+        (ffi-obj name lib)))]))
+
+;; get-ffi-obj is implemented as a syntax only to be able to propagate the
+;; foreign name into the type syntax, which allows generated wrappers to have a
+;; proper name.
+(provide* (unsafe get-ffi-obj))
+(define get-ffi-obj*
+  (case-lambda
+   [(name lib type) (get-ffi-obj* name lib type #f)]
+   [(name lib type failure)
+    (let ([name (get-ffi-obj-name 'get-ffi-obj name)]
+          [lib  (get-ffi-lib-internal lib)])
+      (let-values ([(obj error?)
+                    (with-handlers
+                        ([exn:fail:filesystem?
+                          (lambda (e)
+                            (if failure (values (failure) #t) (raise e)))])
+                      (values (ffi-obj name lib) #f))])
+        (if error? obj (ffi-get obj type))))]))
+(define-syntax (get-ffi-obj stx)
+  (syntax-case stx ()
+    [(_ name lib type)
+     #`(get-ffi-obj* name lib #,(syntax-property #`type 'ffi-name #'name))]
+    [(_ name lib type failure)
+     #`(get-ffi-obj* name lib #,(syntax-property #`type 'ffi-name #'name)
+                     failure)]
+    [x (identifier? #'x) #'get-ffi-obj*]))
+
+;; It is important to use the set-ffi-obj! wrapper because it takes care of
+;; keeping a handle on the object -- otherwise, setting a callback hook will
+;; crash when the Scheme function is gone.
+(provide* (unsafe set-ffi-obj!))
+(define (set-ffi-obj! name lib type new)
+  (ffi-set! (ffi-obj (get-ffi-obj-name 'set-ffi-obj! name)
+                     (get-ffi-lib-internal lib))
+            type new))
+
+;; Combining the above two in a `define-c' special form which makes a Scheme
+;; `binding', first a `parameter'-like constructor:
+(provide* (unsafe make-c-parameter))
+(define (make-c-parameter name lib type)
+  (let ([obj (ffi-obj (get-ffi-obj-name 'make-c-parameter name)
+                      (get-ffi-lib-internal lib))])
+    (case-lambda [()    (ffi-get  obj type)]
+                 [(new) (ffi-set! obj type new)])))
+;; Then the fake binding syntax, uses the defined identifier to name the
+;; object:
+(provide* (unsafe define-c))
+(define-syntax (define-c stx)
+  (syntax-case stx ()
+    [(_ var-name lib-name type-expr)
+     (with-syntax ([(p) (generate-temporaries (list #'var-name))])
+       (namespace-syntax-introduce
+        #'(begin (define p (make-c-parameter 'var-name lib-name type-expr))
+                 (define-syntax var-name
+                   (syntax-id-rules (set!)
+                     [(set! var val) (p val)]
+                     [(var . xs) ((p) . xs)]
+                     [var (p)])))))]))
+
+;; Used to convert strings and symbols to a byte-string that names an object
+(define (get-ffi-obj-name who objname)
+  (cond [(bytes? objname) objname]
+        [(symbol? objname) (get-ffi-obj-name who (symbol->string objname))]
+        [(string? objname) (string->bytes/utf-8 objname)]
+        [else (raise-type-error who "object-name" objname)]))
+
+;; This table keeps references to values that are set in foreign libraries, to
+;; avoid them being GCed.  See set-ffi-obj! above.
+(define ffi-objects-ref-table (make-hasheq))
+
+;; ----------------------------------------------------------------------------
+;; Compile-time support for fun-expanders
+
+(begin-for-syntax
+
+  ;; The `_fun' macro tears its input apart and reassemble it using pieces from
+  ;; custom function types (macros).  This whole deal needs some work to make
+  ;; it play nicely with code certificates, so Matthew wrote the following
+  ;; code.  The idea is to create a define-fun-syntax which makes the new
+  ;; syntax transformer be an object that carries extra information, later used
+  ;; by `expand-fun-syntax/fun'.
+
+  (define fun-cert-key (gensym))
+
+  ;; bug in begin-for-syntax (PR7104), see below
+  (define foo!!! (make-parameter #f))
+  (define (expand-fun-syntax/normal fun-stx stx)
+    ((foo!!!) fun-stx stx))
+
+  (define-values (make-fun-syntax fun-syntax?
+                  fun-syntax-proc fun-syntax-certifier fun-syntax-name)
+    (let-values ([(desc make pred? get set!)
+                  (make-struct-type
+                   'fun-syntax #f 3 0 #f '() (current-inspector)
+                   expand-fun-syntax/normal)])
+      (values make pred?
+              (make-struct-field-accessor get 0 'proc)
+              (make-struct-field-accessor get 1 'certifier)
+              (make-struct-field-accessor get 2 'name))))
+
+  ;; This is used to expand a fun-syntax in a _fun type context.
+  (define (expand-fun-syntax/fun stx)
+    (let loop ([stx stx])
+      (define (do-expand id id?) ; id? == are we expanding an identifier?
+        (define v           (syntax-local-value id (lambda () #f)))
+        (define set!-trans? (set!-transformer? v))
+        (define proc        (if set!-trans? (set!-transformer-procedure v) v))
+        (if (and (fun-syntax? proc) (or (not id?) set!-trans?))
+          ;; Do essentially the same thing that `local-expand' does.
+          ;;  First, create an "introducer" to mark introduced identifiers:
+          (let* ([introduce (make-syntax-introducer)]
+                 [expanded
+                  ;; Re-introduce mark related to expansion of `_fun':
+                  (syntax-local-introduce
+                   ;; Re-add mark specific to this expansion, cancelling
+                   ;;  some marks applied before expanding (leaving only
+                   ;;  introuced syntax marked)
+                   (introduce
+                    ;; Actually expand:
+                    ((fun-syntax-proc proc)
+                     ;; Add mark specific to this expansion:
+                     (introduce
+                      ;; Remove mark related to expansion of `_fun':
+                      (syntax-local-introduce stx)))))])
+            ;; Certify based on definition of expander, then loop
+            ;;  to continue expanding:
+            (loop ((fun-syntax-certifier proc)
+                   expanded fun-cert-key introduce)))
+          stx))
+      (syntax-case stx ()
+        [(id . rest) (identifier? #'id) (do-expand #'id #f)]
+        [id          (identifier? #'id) (do-expand #'id #t)]
+        [_else stx])))
+
+  ;; Use module-or-top-identifier=? because we use keywords like `=' and want
+  ;; to make it possible to play with it at the toplevel.
+  (define id=? module-or-top-identifier=?)
+
+  (define (split-by key args)
+    (let loop ([args args] [r (list '())])
+      (cond [(null? args) (reverse (map reverse r))]
+            [(eq? key (car args)) (loop (cdr args) (cons '() r))]
+            [else (loop (cdr args)
+                        (cons (cons (car args) (car r)) (cdr r)))])))
+
+  (define (add-renamer body from to)
+    (with-syntax ([body body] [from from] [to to])
+      #'(let-syntax ([to (syntax-id-rules ()
+                           [(_?_ . _rest_) (from . _rest_)] [_?_ from])])
+          body)))
+
+  (define (custom-type->keys type err)
+    (define stops (map (lambda (s) (datum->syntax type s #f))
+                       '(#%app #%top #%datum)))
+    ;; Expand `type' using expand-fun-syntax/fun
+    (define orig (expand-fun-syntax/fun type))
+    (define (with-arg x)
+      (syntax-case* x (=>) id=?
+        [(id => body) (identifier? #'id)
+         ;; Extract #'body from its context, use a key it needs certification:
+         (list (syntax-recertify #'id orig #f fun-cert-key)
+	       (syntax-recertify #'body orig #f fun-cert-key))]
+        [_else x]))
+    (define (cert-id id)
+      (syntax-recertify id orig #f fun-cert-key))
+   (let ([keys '()])
+     (define (setkey! key val . id?)
+       (cond
+         [(assq key keys)
+          (err "bad expansion of custom type (two `~a:'s)" key type)]
+         [(and (pair? id?) (car id?) (not (identifier? val)))
+          (err "bad expansion of custom type (`~a:' expects an identifier)"
+               key type)]
+         [else (set! keys (cons (cons key val) keys))]))
+     (let loop ([t orig])
+       (define (next rest . args) (apply setkey! args) (loop rest))
+       (syntax-case* t (type: expr: bind: 1st-arg: prev-arg: pre: post:) id=?
+         [(type: t x ...)      (next #'(x ...) 'type #'t)]
+         [(expr:     e  x ...) (next #'(x ...) 'expr #'e)]
+         [(bind:     id x ...) (next #'(x ...) 'bind (cert-id #'id) #t)]
+         [(1st-arg:  id x ...) (next #'(x ...) '1st  (cert-id #'id) #t)]
+         [(prev-arg: id x ...) (next #'(x ...) 'prev (cert-id #'id) #t)]
+         ;; in the following two cases pass along orig for recertifying
+         [(pre:      p  x ...) (next #'(x ...) 'pre  (with-arg #'p))]
+         [(post:     p  x ...) (next #'(x ...) 'post (with-arg #'p))]
+         [() (and (pair? keys) keys)]
+         [_else #f]))))
+
+  ;; This is used for a normal expansion of fun-syntax, when not in a _fun type
+  ;; context.
+  ;; bug in begin-for-syntax (PR7104), see above
+  ;;   should be (define (expand-fun-syntax/normal fun-stx stx) ...)
+  (foo!!! (lambda (fun-stx stx)
+    (define (err msg . sub)
+      (apply raise-syntax-error (fun-syntax-name fun-stx) msg stx sub))
+    (let ([keys (custom-type->keys stx err)])
+      (define (getkey key) (cond [(assq key keys) => cdr] [else #f]))
+      (define (notkey key)
+        (when (getkey key)
+          (err (format "this type must be used in a _fun expression (uses ~s)"
+                       key))))
+      (if keys
+        (let ([type (getkey 'type)] [pre (getkey 'pre)] [post (getkey 'post)])
+          (unless type
+            (err "this type must be used in a _fun expression (#f type)"))
+          (for-each notkey '(expr bind 1st prev))
+          (if (or pre post)
+            ;; a type with pre/post blocks
+            (let ([make-> (lambda (x what)
+                            (cond [(not x) #'#f]
+                                  [(and (list? x) (= 2 (length x))
+                                        (identifier? (car x)))
+                                   #`(lambda (#,(car x)) #,(cadr x))]
+                                  [else #`(lambda (_)
+                                            (error '#,(fun-syntax-name fun-stx)
+                                                   "cannot be used to ~a"
+                                                   #,what))]))])
+              (with-syntax ([type type]
+                            [scheme->c (make-> pre "send values to C")]
+                            [c->scheme (make-> post "get values from C")])
+                #'(make-ctype type scheme->c c->scheme)))
+            ;; simple type
+            type))
+        ;; no keys => normal expansion
+        ((fun-syntax-proc fun-stx) stx))))))
+
+;; Use define-fun-syntax instead of define-syntax for forms that
+;;  are to be expanded by `_fun':
+(provide define-fun-syntax)
+(define-syntax define-fun-syntax
+  (syntax-rules ()
+    [(_ id trans)
+     (define-syntax id
+       (let* ([xformer trans]
+              [set!-trans? (set!-transformer? xformer)])
+         (unless (or (and (procedure? xformer)
+                          (procedure-arity-includes? xformer 1))
+                     set!-trans?)
+           (raise-type-error 'define-fun-syntax
+                             "procedure (arity 1) or set!-transformer"
+                             xformer))
+         (let ([f (make-fun-syntax (if set!-trans?
+                                     (set!-transformer-procedure xformer)
+                                     xformer)
+                                   ;; Capture definition-time certificates:
+                                   (syntax-local-certifier)
+                                   'id)])
+           (if set!-trans? (make-set!-transformer f) f))))]))
+
+;; ----------------------------------------------------------------------------
+;; Function type
+
+;; Creates a simple function type that can be used for callouts and callbacks,
+;; optionally applying a wrapper function to modify the result primitive
+;; (callouts) or the input procedure (callbacks).
+(define* (_cprocedure itypes otype
+                      #:abi [abi #f] 
+                      #:wrapper [wrapper #f] 
+                      #:keep [keep #f]
+                      #:atomic? [atomic? #f])
+  (_cprocedure* itypes otype abi wrapper keep atomic?))
+
+;; for internal use
+(define held-callbacks (make-weak-hasheq))
+(define (_cprocedure* itypes otype abi wrapper keep atomic?)
+  (define-syntax-rule (make-it wrap)
+    (make-ctype _fpointer
+      (lambda (x)
+        (and x
+             (let ([cb (ffi-callback (wrap x) itypes otype abi atomic?)])
+               (cond [(eq? keep #t) (hash-set! held-callbacks x cb)]
+                     [(box? keep)
+                      (let ([x (unbox keep)])
+                        (set-box! keep
+                                  (if (or (null? x) (pair? x)) (cons cb x) cb)))]
+                     [(procedure? keep) (keep cb)])
+               cb)))
+      (lambda (x) (and x (wrap (ffi-call x itypes otype abi))))))
+  (if wrapper (make-it wrapper) (make-it begin)))
+
+;; Syntax for the special _fun type:
+;; (_fun [{(name ... [. name]) | name} [-> expr] ::]
+;;       {type | (name : type [= expr]) | ([name :] type = expr)} ...
+;;       -> {type | (name : type)}
+;;       [-> expr])
+;; Usage:
+;; `{(name ...) | ...} ::' specify explicit wrapper function formal arguments
+;;           `-> expr'     can be used instead of the last expr
+;; `type'                  input type (implies input, but see type macros next)
+;; `(name : type = expr)'  specify name and type, `= expr' means computed input
+;; `-> type'               output type (possibly with name)
+;; `-> expr'               specify different output, can use previous names
+;; Also, see below for custom function types.
+
+(provide ->) ; to signal better errors when trying to use this with contracts
+(define-syntax ->
+  (syntax-id-rules ()
+    [_ (raise-syntax-error '-> "should be used only in a _fun context")]))
+
+(provide _fun)
+(define-syntax (_fun stx)
+  (define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub))
+  (define xs     #f)
+  (define abi    #f)
+  (define keep   #f)
+  (define atomic? #f)
+  (define inputs #f)
+  (define output #f)
+  (define bind   '())
+  (define pre    '())
+  (define post   '())
+  (define input-names #f)
+  (define output-type #f)
+  (define output-expr #f)
+  (define 1st-arg     #f)
+  (define prev-arg    #f)
+  (define (bind! x) (set! bind (append bind (list x))))
+  (define (pre!  x) (set! pre  (append pre  (list x))))
+  (define (post! x) (set! post (append post (list x))))
+  (define ((t-n-e clause) type name expr)
+    (let ([keys (custom-type->keys type err)])
+      (define (getkey key) (cond [(assq key keys) => cdr] [else #f]))
+      (define (arg x . no-expr?)
+        (define use-expr?
+          (and (list? x) (= 2 (length x)) (identifier? (car x))))
+        ;; when the current expr is not used with a (x => ...) form,
+        ;; either check that no expression is given or just make it
+        ;; disappear from the inputs.
+        (unless use-expr?
+          (if (and (pair? no-expr?) (car no-expr?) expr)
+            (err "got an expression for a custom type that do not use it"
+                 clause)
+            (set! expr (void))))
+        (set! x (if use-expr? (add-renamer (cadr x) name (car x)) x))
+        (cond [(getkey '1st) =>
+               (lambda (v)
+                 (if 1st-arg
+                   (set! x (add-renamer x 1st-arg v))
+                   (err "got a custom type that wants 1st arg too early"
+                        clause)))])
+        (cond [(getkey 'prev) =>
+               (lambda (v)
+                 (if prev-arg
+                   (set! x (add-renamer x prev-arg v))
+                   (err "got a custom type that wants prev arg too early"
+                        clause)))])
+        x)
+      (when keys
+        (set! type (getkey 'type))
+        (cond [(and (not expr) (getkey 'expr)) => (lambda (x) (set! expr x))])
+        (cond [(getkey 'bind) => (lambda (x) (bind! #`[#,x #,name]))])
+        (cond [(getkey 'pre) => (lambda (x) (pre!  #`[#,name #,(arg x #t)]))])
+        (cond [(getkey 'post) => (lambda (x) (post! #`[#,name #,(arg x)]))]))
+      ;; turn a #f syntax to #f
+      (set! type (and type (syntax-case type () [#f #f] [_ type])))
+      (when type ; remember these for later usages
+        (unless 1st-arg (set! 1st-arg name))
+        (set! prev-arg name))
+      (list type name expr)))
+  (define (do-fun)
+    ;; parse keywords
+    (let loop ()
+      (let ([k (and (pair? xs) (pair? (cdr xs)) (syntax-e (car xs)))])
+        (define-syntax-rule (kwds [key var] ...)
+          (case k
+            [(key) (if var
+                     (err (format "got a second ~s keyword") 'key (car xs))
+                     (begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))]
+            ...
+            [else (err "unknown keyword" (car xs))]))
+        (when (keyword? k) (kwds [#:abi abi] [#:keep keep] [#:atomic? atomic?]))))
+    (unless abi  (set! abi  #'#f))
+    (unless keep (set! keep #'#t))
+    (unless atomic? (set! atomic? #'#f))
+    ;; parse known punctuation
+    (set! xs (map (lambda (x)
+                    (syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_  x]))
+                  xs))
+    ;; parse "::"
+    (let ([s (split-by ':: xs)])
+      (case (length s)
+        [(0) (err "something bad happened (::)")]
+        [(1) (void)]
+        [(2) (if (and (= 1 (length (car s))) (not (eq? '-> (caar s))))
+               (begin (set! xs (cadr s)) (set! input-names (caar s)))
+               (err "bad wrapper formals"))]
+        [else (err "saw two or more instances of `::'")]))
+    ;; parse "->"
+    (let ([s (split-by '-> xs)])
+      (case (length s)
+        [(0) (err "something bad happened (->)")]
+        [(1) (err "missing output type")]
+        [(2 3) (set! inputs (car s))
+               (case (length (cadr s))
+                 [(1) (set! output-type (caadr s))]
+                 [(0) (err "missing output type after `->'")]
+                 [else (err "extraneous output type" (cadadr s))])
+               (unless (null? (cddr s))
+                 (case (length (caddr s))
+                   [(1) (set! output-expr (caaddr s))]
+                   [(0) (err "missing output expression after `->'")]
+                   [else (err "extraneous output expression"
+                              (cadr (caddr s)))]))]
+        [else (err "saw three or more instances of `->'")]))
+    (set! inputs
+          (map (lambda (sub temp)
+                 (let ([t-n-e (t-n-e sub)])
+                   (syntax-case* sub (: =) id=?
+                     [(name : type)        (t-n-e #'type #'name #f)]
+                     [(type = expr)        (t-n-e #'type temp   #'expr)]
+                     [(name : type = expr) (t-n-e #'type #'name #'expr)]
+                     [type                 (t-n-e #'type temp   #f)])))
+               inputs
+               (generate-temporaries (map (lambda (x) 'tmp) inputs))))
+    ;; when processing the output type, only the post code matters
+    (set! pre! (lambda (x) #f))
+    (set! output
+          (let ([temp (car (generate-temporaries #'(ret)))]
+                [t-n-e (t-n-e output-type)])
+            (syntax-case* output-type (: =) id=?
+              [(name : type) (t-n-e #'type #'name output-expr)]
+              [(type = expr) (if output-expr
+                               (err "extraneous output expression" #'expr)
+                               (t-n-e #'type temp #'expr))]
+              [(name : type = expr)
+                             (if output-expr
+                               (err "extraneous output expression" #'expr)
+                               (t-n-e #'type #'name #'expr))]
+              [type          (t-n-e #'type temp output-expr)])))
+    (if (or (caddr output) input-names (ormap caddr inputs)
+            (ormap (lambda (x) (not (car x))) inputs)
+            (pair? bind) (pair? pre) (pair? post))
+      (let* ([input-names (or input-names
+                              (filter-map (lambda (i)
+                                            (and (not (caddr i)) (cadr i)))
+                                          inputs))]
+             [output-expr (let ([o (caddr output)])
+                            (or (and (not (void? o)) o)
+                                (cadr output)))]
+             [args (filter-map (lambda (i)
+                                 (and (caddr i)
+                                      (not (void? (caddr i)))
+                                      #`[#,(cadr i) #,(caddr i)]))
+                               inputs)]
+             [ffi-args (filter-map (lambda (x) (and (car x) (cadr x))) inputs)]
+             ;; the actual wrapper body
+             [body (quasisyntax/loc stx
+                     (lambda #,input-names
+                       (let* (#,@args
+                              #,@bind
+                              #,@pre
+                              [#,(cadr output) (ffi #,@ffi-args)]
+                              #,@post)
+                         #,output-expr)))]
+             ;; if there is a string 'ffi-name property, use it as a name
+             [body (let ([n (cond [(syntax-property stx 'ffi-name)
+                                   => syntax->datum]
+                                  [else #f])])
+                     (if (string? n)
+                       (syntax-property
+                        body 'inferred-name
+                        (string->symbol (string-append "ffi-wrapper:" n)))
+                       body))])
+        #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
+                        #,abi (lambda (ffi) #,body) #,keep #,atomic?))
+      #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
+                      #,abi #f #,keep #,atomic?)))
+  (syntax-case stx ()
+    [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))]))
+
+(define (function-ptr p fun-ctype)
+  (if (or (cpointer? p) (procedure? p))
+      (if (eq? (ctype->layout fun-ctype) 'fpointer)
+           (if (procedure? p)
+               ((ctype-scheme->c fun-ctype) p)
+               ((ctype-c->scheme fun-ctype) p))
+          (raise-type-error 'function-ptr "function ctype" fun-ctype))
+      (raise-type-error 'function-ptr "cpointer" p)))
+
+;; ----------------------------------------------------------------------------
+;; String types
+
+;; The internal _string type uses the native ucs-4 encoding, also providing a
+;; utf-16 type
+(provide _string/ucs-4 _string/utf-16)
+
+;; 8-bit string encodings, #f is NULL
+(define ((false-or-op op) x) (and x (op x)))
+(define* _string/utf-8
+  (make-ctype _bytes
+    (false-or-op string->bytes/utf-8) (false-or-op bytes->string/utf-8)))
+(define* _string/locale
+  (make-ctype _bytes
+    (false-or-op string->bytes/locale) (false-or-op bytes->string/locale)))
+(define* _string/latin-1
+  (make-ctype _bytes
+    (false-or-op string->bytes/latin-1) (false-or-op bytes->string/latin-1)))
+
+;; 8-bit string encodings, #f is NULL, can also use bytes and paths
+(define ((any-string-op op) x)
+  (cond [(not    x) x]
+        [(bytes? x) x]
+        [(path?  x) (path->bytes x)]
+        [else (op x)]))
+(define* _string*/utf-8
+  (make-ctype _bytes
+    (any-string-op string->bytes/utf-8) (false-or-op bytes->string/utf-8)))
+(define* _string*/locale
+  (make-ctype _bytes
+    (any-string-op string->bytes/locale) (false-or-op bytes->string/locale)))
+(define* _string*/latin-1
+  (make-ctype _bytes
+    (any-string-op string->bytes/latin-1) (false-or-op bytes->string/latin-1)))
+
+;; A generic _string type that usually does the right thing via a parameter
+(define* default-_string-type
+  (make-parameter _string*/utf-8
+    (lambda (x)
+      (if (ctype? x)
+        x (error 'default-_string-type "expecting a C type, got ~e" x)))))
+;; The type looks like an identifier, but it's actually using the parameter
+(provide _string)
+(define-syntax _string
+  (syntax-id-rules ()
+    [(_ . xs) ((default-_string-type) . xs)]
+    [_ (default-_string-type)]))
+
+;; _symbol is defined in C, since it uses simple C strings
+(provide _symbol)
+
+(provide _path)
+;; `file' type: path-expands a path string, provide _path too.
+(define* _file (make-ctype _path cleanse-path #f))
+
+;; `string/eof' type: converts an output #f (NULL) to an eof-object.
+(define string-type->string/eof-type
+  (let ([table (make-hasheq)])
+    (lambda (string-type)
+      (hash-ref table string-type
+        (lambda ()
+          (let ([new-type (make-ctype string-type
+                            (lambda (x) (and (not (eof-object? x)) x))
+                            (lambda (x) (or x eof)))])
+            (hash-set! table string-type new-type)
+            new-type))))))
+(provide _string/eof _bytes/eof)
+(define _bytes/eof
+  (make-ctype _bytes
+              (lambda (x) (and (not (eof-object? x)) x))
+              (lambda (x) (or x eof))))
+(define-syntax _string/eof ; make it a syntax so it depends on the _string type
+  (syntax-id-rules ()
+    [(_ . xs) ((string-type->string/eof-type _string) . xs)]
+    [_ (string-type->string/eof-type _string)]))
+
+;; ----------------------------------------------------------------------------
+;; Utility types
+
+;; Call this with a name (symbol) and a list of symbols, where a symbol can be
+;; followed by a '= and an integer to have a similar effect of C's enum.
+(define (_enum* name symbols . base?)
+  (define basetype (if (pair? base?) (car base?) _ufixint))
+  (define sym->int '())
+  (define int->sym '())
+  (define s->c
+    (if name (string->symbol (format "enum:~a->int" name)) 'enum->int))
+  (let loop ([i 0] [symbols symbols])
+    (unless (null? symbols)
+      (let-values ([(i rest)
+                    (if (and (pair? (cdr symbols))
+                             (eq? '= (cadr symbols))
+                             (pair? (cddr symbols)))
+                        (values (caddr symbols)
+                                (cdddr symbols))
+                        (values i
+                                (cdr symbols)))])
+        (set! sym->int (cons (cons (car symbols) i) sym->int))
+        (set! int->sym (cons (cons i (car symbols)) int->sym))
+        (loop (add1 i) rest))))
+  (make-ctype basetype
+    (lambda (x)
+      (let ([a (assq x sym->int)])
+        (if a
+          (cdr a)
+          (raise-type-error s->c (format "~a" (or name "enum")) x))))
+    (lambda (x) (cond [(assq x int->sym) => cdr] [else #f]))))
+
+;; Macro wrapper -- no need for a name
+(provide _enum)
+(define-syntax (_enum stx)
+  (syntax-case stx ()
+    [(_ syms)
+     (with-syntax ([name (syntax-local-name)])
+       #'(_enum* 'name syms))]
+    [(_ syms basetype)
+     (with-syntax ([name (syntax-local-name)])
+       #'(_enum* 'name syms basetype))]
+    [id (identifier? #'id)
+     #'(lambda (syms . base?) (apply _enum* #f syms base?))]))
+
+;; Call this with a name (symbol) and a list of (symbol int) or symbols like
+;; the above with '= -- but the numbers have to be specified in some way.  The
+;; generated type will convert a list of these symbols into the logical-or of
+;; their values and back.
+(define (_bitmask* name orig-symbols->integers . base?)
+  (define basetype (if (pair? base?) (car base?) _uint))
+  (define s->c
+    (if name (string->symbol (format "bitmask:~a->int" name)) 'bitmask->int))
+  (define symbols->integers
+    (let loop ([s->i orig-symbols->integers])
+      (cond
+       [(null? s->i)
+        null]
+       [(and (pair? (cdr s->i)) (eq? '= (cadr s->i)) (pair? (cddr s->i)))
+        (cons (list (car s->i) (caddr s->i))
+              (loop (cdddr s->i)))]
+       [(and (pair? (car s->i)) (pair? (cdar s->i)) (null? (cddar s->i))
+             (symbol? (caar s->i)) (integer? (cadar s->i)))
+        (cons (car s->i) (loop (cdr s->i)))]
+       [else
+        (error '_bitmask "bad spec in ~e" orig-symbols->integers)])))
+  (make-ctype basetype
+    (lambda (symbols)
+      (if (null? symbols) ; probably common
+        0
+        (let loop ([xs (if (pair? symbols) symbols (list symbols))] [n 0])
+          (cond [(null? xs) n]
+                [(assq (car xs) symbols->integers) =>
+                 (lambda (x) (loop (cdr xs) (bitwise-ior (cadr x) n)))]
+                [else (raise-type-error s->c (format "~a" (or name "bitmask"))
+                                        symbols)]))))
+    (lambda (n)
+      (if (zero? n) ; probably common
+        '()
+        (let loop ([s->i symbols->integers] [l '()])
+          (if (null? s->i)
+            (reverse l)
+            (loop (cdr s->i)
+                  (let ([i (cadar s->i)])
+                    (if (and (not (= i 0)) (= i (bitwise-and i n)))
+                      (cons (caar s->i) l)
+                      l)))))))))
+
+;; Macro wrapper -- no need for a name
+(provide _bitmask)
+(define-syntax (_bitmask stx)
+  (syntax-case stx ()
+    [(_ syms)
+     (with-syntax ([name (syntax-local-name)])
+       #'(_bitmask* 'name syms))]
+    [(_ syms basetype)
+     (with-syntax ([name (syntax-local-name)])
+       #'(_bitmask* 'name syms basetype))]
+    [id (identifier? #'id)
+     #'(lambda (syms . base?) (apply _bitmask* #f syms base?))]))
+
+;; ----------------------------------------------------------------------------
+;; Custom function type macros
+
+;; These macros get expanded by the _fun type.  They can expand to a form that
+;; looks like (keyword: value ...), where the keyword is one of:
+;; * `type:'     for the type that will be used,
+;; * `expr:'     an expression that will always be used for these arguments, as
+;;               if `= expr' is always given, when an expression is actually
+;;               given in an argument specification, it supersedes this.
+;; * `bind:'     for an additional binding that holds the initial value,
+;; * `1st-arg:'  is used to name an identifier that will be bound to the value
+;;               of the 1st foreign argument in pre/post chunks (good for
+;;               common cases where the first argument has a special meaning,
+;;               eg, for method calls),
+;; * `prev-arg:' similar to 1st-arg: but for the previous argument,
+;; * `pre:'      for a binding that will be inserted before the ffi call,
+;; * `post:'     for a binding after the ffi call.
+;; The pre: and post: bindings can be of the form (id => expr) to use the
+;; existing value.  Note that if the pre: expression is not (id => expr), then
+;; it means that there is no input for this argument.  Also note that if a
+;; custom type is used as an output type of a function, then only the post:
+;; code is used -- for example, this is useful for foreign functions that
+;; allocate a memory block and return it to the user.  The resulting wrapper
+;; looks like:
+;;   (let* (...bindings for arguments...
+;;          ...bindings for bind: identifiers...
+;;          ...bindings for pre-code...
+;;          (ret-name ffi-call)
+;;          ...bindings for post-code...)
+;;     return-expression)
+;;
+;; Finally, the code in a custom-function macro needs special treatment when it
+;; comes to dealing with code certificates, so instead of using
+;; `define-syntax', you should use `define-fun-syntax' (used in the same way).
+
+;; _?
+;; This is not a normal ffi type -- it is a marker for expressions that should
+;; not be sent to the ffi function.  Use this to bind local values in a
+;; computation that is part of an ffi wrapper interface.
+(provide _?)
+(define-fun-syntax _?
+  (syntax-id-rules () [(_ . xs) ((type: #f) . xs)] [_ (type: #f)]))
+
+;; (_ptr <mode> <type>)
+;; This is for pointers, where mode indicates input or output pointers (or
+;; both).  If the mode is `o' (output), then the wrapper will not get an
+;; argument for it, instead it generates the matching argument.
+(provide _ptr)
+(define-fun-syntax _ptr
+  (syntax-rules (i o io)
+    [(_ i  t) (type: _pointer
+               pre:  (x => (let ([p (malloc t)]) (ptr-set! p t x) p)))]
+    [(_ o  t) (type: _pointer
+               pre:  (malloc t)
+               post: (x => (ptr-ref x t)))]
+    [(_ io t) (type: _pointer
+               pre:  (x => (let ([p (malloc t)]) (ptr-set! p t x) p))
+               post: (x => (ptr-ref x t)))]))
+
+;; (_box <type>)
+;; This is similar to a (_ptr io <type>) argument, where the input is expected
+;; to be a box, which is unboxed on entry and modified on exit.
+(provide _box)
+(define-fun-syntax _box
+  (syntax-rules ()
+    [(_ t) (type: _pointer
+            bind: tmp ; need to save the box so we can get back to it
+            pre:  (x => (let ([p (malloc t)]) (ptr-set! p t (unbox x)) p))
+            post: (x => (begin (set-box! tmp (ptr-ref x t)) tmp)))]))
+
+;; (_list <mode> <type> [<len>])
+;; Similar to _ptr, except that it is used for converting lists to/from C
+;; vectors.  The length is needed for output values where it is used in the
+;; post code, and in the pre code of an output mode to allocate the block.  In
+;; any case it can refer to a previous binding for the length of the list which
+;; the C function will most likely require.
+(provide _list)
+(define-fun-syntax _list
+  (syntax-rules (i o io)
+    [(_ i  t  ) (type: _pointer
+                 pre:  (x => (list->cblock x t)))]
+    [(_ o  t n) (type: _pointer
+                 pre:  (malloc n t)
+                 post: (x => (cblock->list x t n)))]
+    [(_ io t n) (type: _pointer
+                 pre:  (x => (list->cblock x t))
+                 post: (x => (cblock->list x t n)))]))
+
+;; (_vector <mode> <type> [<len>])
+;; Same as _list, except that it uses Scheme vectors.
+(provide _vector)
+(define-fun-syntax _vector
+  (syntax-rules (i o io)
+    [(_ i  t  ) (type: _pointer
+                 pre:  (x => (vector->cblock x t)))]
+    [(_ o  t n) (type: _pointer
+                 pre:  (malloc n t)
+                 post: (x => (cblock->vector x t n)))]
+    [(_ io t n) (type: _pointer
+                 pre:  (x => (vector->cblock x t))
+                 post: (x => (cblock->vector x t n)))]))
+
+;; _bytes or (_bytes o n) is for a memory block represented as a Scheme byte
+;; string.  _bytes is just like a byte-string, and (_bytes o n) is for
+;; pre-malloc of the string.  There is no need for other modes: i or io would
+;; be just like _bytes since the string carries its size information (so there
+;; is no real need for the `o', but it's there for consistency with the above
+;; macros).
+(provide (rename-out [_bytes* _bytes]))
+(define-fun-syntax _bytes*
+  (syntax-id-rules (o)
+    [(_ o n) (type: _bytes
+              pre:  (make-sized-byte-string (malloc n) n)
+              ;; post is needed when this is used as a function output type
+              post: (x => (make-sized-byte-string x n)))]
+    [(_ . xs) (_bytes . xs)]
+    [_ _bytes]))
+
+;; ----------------------------------------------------------------------------
+;; Safe raw vectors
+
+(define-struct cvector (ptr type length))
+
+(provide* cvector? cvector-length cvector-type cvector-ptr
+          ;; make-cvector* is a dangerous operation
+          (unsafe (rename-out [make-cvector make-cvector*])))
+
+(define _cvector* ; used only as input types
+  (make-ctype _pointer cvector-ptr
+    (lambda (x)
+      (error '_cvector
+             "cannot automatically convert a C pointer to a cvector"))))
+
+;; (_cvector <mode> [<type> <len>]) | _cevector
+;; Same as _list etc above, except that it uses C vectors.
+(provide _cvector)
+(define-fun-syntax _cvector
+  (syntax-id-rules (i o io)
+    [(_ i     ) _cvector*]
+    [(_ o  t n) (type: _pointer ; needs to be a pointer, not a cvector*
+                 pre:  (malloc n t)
+                 post: (x => (make-cvector x t n)))]
+    [(_ io    ) (type: _cvector*
+                 bind: tmp
+                 pre:  (x => (cvector-ptr x))
+                 post: (x => tmp))]
+    [(_ . xs)   (_cvector* . xs)]
+    [_          _cvector*]))
+
+(provide (rename-out [allocate-cvector make-cvector]))
+(define (allocate-cvector type len)
+  (make-cvector (if (zero? len) #f ; 0 => NULL
+                    (malloc len type))
+                type len))
+
+(provide (rename-out [cvector-args cvector]))
+(define (cvector-args type . args)
+  (list->cvector args type))
+
+(define* (cvector-ref v i)
+  (if (and (exact-nonnegative-integer? i) (< i (cvector-length v)))
+    (ptr-ref (cvector-ptr v) (cvector-type v) i)
+    (error 'cvector-ref "bad index ~e for cvector bounds of 0..~e"
+           i (sub1 (cvector-length v)))))
+
+(define* (cvector-set! v i x)
+  (if (and (exact-nonnegative-integer? i) (< i (cvector-length v)))
+    (ptr-set! (cvector-ptr v) (cvector-type v) i x)
+    (error 'cvector-ref "bad index ~e for cvector bounds of 0..~e"
+           i (sub1 (cvector-length v)))))
+
+(define* (cvector->list v)
+  (cblock->list (cvector-ptr v) (cvector-type v) (cvector-length v)))
+
+(define* (list->cvector l type)
+  (make-cvector (list->cblock l type) type (length l)))
+
+;; ----------------------------------------------------------------------------
+;; SRFI-4 implementation
+
+(define-syntax (srfi-4-define/provide stx)
+  (syntax-case stx ()
+    [(_ TAG type)
+     (identifier? #'TAG)
+     (let ([name (format "~avector" (syntax->datum #'TAG))])
+       (define (id prefix suffix)
+         (let* ([name (if prefix (string-append prefix name) name)]
+                [name (if suffix (string-append name suffix) name)])
+           (datum->syntax #'TAG (string->symbol name) #'TAG)))
+       (with-syntax ([TAG?         (id "" "?")]
+                     [TAG          (id "" "")]
+                     [s:TAG        (id "s:" "")]
+                     [make-TAG     (id "make-" "")]
+                     [TAG-ptr      (id "" "-ptr")]
+                     [TAG-length   (id "" "-length")]
+                     [allocate-TAG (id "allocate-" "")]
+                     [TAG*         (id "" "*")]
+                     [list->TAG    (id "list->" "")]
+                     [TAG->list    (id "" "->list")]
+                     [TAG-ref      (id "" "-ref")]
+                     [TAG-set!     (id "" "-set!")]
+                     [_TAG         (id "_" "")]
+                     [_TAG*        (id "_" "*")]
+                     [TAGname      name])
+         #'(begin
+             (define-struct TAG (ptr length))
+             (provide TAG? TAG-length (rename-out [TAG s:TAG]))
+             (provide (rename-out [allocate-TAG make-TAG]))
+             (define (allocate-TAG n . init)
+               (let* ([p (if (eq? n 0) #f (malloc n type))]
+                      [v (make-TAG p n)])
+                 (when (and p (pair? init))
+                   (let ([init (car init)])
+                     (let loop ([i (sub1 n)])
+                       (unless (< i 0)
+                         (ptr-set! p type i init)
+                         (loop (sub1 i))))))
+                 v))
+             (provide (rename-out [TAG* TAG]))
+             (define (TAG* . vals)
+               (list->TAG vals))
+             (define* (TAG-ref v i)
+               (if (TAG? v)
+                   (if (and (exact-nonnegative-integer? i) (< i (TAG-length v)))
+                       (ptr-ref (TAG-ptr v) type i)
+                       (error 'TAG-ref "bad index ~e for ~a bounds of 0..~e"
+                              i 'TAG (sub1 (TAG-length v))))
+                   (raise-type-error 'TAG-ref TAGname v)))
+             (define* (TAG-set! v i x)
+               (if (TAG? v)
+                   (if (and (exact-nonnegative-integer? i) (< i (TAG-length v)))
+                       (ptr-set! (TAG-ptr v) type i x)
+                       (error 'TAG-set! "bad index ~e for ~a bounds of 0..~e"
+                              i 'TAG (sub1 (TAG-length v))))
+                   (raise-type-error 'TAG-set! TAGname v)))
+             (define* (TAG->list v)
+               (if (TAG? v)
+                   (cblock->list (TAG-ptr v) type (TAG-length v))
+                   (raise-type-error 'TAG->list TAGname v)))
+             (define* (list->TAG l)
+               (make-TAG (list->cblock l type) (length l)))
+             ;; same as the _cvector implementation
+             (provide _TAG)
+             (define _TAG*
+               (make-ctype _pointer TAG-ptr
+                           (lambda (x)
+                             (error
+                              '_TAG
+                              "cannot automatically convert a C pointer to a ~a"
+                              TAGname))))
+             (define-fun-syntax _TAG
+               (syntax-id-rules (i o io)
+                 [(_ i   ) _TAG*]
+                 [(_ o  n) (type: _pointer
+                                  pre:  (malloc n type)
+                                  post: (x => (make-TAG x n)))]
+                 [(_ io  ) (type: _cvector*
+                                  bind: tmp
+                                  pre:  (x => (TAG-ptr x))
+                                  post: (x => tmp))]
+                 [(_ . xs)   (_TAG* . xs)]
+                 [_          _TAG*])))))]
+    [(_ TAG type)
+     (identifier? #'TAG)]))
+
+;; check that the types that were used above have the proper sizes
+(unless (= 4 (ctype-sizeof _float))
+  (error 'foreign "internal error: float has a bad size (~s)"
+         (ctype-sizeof _float)))
+(unless (= 8 (ctype-sizeof _double*))
+  (error 'foreign "internal error: double has a bad size (~s)"
+         (ctype-sizeof _double*)))
+
+(srfi-4-define/provide s8  _int8)
+(srfi-4-define/provide s16 _int16)
+(srfi-4-define/provide u16 _uint16)
+(srfi-4-define/provide s32 _int32)
+(srfi-4-define/provide u32 _uint32)
+(srfi-4-define/provide s64 _int64)
+(srfi-4-define/provide u64 _uint64)
+(srfi-4-define/provide f32 _float)
+(srfi-4-define/provide f64 _double*)
+
+;; simply rename bytes* to implement the u8vector type
+(provide (rename-out [bytes?       u8vector?      ]
+                     [bytes-length u8vector-length]
+                     [make-bytes   make-u8vector  ]
+                     [bytes        u8vector       ]
+                     [bytes-ref    u8vector-ref   ]
+                     [bytes-set!   u8vector-set!  ]
+                     [bytes->list  u8vector->list ]
+                     [list->bytes  list->u8vector ]
+                     [_bytes       _u8vector      ]))
+;; additional `u8vector' bindings for srfi-66
+(provide (rename-out [bytes-copy u8vector-copy] [bytes=? u8vector=?]))
+(define* (u8vector-compare v1 v2)
+  (cond [(bytes<? v1 v2) -1]
+        [(bytes>? v1 v2)  1]
+        [else             0]))
+(define* (u8vector-copy! src src-start dest dest-start n)
+  (bytes-copy! dest dest-start src src-start (+ src-start n)))
+
+;; ----------------------------------------------------------------------------
+;; Tagged pointers
+
+;; Make these operations available for unsafe interfaces (they can be used to
+;; grab a hidden tag value and break code).
+(provide* (unsafe cpointer-tag) (unsafe set-cpointer-tag!)
+          (unsafe cpointer-has-tag?) (unsafe cpointer-push-tag!))
+
+;; Defined as syntax for efficiency, but can be used as procedures too.
+(define-syntax (cpointer-has-tag? stx)
+  (syntax-case stx ()
+    [(_ cptr tag)
+     #'(let ([ptag (cpointer-tag cptr)])
+         (if (pair? ptag) (memq tag ptag) (eq? tag ptag)))]
+    [id (identifier? #'id)
+     #'(lambda (cptr tag) (cpointer-has-tag? cptr tag))]))
+(define-syntax (cpointer-push-tag! stx)
+  (syntax-case stx ()
+    [(_ cptr tag)
+     #'(let ([ptag (cpointer-tag cptr)])
+         (set-cpointer-tag! cptr
+           (cond [(not ptag) tag]
+                 [(pair? ptag) (cons tag ptag)]
+                 [else (list tag ptag)])))]
+    [id (identifier? #'id)
+     #'(lambda (cptr tag) (cpointer-push-tag! cptr tag))]))
+
+(define (cpointer-maker nullable?)
+  (case-lambda
+   [(tag) ((cpointer-maker nullable?) tag #f #f #f)]
+   [(tag ptr-type) ((cpointer-maker nullable?) tag ptr-type #f #f)]
+   [(tag ptr-type scheme->c c->scheme)
+    (let* ([tag->C (string->symbol (format "~a->C" tag))]
+           [error-str (format "~a`~a' pointer"
+                              (if nullable? "" "non-null ") tag)]
+           [error* (lambda (p) (raise-type-error tag->C error-str p))])
+      (define-syntax-rule (tag-or-error ptr t)
+        (let ([p ptr])
+          (if (cpointer? p)
+            (if (cpointer-has-tag? p t) p (error* p))
+            (error* p))))
+      (define-syntax-rule (tag-or-error/null ptr t)
+        (let ([p ptr])
+          (if (cpointer? p)
+            (and p (if (cpointer-has-tag? p t) p (error* p)))
+            (error* p))))
+      (make-ctype (or ptr-type _pointer)
+        ;; bad hack: `if's outside the lambda for efficiency
+        (if nullable?
+          (if scheme->c
+            (lambda (p) (tag-or-error/null (scheme->c p) tag))
+            (lambda (p) (tag-or-error/null p tag)))
+          (if scheme->c
+            (lambda (p) (tag-or-error (scheme->c p) tag))
+            (lambda (p) (tag-or-error p tag))))
+        (if nullable?
+          (if c->scheme
+            (lambda (p) (when p (cpointer-push-tag! p tag)) (c->scheme p))
+            (lambda (p) (when p (cpointer-push-tag! p tag)) p))
+          (if c->scheme
+            (lambda (p)
+              (if p (cpointer-push-tag! p tag) (error* p))
+              (c->scheme p))
+            (lambda (p)
+              (if p (cpointer-push-tag! p tag) (error* p))
+              p)))))]))
+
+;; This is a kind of a pointer that gets a specific tag when converted to
+;; Scheme, and accepts only such tagged pointers when going to C.  An optional
+;; `ptr-type' can be given to be used as the base pointer type, instead of
+;; _pointer, `scheme->c' and `c->scheme' can be used for adding conversion
+;; hooks.
+(define* _cpointer (cpointer-maker #f))
+
+;; Similar to the above, but can tolerate null pointers (#f).
+(define* _cpointer/null (cpointer-maker #t))
+
+;; A macro version of the above two functions, using the defined name for a tag
+;; string, and defining a predicate too.  The name should look like `_foo', the
+;; predicate will be `foo?', and the tag will be "foo".  In addition, `foo-tag'
+;; is bound to the tag.  The optional `ptr-type', `scheme->c', and `c->scheme'
+;; arguments are the same as those of `_cpointer'.  `_foo' will be bound to the
+;; _cpointer type, and `_foo/null' to the _cpointer/null type.
+(provide define-cpointer-type)
+(define-syntax (define-cpointer-type stx)
+  (syntax-case stx ()
+    [(_ _TYPE) #'(define-cpointer-type _TYPE #f #f #f)]
+    [(_ _TYPE ptr-type) #'(define-cpointer-type _TYPE ptr-type #f #f)]
+    [(_ _TYPE ptr-type scheme->c c->scheme)
+     (and (identifier? #'_TYPE)
+          (regexp-match #rx"^_.+" (symbol->string (syntax-e #'_TYPE))))
+     (let ([name (cadr (regexp-match #rx"^_(.+)$"
+                                     (symbol->string (syntax-e #'_TYPE))))])
+       (define (id . strings)
+         (datum->syntax
+          #'_TYPE (string->symbol (apply string-append strings)) #'_TYPE))
+       (with-syntax ([name-string name]
+                     [TYPE?      (id name "?")]
+                     [TYPE-tag   (id name "-tag")]
+                     [_TYPE/null (id "_" name "/null")])
+         #'(define-values (_TYPE _TYPE/null TYPE? TYPE-tag)
+             (let ([TYPE-tag name-string])
+               (values (_cpointer      TYPE-tag ptr-type scheme->c c->scheme)
+                       (_cpointer/null TYPE-tag ptr-type scheme->c c->scheme)
+                       (lambda (x)
+                         (and (cpointer? x) (cpointer-has-tag? x TYPE-tag)))
+                       TYPE-tag)))))]))
+
+;; ----------------------------------------------------------------------------
+;; Struct wrappers
+
+(define (compute-offsets types)
+  (let loop ([ts types] [cur 0] [r '()])
+    (if (null? ts)
+      (reverse r)
+      (let* ([algn (ctype-alignof (car ts))]
+             [pos  (+ cur (modulo (- (modulo cur algn)) algn))])
+        (loop (cdr ts)
+              (+ pos (ctype-sizeof (car ts)))
+              (cons pos r))))))
+
+;; Simple structs: call this with a list of types, and get a type that marshals
+;; C structs to/from Scheme lists.
+(define* (_list-struct . types)
+  (let ([stype   (make-cstruct-type types)]
+        [offsets (compute-offsets types)]
+        [len     (length types)])
+    (make-ctype stype
+      (lambda (vals)
+        (unless (and (list vals) (= len (length vals)))
+          (raise-type-error 'list-struct (format "list of ~a items" len) vals))
+        (let ([block (malloc stype)])
+          (for-each (lambda (type ofs val) (ptr-set! block type 'abs ofs val))
+                    types offsets vals)
+          block))
+      (lambda (block)
+        (map (lambda (type ofs) (ptr-ref block type 'abs ofs))
+             types offsets)))))
+
+;; (define-cstruct _foo ([slot type] ...))
+;; or
+;; (define-cstruct (_foo _super) ([slot type] ...))
+;; defines a type called _foo for a C struct, with user-procedues: make-foo,
+;; foo? foo-slot... and set-foo-slot!....  The `_' prefix is required.  Objects
+;; of this new type are actually cpointers, with a type tag that is "foo" and
+;; (possibly more if the first type is itself a cstruct type or if a super type
+;; is given,) provided as foo-tag, and tags of pointers are checked before
+;; attempting to use them (see define-cpointer-type above).  Note that since
+;; structs are implemented as pointers, they can be used for a _pointer input
+;; to a foreign function: their address will be used, to make this possible,
+;; the corresponding cpointer type is defined as _foo-pointer.  If a super
+;; cstruct type is given, the constructor function expects values for every
+;; field of the super type as well as other fields that are specified, and a
+;; slot named `super' can be used to extract this initial struct -- although
+;; pointers to the new struct type can be used as pointers to the super struct
+;; type.
+(provide define-cstruct)
+(define-syntax (define-cstruct stx)
+  (define (make-syntax _TYPE-stx has-super? slot-names-stx slot-types-stx)
+    (define name
+      (cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx)))))
+    (define slot-names (map (lambda (x) (symbol->string (syntax-e x)))
+                            (syntax->list slot-names-stx)))
+    (define 1st-type
+      (let ([xs (syntax->list slot-types-stx)]) (and (pair? xs) (car xs))))
+    (define (id . strings)
+      (datum->syntax
+       _TYPE-stx (string->symbol (apply string-append strings)) _TYPE-stx))
+    (define (ids name-func)
+      (map (lambda (s)
+             (datum->syntax
+              _TYPE-stx
+              (string->symbol (apply string-append (name-func s)))
+              _TYPE-stx))
+           slot-names))
+    (define (safe-id=? x y)
+      (and (identifier? x) (identifier? y) (free-identifier=? x y)))
+    (with-syntax
+        ([has-super?           has-super?]
+         [name-string          name]
+         [struct-string        (format "struct:~a" name)]
+         [(slot ...)           slot-names-stx]
+         [(slot-type ...)      slot-types-stx]
+         [_TYPE                _TYPE-stx]
+         [_TYPE-pointer        (id "_"name"-pointer")]
+         [_TYPE-pointer/null   (id "_"name"-pointer/null")]
+         [_TYPE/null           (id "_"name"/null")]
+         [_TYPE*               (id "_"name"*")]
+         [TYPE?                (id name"?")]
+         [make-TYPE            (id "make-"name)]
+         [list->TYPE           (id "list->"name)]
+         [list*->TYPE          (id "list*->"name)]
+         [TYPE->list           (id name"->list")]
+         [TYPE->list*          (id name"->list*")]
+         [TYPE-tag             (id name"-tag")]
+         [(stype ...)          (ids (lambda (s) `(,name"-",s"-type")))]
+         [(TYPE-SLOT ...)      (ids (lambda (s) `(,name"-",s)))]
+         [(set-TYPE-SLOT! ...) (ids (lambda (s) `("set-",name"-",s"!")))]
+         [(offset ...) (generate-temporaries
+                               (ids (lambda (s) `(,s"-offset"))))])
+      (with-syntax ([get-super-info
+                     ;; the 1st-type might be a pointer to this type
+                     (if (or (safe-id=? 1st-type #'_TYPE-pointer/null)
+                             (safe-id=? 1st-type #'_TYPE-pointer))
+                       #'(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
+                          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
+                                         super->list* list*->super)
+                          get-super-info])
+              (define-cpointer-type _TYPE super-pointer)
+              ;; these makes it possible to use recursive pointer definitions
+              (define _TYPE-pointer      _TYPE)
+              (define _TYPE-pointer/null _TYPE/null)
+              (let*-values ([(stype ...)  (values slot-type ...)]
+                            [(types)      (list stype ...)]
+                            [(offsets)    (compute-offsets types)]
+                            [(offset ...) (apply values offsets)])
+                (define all-tags (cons TYPE-tag super-tags))
+                (define _TYPE*
+                  ;; c->scheme adjusts all tags
+                  (let* ([cst (make-cstruct-type types)]
+                         [t (_cpointer TYPE-tag cst)]
+                         [c->s (ctype-c->scheme t)])
+                    (make-ctype cst (ctype-scheme->c t)
+                      ;; hack: modify & reuse the procedure made by _cpointer
+                      (lambda (p)
+                        (if p (set-cpointer-tag! p all-tags) (c->s p))
+                        p))))
+                (define-values (all-types all-offsets)
+                  (if (and has-super? super-types super-offsets)
+                    (values (append super-types   (cdr types))
+                            (append super-offsets (cdr offsets)))
+                    (values types offsets)))
+                (define (TYPE-SLOT x)
+                  (unless (TYPE? x)
+                    (raise-type-error 'TYPE-SLOT struct-string x))
+                  (ptr-ref x stype 'abs offset))
+                ...
+                (define (set-TYPE-SLOT! x slot)
+                  (unless (TYPE? x)
+                    (raise-type-error 'set-TYPE-SLOT! struct-string 0 x slot))
+                  (ptr-set! x stype 'abs offset slot))
+                ...
+                (define make-TYPE
+                  (if (and has-super? super-types super-offsets)
+                    ;; init using all slots
+                    (lambda vals
+                      (if (= (length vals) (length all-types))
+                        (let ([block (malloc _TYPE*)])
+                          (set-cpointer-tag! block all-tags)
+                          (for-each (lambda (type ofs value)
+                                      (ptr-set! block type 'abs ofs value))
+                                    all-types all-offsets vals)
+                          block)
+                        (error '_TYPE "expecting ~s values, got ~s: ~e"
+                               (length all-types) (length vals) vals)))
+                    ;; normal initializer
+                    (lambda (slot ...)
+                      (let ([block (malloc _TYPE*)])
+                        (set-cpointer-tag! block all-tags)
+                        (ptr-set! block stype 'abs offset slot)
+                        ...
+                        block))))
+                (define (list->TYPE vals) (apply make-TYPE vals))
+                (define (list*->TYPE vals)
+                  (cond
+                    [(TYPE? vals) vals]
+                    [(= (length vals) (length all-types))
+                     (let ([block (malloc _TYPE*)])
+                       (set-cpointer-tag! block all-tags)
+                       (for-each
+                        (lambda (type ofs value)
+                          (let-values
+                              ([(ptr tags types offsets T->list* list*->T)
+                                (cstruct-info
+                                 type
+                                 (lambda () (values #f '() #f #f #f #f)))])
+                            (ptr-set! block type 'abs ofs
+                                      (if list*->T (list*->T value) value))))
+                        all-types all-offsets vals)
+                       block)]
+                    [else (error '_TYPE "expecting ~s values, got ~s: ~e"
+                                 (length all-types) (length vals) vals)]))
+                (define (TYPE->list x)
+                  (unless (TYPE? x)
+                    (raise-type-error 'TYPE-list struct-string x))
+                  (map (lambda (type ofs) (ptr-ref x type 'abs ofs))
+                       all-types all-offsets))
+                (define (TYPE->list* x)
+                  (unless (TYPE? x)
+                    (raise-type-error 'TYPE-list struct-string x))
+                  (map (lambda (type ofs)
+                         (let-values
+                             ([(v) (ptr-ref x type 'abs ofs)]
+                              [(ptr tags types offsets T->list* list*->T)
+                               (cstruct-info
+                                type
+                                (lambda () (values #f '() #f #f #f #f)))])
+                           (if T->list* (T->list* v) v)))
+                       all-types all-offsets))
+                (cstruct-info
+                 _TYPE* 'set!
+                 _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*)))))))
+  (define (identifiers? stx)
+    (andmap identifier? (syntax->list stx)))
+  (define (_-identifier? id stx)
+    (and (identifier? id)
+         (or (regexp-match #rx"^_." (symbol->string (syntax-e id)))
+             (raise-syntax-error #f "cstruct name must begin with a `_'"
+                                 stx id))))
+  (syntax-case stx ()
+    [(_ _TYPE ([slot slot-type] ...))
+     (and (_-identifier? #'_TYPE stx)
+          (identifiers? #'(slot ...)))
+     (make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...))]
+    [(_ (_TYPE _SUPER) ([slot slot-type] ...))
+     (and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...)))
+     (with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)])
+       (make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...)))]))
+
+;; helper for the above: keep runtime information on structs
+(define cstruct-info
+  (let ([table (make-weak-hasheq)])
+    (lambda (cstruct msg/fail-thunk . args)
+      (cond [(eq? 'set! msg/fail-thunk)
+             (hash-set! table cstruct (make-ephemeron cstruct args))]
+            [(and cstruct ; might get a #f if there were no slots
+                  (hash-ref table cstruct (lambda () #f)))
+             => (lambda (xs)
+                  (let ([v (ephemeron-value xs)])
+                    (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 (ctype? basetype)
+      (let ([s->c (ctype-scheme->c type)])
+        (get-lowlevel-object (if s->c (s->c x) x) basetype))
+      (values x type))))
+
+;; Converting Scheme lists to/from C vectors (going back requires a length)
+(define* (list->cblock l type)
+  (if (null? l)
+    #f ; null => NULL
+    (let ([cblock (malloc (length l) type)])
+      (let loop ([l l] [i 0])
+        (unless (null? l)
+          (ptr-set! cblock type i (car l))
+          (loop (cdr l) (add1 i))))
+      cblock)))
+(provide* (unsafe cblock->list))
+(define (cblock->list cblock type len)
+  (cond [(zero? len) '()]
+        [(cpointer? cblock)
+         (let loop ([i (sub1 len)] [r '()])
+           (if (< i 0)
+             r
+             (loop (sub1 i) (cons (ptr-ref cblock type i) r))))]
+        [else (error 'cblock->list
+                     "expecting a non-void pointer, got ~s" cblock)]))
+
+;; Converting Scheme vectors to/from C vectors
+(define* (vector->cblock v type)
+  (let ([len (vector-length v)])
+    (if (zero? len)
+      #f ; #() => NULL
+      (let ([cblock (malloc len type)])
+        (let loop ([i 0])
+          (when (< i len)
+            (ptr-set! cblock type i (vector-ref v i))
+            (loop (add1 i))))
+        cblock))))
+(provide* (unsafe cblock->vector))
+(define (cblock->vector cblock type len)
+  (cond [(zero? len) '#()]
+        [(cpointer? cblock)
+         (let ([v (make-vector len)])
+           (let loop ([i (sub1 len)])
+             (unless (< i 0)
+               (vector-set! v i (ptr-ref cblock type i))
+               (loop (sub1 i))))
+           v)]
+        [else (error 'cblock->vector
+                     "expecting a non-void pointer, got ~s" cblock)]))
+
+;; Useful for automatic definitions
+;; If a provided regexp begins with a "^" or ends with a "$", then
+;; `regexp-replace' is used, otherwise use `regexp-replace*'.
+(define* (regexp-replaces x rs)
+  (let loop ([str (if (bytes? x) (bytes->string/utf-8 x) (format "~a" x))]
+             [rs rs])
+    (if (null? rs)
+      str
+      (loop ((if (regexp-match #rx"^\\^|\\$$"
+                               (if (regexp? (caar rs))
+                                 (object-name (caar rs)) (caar rs)))
+               regexp-replace regexp-replace*)
+             (caar rs) str (cadar rs)) (cdr rs)))))
+
+;; A facility for running finalizers using executors.  #%foreign has a C-based
+;; version that uses finalizers, but that leads to calling Scheme from the GC
+;; which is not a good idea.
+(define killer-executor (make-will-executor))
+(define killer-thread #f)
+
+(define* (register-finalizer obj finalizer)
+  (unless killer-thread
+    (set! killer-thread
+          (thread (lambda ()
+                    (let loop () (will-execute killer-executor) (loop))))))
+  (will-register killer-executor obj finalizer))
+
+(define-unsafer unsafe!)
diff --git a/collects/scheme/private/local.ss b/collects/scheme/private/local.ss
index 7c0c27fbef..62a4720405 100644
--- a/collects/scheme/private/local.ss
+++ b/collects/scheme/private/local.ss
@@ -7,47 +7,60 @@
 (define-for-syntax (do-local stx letrec-syntaxes+values-id)
   (syntax-case stx ()
     [(_ (defn ...) body1 body ...)
-     (let ([defs (let ([expand-context (generate-expand-context)])
-                   (let loop ([defns (syntax->list (syntax (defn ...)))])
-                     (apply
-                      append
-                      (map
-                       (lambda (defn)
-                         (let ([d (local-expand
-                                   defn
-                                   expand-context
-                                   (kernel-form-identifier-list))]
-                               [check-ids (lambda (ids)
-                                            (for-each
-                                             (lambda (id)
-                                               (unless (identifier? id)
-                                                 (raise-syntax-error
-                                                  #f
-                                                  "not an identifier for definition"
-                                                  stx
-                                                  id)))
-                                             ids))])
-                           (syntax-case d (define-values define-syntaxes begin)
-                             [(begin defn ...)
-                              (loop (syntax->list (syntax (defn ...))))]
-                             [(define-values (id ...) body)
-                              (begin
-                                (check-ids (syntax->list (syntax (id ...))))
-                                (list d))]
-                             [(define-values . rest)
-                              (raise-syntax-error
-                               #f "ill-formed definition" stx d)]
-                             [(define-syntaxes (id ...) body)
-                              (begin
-                                (check-ids (syntax->list (syntax (id ...))))
-                                (list d))]
-                             [(define-syntaxes . rest)
-                              (raise-syntax-error
-                               #f "ill-formed definition" stx d)]
-                             [_else
-                              (raise-syntax-error
-                               #f "not a definition" stx defn)])))
-                       defns))))])
+     (let* ([def-ctx (syntax-local-make-definition-context)]
+            [defs (let ([expand-context (cons (gensym 'intdef)
+                                              (let ([orig-ctx (syntax-local-context)])
+                                                (if (pair? orig-ctx)
+                                                    orig-ctx
+                                                    null)))])
+                    (let loop ([defns (syntax->list (syntax (defn ...)))])
+                      (apply
+                       append
+                       (map
+                        (lambda (defn)
+                          (let ([d (local-expand
+                                    defn
+                                    expand-context
+                                    (kernel-form-identifier-list)
+                                    def-ctx)]
+                                [check-ids (lambda (defn ids)
+                                             (for-each
+                                              (lambda (id)
+                                                (unless (identifier? id)
+                                                  (raise-syntax-error
+                                                   #f
+                                                   "not an identifier for definition"
+                                                   defn
+                                                   id)))
+                                              ids))])
+                            (syntax-case d (define-values define-syntaxes begin)
+                              [(begin defn ...)
+                               (loop (syntax->list (syntax (defn ...))))]
+                              [(define-values (id ...) body)
+                               (let ([ids (syntax->list (syntax (id ...)))])
+                                 (check-ids d ids)
+                                 (syntax-local-bind-syntaxes ids #f def-ctx)
+                                 (list d))]
+                              [(define-values . rest)
+                               (raise-syntax-error
+                                #f "ill-formed definition" stx d)]
+                              [(define-syntaxes (id ...) rhs)
+                               (let ([ids (syntax->list (syntax (id ...)))])
+                                 (check-ids d ids)
+                                 (with-syntax ([rhs (local-transformer-expand
+                                                     #'rhs
+                                                     'expression
+                                                     null)])
+                                   (syntax-local-bind-syntaxes ids #'rhs def-ctx)
+                                   (list (quasisyntax/loc d (define-syntaxes #,ids rhs)))))]
+                              [(define-syntaxes . rest)
+                               (raise-syntax-error
+                                #f "ill-formed definition" stx d)]
+                              [_else
+                               (raise-syntax-error
+                                #f "not a definition" stx defn)])))
+                        defns))))])
+       (internal-definition-context-seal def-ctx)
        (let ([ids (apply append
                          (map
                           (lambda (d)
@@ -73,9 +86,19 @@
              (raise-syntax-error #f "duplicate identifier" stx dup)))
          (with-syntax ([sbindings sbindings]
                        [vbindings vbindings]
-                       [LSV letrec-syntaxes+values-id])
+                       [LSV letrec-syntaxes+values-id]
+                       [(body ...)
+                        (map (lambda (stx)
+                               ;; add def-ctx:
+                               (let ([q (local-expand #`(quote #,stx)
+                                                      'expression
+                                                      (list #'quote)
+                                                      def-ctx)])
+                                 (syntax-case q ()
+                                   [(_ stx) #'stx])))
+                             (syntax->list #'(body1 body ...)))])
            (syntax/loc stx
              (LSV sbindings vbindings
-               body1 body ...)))))]
+               body ...)))))]
     [(_ x body1 body ...)
      (raise-syntax-error #f "not a definition sequence" stx (syntax x))]))
diff --git a/collects/scribblings/foreign/libs.scrbl b/collects/scribblings/foreign/libs.scrbl
index cd3c352a56..b3084f9dc3 100644
--- a/collects/scribblings/foreign/libs.scrbl
+++ b/collects/scribblings/foreign/libs.scrbl
@@ -21,7 +21,6 @@ Returns @scheme[#t] if @scheme[v] is the result of @scheme[ffi-lib],
 
 @declare-exporting[scribblings/foreign/unsafe-foreign]
 
-
 @defproc[(ffi-lib [path (or/c path-string? #f)]
                   [version (or/c string? (listof string?) #f) #f]) any]{
 
diff --git a/collects/scribblings/reference/module-reflect.scrbl b/collects/scribblings/reference/module-reflect.scrbl
index 801383101e..91d47f3ae9 100644
--- a/collects/scribblings/reference/module-reflect.scrbl
+++ b/collects/scribblings/reference/module-reflect.scrbl
@@ -256,7 +256,9 @@ the module's explicit imports.}
 Returns two association lists mapping @tech{phase level} values (where
 @scheme[#f] corresponds to the @tech{label phase level}) to exports at
 the corresponding phase. The first association list is for exported
-variables, and the second is for exported syntax.
+variables, and the second is for exported syntax. Beware however, that
+value bindings re-exported though a @tech{rename transformer} are in
+the syntax list instead of the value list.
 
 Each associated list, which is represented by @scheme[list?] in the
 result contracts above, more precisely matches the contract
diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl
index 49e188aa33..8da2fbfb77 100644
--- a/collects/scribblings/reference/stx-trans.scrbl
+++ b/collects/scribblings/reference/stx-trans.scrbl
@@ -16,15 +16,22 @@ expander, otherwise the @exnraise[exn:fail:contract].})
 
 @title[#:tag "stxtrans"]{Syntax Transformers}
 
+@defproc[(set!-transformer? [v any/c]) boolean?]{
+
+Returns @scheme[#t] if @scheme[v] is a value created by
+@scheme[make-set!-transformer] or an instance of a structure type with
+the @scheme[prop:set!-transformer] property, @scheme[#f] otherwise.}
+
+
 @defproc[(make-set!-transformer [proc (syntax? . -> . syntax?)])
          set!-transformer?]{
 
-Creates a @tech{syntax transformer} that cooperates with
+Creates an @tech{assignment transformer} that cooperates with
 @scheme[set!]. If the result of @scheme[make-set!-transformer] is
-bound to @scheme[identifier] as a @tech{transformer binding}, then
-@scheme[proc] is applied as a transformer when @scheme[identifier] is
+bound to @scheme[_id] as a @tech{transformer binding}, then
+@scheme[proc] is applied as a transformer when @scheme[_id] is
 used in an expression position, or when it is used as the target of a
-@scheme[set!] assignment as @scheme[(set! identifier _expr)]. When the
+@scheme[set!] assignment as @scheme[(set! _id _expr)]. When the
 identifier appears as a @scheme[set!] target, the entire @scheme[set!]
 expression is provided to the transformer.
 
@@ -45,17 +52,48 @@ expression is provided to the transformer.
 ]}
 
 
-@defproc[(set!-transformer? [v any/c]) boolean?]{
-
-Returns @scheme[#t] if @scheme[v] is a value created by
-@scheme[make-set!-transformer], @scheme[#f] otherwise.}
-
-
 @defproc[(set!-transformer-procedure [transformer set!-transformer?])
          (syntax? . -> . syntax?)]{
 
 Returns the procedure that was passed to
-@scheme[make-set!-transformer] to create @scheme[transformer].}
+@scheme[make-set!-transformer] to create @scheme[transformer] or that
+is identified by the @scheme[prop:set!-transformer] property of
+@scheme[transformer].}
+
+
+@defthing[prop:set!-transformer struct-type-property?]{
+
+A @tech{structure type property} to indentify structure types that act
+as @tech{assignment transformers} like the ones created by
+@scheme[make-set!-transformer].
+
+The property value must be an exact integer or procedure of one
+argument. In the former case, the integer designates a field within
+the structure that should contain a procedure; the integer must be
+between @scheme[0] (inclusive) and the number of non-automatic fields
+in the structure type (exclusive, not counting supertype fields), and
+the designated field must also be specified as immutable.
+
+If the property value is an procedure, then the procedure serves as a
+@tech{syntax transformer} and for @scheme[set!] transformations. If
+the property value is an integer, the target identifier is extracted
+from the structure instance; if the field value is not a procedure of
+one argument, then a procedure that always calls
+@scheme[raise-syntax-error] is used, instead.
+
+If a value has both the @scheme[prop:set!-transformer] and
+@scheme[prop:rename-transformer] properties, then the latter takes
+precedence. If a structure type has the @scheme[prop:set!-transformer]
+and @scheme[prop:procedure] properties, then the former takes
+precedence for the purposes of macro expansion.}
+
+
+@defproc[(rename-transformer? [v any/c]) boolean?]{
+
+Returns @scheme[#t] if @scheme[v] is a value created by
+@scheme[make-rename-transformer] or an instance of a structure type
+with the @scheme[prop:rename-transformer] property, @scheme[#f]
+otherwise.}
 
 
 @defproc[(make-rename-transformer [id-stx syntax?]
@@ -64,28 +102,49 @@ Returns the procedure that was passed to
          rename-transformer?]{
 
 Creates a @tech{rename transformer} that, when used as a
-@tech{transformer binding}, acts as a transformer that insert the
+@tech{transformer binding}, acts as a transformer that inserts the
 identifier @scheme[id-stx] in place of whatever identifier binds the
 transformer, including in non-application positions, in @scheme[set!]
-expressions. Such a transformer could be written manually, but the one
-created by @scheme[make-rename-transformer] also causes the parser to
-install a @scheme[free-identifier=?] and @scheme[identifier-binding]
-equivalence, and it cooperates specially with
+expressions.
+
+Such a transformer could be written manually, but the one created by
+@scheme[make-rename-transformer] also causes the parser to install a
+@scheme[free-identifier=?] and @scheme[identifier-binding]
+equivalence, as long as @scheme[id-stx] does not have a true value for the
+@indexed-scheme['not-free-identifier=?] @tech{syntax property}.
+In addition, the rename transformer cooperates specially with
 @scheme[syntax-local-value] and
 @scheme[syntax-local-make-delta-introducer].}
 
 
-@defproc[(rename-transformer? [v any/c]) boolean?]{
-
-Returns @scheme[#t] if @scheme[v] is a value created by
-@scheme[make-rename-transformer], @scheme[#f] otherwise.}
-
-
 @defproc[(rename-transformer-target [transformer rename-transformer?])
-         syntax?]{
+         identifier?]{
 
 Returns the identifier passed to @scheme[make-rename-transformer] to
-create @scheme[transformer].}
+create @scheme[transformer] or as indicated by a
+@scheme[prop:rename-transformer] property on @scheme[transformer].}
+
+
+@defthing[prop:rename-transformer struct-type-property?]{
+
+A @tech{structure type property} to indentify structure types that act
+as @tech{rename transformers} like the ones created by
+@scheme[make-rename-transformer].
+
+The property value must be an exact integer or an identifier
+@tech{syntax object}. In the former case, the integer designates a
+field within the structure that should contain an identifier; the
+integer must be between @scheme[0] (inclusive) and the number of
+non-automatic fields in the structure type (exclusive, not counting
+supertype fields), and the designated field must also be specified as
+immutable.
+
+If the property value is an identifier, the identifier serves as the
+target for renaming, just like the first argument to
+@scheme[make-rename-transformer]. If the property value is an integer,
+the target identifier is extracted from the structure instance; if the
+field value is not an identifier, then an identifier @schemeidfont{?}
+with an empty context is used, instead.}
 
 
 @defproc[(local-expand [stx syntax?]
@@ -309,6 +368,28 @@ being expanded for the body of a module, then resolving
 @transform-time[]}
 
 
+@defproc[(syntax-local-value/immediate [id-stx syntax?]
+                                       [failure-thunk (or/c (-> any) #f)
+                                                      #f]
+                                       [intdef-ctx (or/c internal-definition-context?
+                                                         #f)
+                                                   #f])
+         any]{
+
+Like @scheme[syntax-local-value], but the result is normally two
+values. If @scheme[id-stx] is bound to a @tech{rename transformer},
+the results are the rename transformer and the identifier in the
+transformer augmented with certificates from @scheme[id-stx]. If
+@scheme[id-stx] is not bound to a @tech{rename transformer}, then the
+results are the value that @scheme[syntax-local-value] would produce
+and @scheme[#f].
+
+If @scheme[id-stx] has no transformer biding, then
+@scheme[failure-thunk] is called (and it can return any number of
+values), or an exception is raised if @scheme[failure-thunk] is
+@scheme[#f].}
+
+
 @defproc[(syntax-local-lift-expression [stx syntax?])
          identifier?]{
 
diff --git a/collects/scribblings/reference/syntax-model.scrbl b/collects/scribblings/reference/syntax-model.scrbl
index aa201a3ae1..1f080ca659 100644
--- a/collects/scribblings/reference/syntax-model.scrbl
+++ b/collects/scribblings/reference/syntax-model.scrbl
@@ -531,23 +531,27 @@ is the one left with a mark, and the reference @scheme[x] has no mark,
 so the binding @scheme[x] is not @scheme[bound-identifier=?] to the
 body @scheme[x].
 
-The @scheme[set!] form and the @scheme[make-set!-transformer]
-procedure work together to support @deftech{assignment transformers}
-that transformer @scheme[set!] expression. @tech{Assignment
-transformers} are applied by @scheme[set!] in the same way as a normal
+The @scheme[set!] form works with the @scheme[make-set!-transformer]
+and @scheme[prop:set!-transformer] property to support
+@deftech{assignment transformers} that transform @scheme[set!]
+expressions. An @tech{assignment transformer} contains a procedure
+that is applied by @scheme[set!] in the same way as a normal
 transformer by the expander.
 
-The @scheme[make-rename-transformer] procedure creates a value that is
-also handled specially by the expander and by @scheme[set!] as a
+The @scheme[make-rename-transformer] procedure or
+@scheme[prop:rename-transformer] property creates a value that is also
+handled specially by the expander and by @scheme[set!] as a
 transformer binding's value. When @scheme[_id] is bound to a
 @deftech{rename transformer} produced by
-@scheme[make-rename-transformer], it is replaced with the identifier
-passed to @scheme[make-rename-transformer]. In addition, the lexical
-information that contains the binding of @scheme[_id] is also enriched
-so that @scheme[_id] is @scheme[free-identifier=?] to the identifier
-passed to @scheme[make-rename-transformer], and
+@scheme[make-rename-transformer], it is replaced with the target
+identifier passed to @scheme[make-rename-transformer]. In addition, as
+long as the target identifier does not have a true value for the
+@scheme['not-free-identifier=?] @tech{syntax property}, the lexical information that
+contains the binding of @scheme[_id] is also enriched so that
+@scheme[_id] is @scheme[free-identifier=?] to the target identifier,
 @scheme[identifier-binding] returns the same results for both
-identifiers. Finally, the binding is treated specially by
+identifiers, and @scheme[provide] exports @scheme[_id] as the target
+identifier. Finally, the binding is treated specially by
 @scheme[syntax-local-value], and
 @scheme[syntax-local-make-delta-introducer] as used by @tech{syntax
 transformer}s.
diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl
index 048e56b9ea..e0647da100 100644
--- a/collects/scribblings/reference/syntax.scrbl
+++ b/collects/scribblings/reference/syntax.scrbl
@@ -702,7 +702,13 @@ follows.
       (define foo 2))
    (require 'test)
    foo
- ]}
+ ]
+
+ If @scheme[id] has a transformer binding to a @tech{rename
+ transformer}, then the exported binding is the target identifier of
+ the @tech{rename transformer}, instead of @scheme[id], unless the
+ target identifier has a true value for the
+ @scheme['not-free-identifier=?] @tech{syntax property}.}
 
  @defsubform[(all-defined-out)]{ Exports all identifiers that are
  defined at @tech{phase level} 0 or @tech{phase level} 1 within the
@@ -2109,14 +2115,19 @@ Equivalent to @scheme[(when (not test-expr) expr ...)].
 
 @defform[(set! id expr)]{
 
-If @scheme[id] has a @tech{transformer binding} to an
-@tech{assignment transformer}, as produced by
-@scheme[make-set!-transformer], then this form is expanded by calling
-the assignment transformer with the full expressions. If @scheme[id]
-has a @tech{transformer binding} to a @tech{rename transformer} as
-produced by @scheme[make-rename-transformer], then this form is
-expanded by replacing @scheme[id] with the one provided to
-@scheme[make-rename-transformer].
+If @scheme[id] has a @tech{transformer binding} to an @tech{assignment
+transformer}, as produced by @scheme[make-set!-transformer] or as an
+instance of a structure type with the @scheme[prop:set!-transformer]
+property, then this form is expanded by calling the assignment
+transformer with the full expressions. If @scheme[id] has a
+@tech{transformer binding} to a @tech{rename transformer} as produced
+by @scheme[make-rename-transformer] or as an instance of a structure
+type with the @scheme[prop:rename-transformer] property, then this
+form is expanded by replacing @scheme[id] with the target identifier
+(e.g., the one provided to @scheme[make-rename-transformer]). If a
+transformer binding has both @scheme[prop:set!-transformer] ad
+@scheme[prop:rename-transformer] properties, the latter takes
+precedence.
 
 Otherwise, evaluates @scheme[expr] and installs the result into the
 location for @scheme[id], which must be bound as a local variable or
diff --git a/collects/tests/mzscheme/macro.ss b/collects/tests/mzscheme/macro.ss
index 9087be2801..e308ab9b05 100644
--- a/collects/tests/mzscheme/macro.ss
+++ b/collects/tests/mzscheme/macro.ss
@@ -144,6 +144,32 @@
 	  (set! f 7)
 	  x)))
 
+(test 77 'set!-transformer-prop
+      (let ([x 3])
+	(let-syntax ([f (let ()
+                          (define-struct s!t (proc)
+                            #:property prop:set!-transformer 0)
+                          (make-s!t
+                           (lambda (stx)
+                             (syntax-case stx ()
+                               [(_ __ val)
+                                #'(set! x val)]))))])
+	  (set! f 77)
+	  x)))
+
+(test 777 'set!-transformer-prop2
+      (let ([x 3])
+	(let-syntax ([f (let ()
+                          (define-struct s!t ()
+                            #:property prop:set!-transformer
+                            (lambda (stx)
+                              (syntax-case stx ()
+                                [(_ __ val)
+                                 #'(set! x val)])))
+                          (make-s!t))])
+	  (set! f 777)
+	  x)))
+
 (test 7 'rename-transformer
       (let ([x 3])
 	(let-syntax ([f (make-rename-transformer #'x)])
@@ -431,6 +457,85 @@
   (define q 8)
   (nab h))
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(module rename-transformer-tests scheme/base
+  (require (for-syntax scheme/base))
+
+  (define x 12)
+  (define-syntax bar (let ([x 10])
+                       (make-rename-transformer #'x)))
+  (define-syntax foo (make-rename-transformer #'x))
+  (list foo
+        (identifier-binding #'foo)
+        (free-identifier=? #'x #'foo))
+  (identifier-binding #'bar)
+
+  (begin-for-syntax 
+   (define-struct rt (id)
+     #:property prop:rename-transformer 0
+     #:omit-define-syntaxes))
+
+  (let-syntax ([q (make-rt #'x)])
+    (list q
+          (identifier-binding #'q)
+          (free-identifier=? #'q #'x)))
+
+  (let ([w 11])
+    (letrec-syntax ([q (let ()
+                         (define-struct rt ()
+                           #:property prop:rename-transformer #'w)
+                         (make-rt))])
+      (list q
+            (identifier-binding #'q)
+            (free-identifier=? #'q #'w))))
+
+  (letrec-syntax ([n (make-rename-transformer #'glob)])
+    (list (identifier-binding #'n)
+          (free-identifier=? #'n #'glob)))
+
+  (letrec-syntax ([i (make-rename-transformer #'glob)])
+    (letrec-syntax ([n (make-rename-transformer (syntax-property #'i 'not-free-identifier=? #f))])
+      (list (identifier-binding #'n)
+            (free-identifier=? #'n #'glob)))))
+
+(let ([accum null])
+  (parameterize ([current-print (lambda (v)
+                                  (set! accum (cons (let loop ([v v])
+                                                      (cond
+                                                       [(module-path-index? v) 'mpi]
+                                                       [(pair? v) (cons (loop (car v))
+                                                                        (loop (cdr v)))]
+                                                       [else v]))
+                                                    accum)))])
+    (dynamic-require ''rename-transformer-tests #f))
+  (test '((#f #t) 
+          (#f #t)
+          (11 lexical #t)
+          (12 (mpi x mpi x 0 0 0) #t)
+          lexical
+          (12 (mpi x mpi x 0 0 0) #t))
+        values accum))
+
+(module rename-transformer-tests:m scheme/base
+  (require (for-syntax scheme/base))
+  (define-syntax x 1)
+  (define-syntax x* (make-rename-transformer #'x))
+  (define-syntax x** (make-rename-transformer (syntax-property #'x 'not-free-identifier=? #t)))
+  (define-syntax (get stx)
+    (syntax-case stx ()
+      [(_ i)
+       #`#,(free-identifier=? #'i #'x)]))
+  (provide get x* x**))
+
+(module rename-transformer-tests:n scheme
+  (require 'rename-transformer-tests:m)
+  (provide go)
+  (define (go)
+    (list (get x*) (get x**))))
+
+(test '(#t #f) (dynamic-require ''rename-transformer-tests:n 'go))
+
 ;; ----------------------------------------
 
 (report-errs)
diff --git a/src/mzscheme/src/cstartup.inc b/src/mzscheme/src/cstartup.inc
index 1f54490d79..2e1ecdac6b 100644
--- a/src/mzscheme/src/cstartup.inc
+++ b/src/mzscheme/src/cstartup.inc
@@ -1,5 +1,5 @@
   {
-    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,50,50,0,0,0,1,0,0,3,0,12,0,
+    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,51,50,0,0,0,1,0,0,3,0,12,0,
 17,0,20,0,27,0,40,0,47,0,51,0,58,0,63,0,68,0,72,0,78,
 0,92,0,106,0,109,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0,
 177,0,179,0,193,0,253,0,23,1,32,1,41,1,51,1,87,1,126,1,165,
@@ -100,7 +100,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 2045);
   }
   {
-    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,50,59,0,0,0,1,0,0,13,0,18,0,
+    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,51,59,0,0,0,1,0,0,13,0,18,0,
 35,0,50,0,68,0,84,0,94,0,112,0,132,0,148,0,166,0,197,0,226,
 0,248,0,6,1,12,1,26,1,31,1,41,1,49,1,77,1,109,1,154,1,
 199,1,223,1,6,2,8,2,65,2,155,3,196,3,31,5,135,5,239,5,100,
@@ -132,173 +132,173 @@
 116,101,32,115,116,114,105,110,103,6,36,36,99,97,110,110,111,116,32,97,100,
 100,32,97,32,115,117,102,102,105,120,32,116,111,32,97,32,114,111,111,116,32,
 112,97,116,104,58,32,5,0,27,20,14,159,80,158,36,50,250,80,158,39,51,
-249,22,27,11,80,158,41,50,22,182,12,10,248,22,157,5,23,196,2,28,248,
+249,22,27,11,80,158,41,50,22,184,12,10,248,22,157,5,23,196,2,28,248,
 22,154,6,23,194,2,12,87,94,248,22,168,8,23,194,1,248,80,159,37,53,
 36,195,28,248,22,73,23,195,2,9,27,248,22,66,23,196,2,27,28,248,22,
-163,13,23,195,2,23,194,1,28,248,22,162,13,23,195,2,249,22,164,13,23,
-196,1,250,80,158,42,48,248,22,178,13,2,19,11,10,250,80,158,40,48,248,
-22,178,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,166,13,249,
-22,164,13,23,198,1,247,22,179,13,27,248,22,67,23,200,1,28,248,22,73,
-23,194,2,9,27,248,22,66,23,195,2,27,28,248,22,163,13,23,195,2,23,
-194,1,28,248,22,162,13,23,195,2,249,22,164,13,23,196,1,250,80,158,47,
-48,248,22,178,13,2,19,11,10,250,80,158,45,48,248,22,178,13,2,19,23,
-197,1,10,28,23,193,2,249,22,65,248,22,166,13,249,22,164,13,23,198,1,
-247,22,179,13,248,80,159,45,52,36,248,22,67,23,199,1,87,94,23,193,1,
+165,13,23,195,2,23,194,1,28,248,22,164,13,23,195,2,249,22,166,13,23,
+196,1,250,80,158,42,48,248,22,180,13,2,19,11,10,250,80,158,40,48,248,
+22,180,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,168,13,249,
+22,166,13,23,198,1,247,22,181,13,27,248,22,67,23,200,1,28,248,22,73,
+23,194,2,9,27,248,22,66,23,195,2,27,28,248,22,165,13,23,195,2,23,
+194,1,28,248,22,164,13,23,195,2,249,22,166,13,23,196,1,250,80,158,47,
+48,248,22,180,13,2,19,11,10,250,80,158,45,48,248,22,180,13,2,19,23,
+197,1,10,28,23,193,2,249,22,65,248,22,168,13,249,22,166,13,23,198,1,
+247,22,181,13,248,80,159,45,52,36,248,22,67,23,199,1,87,94,23,193,1,
 248,80,159,43,52,36,248,22,67,23,197,1,87,94,23,193,1,27,248,22,67,
 23,198,1,28,248,22,73,23,194,2,9,27,248,22,66,23,195,2,27,28,248,
-22,163,13,23,195,2,23,194,1,28,248,22,162,13,23,195,2,249,22,164,13,
-23,196,1,250,80,158,45,48,248,22,178,13,2,19,11,10,250,80,158,43,48,
-248,22,178,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,166,13,
-249,22,164,13,23,198,1,247,22,179,13,248,80,159,43,52,36,248,22,67,23,
-199,1,248,80,159,41,52,36,248,22,67,196,27,248,22,139,13,23,195,2,28,
-23,193,2,192,87,94,23,193,1,28,248,22,159,6,23,195,2,27,248,22,161,
-13,195,28,192,192,248,22,162,13,195,11,87,94,28,28,248,22,140,13,23,195,
-2,10,27,248,22,139,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28,
-248,22,159,6,23,196,2,27,248,22,161,13,23,197,2,28,23,193,2,192,87,
-94,23,193,1,248,22,162,13,23,197,2,11,12,250,22,132,9,76,110,111,114,
+22,165,13,23,195,2,23,194,1,28,248,22,164,13,23,195,2,249,22,166,13,
+23,196,1,250,80,158,45,48,248,22,180,13,2,19,11,10,250,80,158,43,48,
+248,22,180,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,168,13,
+249,22,166,13,23,198,1,247,22,181,13,248,80,159,43,52,36,248,22,67,23,
+199,1,248,80,159,41,52,36,248,22,67,196,27,248,22,141,13,23,195,2,28,
+23,193,2,192,87,94,23,193,1,28,248,22,159,6,23,195,2,27,248,22,163,
+13,195,28,192,192,248,22,164,13,195,11,87,94,28,28,248,22,142,13,23,195,
+2,10,27,248,22,141,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28,
+248,22,159,6,23,196,2,27,248,22,163,13,23,197,2,28,23,193,2,192,87,
+94,23,193,1,248,22,164,13,23,197,2,11,12,250,22,132,9,76,110,111,114,
 109,97,108,45,112,97,116,104,45,99,97,115,101,6,42,42,112,97,116,104,32,
 40,102,111,114,32,97,110,121,32,115,121,115,116,101,109,41,32,111,114,32,118,
 97,108,105,100,45,112,97,116,104,32,115,116,114,105,110,103,23,197,2,28,28,
-248,22,140,13,23,195,2,249,22,164,8,248,22,141,13,23,197,2,2,20,249,
+248,22,142,13,23,195,2,249,22,164,8,248,22,143,13,23,197,2,2,20,249,
 22,164,8,247,22,178,7,2,20,27,28,248,22,159,6,23,196,2,23,195,2,
-248,22,168,7,248,22,144,13,23,197,2,28,249,22,191,13,0,21,35,114,120,
+248,22,168,7,248,22,146,13,23,197,2,28,249,22,129,14,0,21,35,114,120,
 34,94,91,92,92,93,91,92,92,93,91,63,93,91,92,92,93,34,23,195,2,
-28,248,22,159,6,195,248,22,147,13,195,194,27,248,22,134,7,23,195,1,249,
-22,148,13,248,22,171,7,250,22,133,14,0,6,35,114,120,34,47,34,28,249,
-22,191,13,0,22,35,114,120,34,91,47,92,92,93,91,46,32,93,43,91,47,
-92,92,93,42,36,34,23,201,2,23,199,1,250,22,133,14,0,19,35,114,120,
+28,248,22,159,6,195,248,22,149,13,195,194,27,248,22,134,7,23,195,1,249,
+22,150,13,248,22,171,7,250,22,135,14,0,6,35,114,120,34,47,34,28,249,
+22,129,14,0,22,35,114,120,34,91,47,92,92,93,91,46,32,93,43,91,47,
+92,92,93,42,36,34,23,201,2,23,199,1,250,22,135,14,0,19,35,114,120,
 34,91,32,46,93,43,40,91,47,92,92,93,42,41,36,34,23,202,1,6,2,
-2,92,49,80,159,43,36,37,2,20,28,248,22,159,6,194,248,22,147,13,194,
-193,87,94,28,27,248,22,139,13,23,196,2,28,23,193,2,192,87,94,23,193,
-1,28,248,22,159,6,23,196,2,27,248,22,161,13,23,197,2,28,23,193,2,
-192,87,94,23,193,1,248,22,162,13,23,197,2,11,12,250,22,132,9,23,196,
-2,2,21,23,197,2,28,248,22,161,13,23,195,2,12,248,22,158,11,249,22,
-167,10,248,22,188,6,250,22,143,7,2,22,23,200,1,23,201,1,247,22,23,
-87,94,28,27,248,22,139,13,23,196,2,28,23,193,2,192,87,94,23,193,1,
-28,248,22,159,6,23,196,2,27,248,22,161,13,23,197,2,28,23,193,2,192,
-87,94,23,193,1,248,22,162,13,23,197,2,11,12,250,22,132,9,23,196,2,
-2,21,23,197,2,28,248,22,161,13,23,195,2,12,248,22,158,11,249,22,167,
+2,92,49,80,159,43,36,37,2,20,28,248,22,159,6,194,248,22,149,13,194,
+193,87,94,28,27,248,22,141,13,23,196,2,28,23,193,2,192,87,94,23,193,
+1,28,248,22,159,6,23,196,2,27,248,22,163,13,23,197,2,28,23,193,2,
+192,87,94,23,193,1,248,22,164,13,23,197,2,11,12,250,22,132,9,23,196,
+2,2,21,23,197,2,28,248,22,163,13,23,195,2,12,248,22,160,11,249,22,
+169,10,248,22,188,6,250,22,143,7,2,22,23,200,1,23,201,1,247,22,23,
+87,94,28,27,248,22,141,13,23,196,2,28,23,193,2,192,87,94,23,193,1,
+28,248,22,159,6,23,196,2,27,248,22,163,13,23,197,2,28,23,193,2,192,
+87,94,23,193,1,248,22,164,13,23,197,2,11,12,250,22,132,9,23,196,2,
+2,21,23,197,2,28,248,22,163,13,23,195,2,12,248,22,160,11,249,22,169,
 10,248,22,188,6,250,22,143,7,2,22,23,200,1,23,201,1,247,22,23,87,
-94,87,94,28,27,248,22,139,13,23,196,2,28,23,193,2,192,87,94,23,193,
-1,28,248,22,159,6,23,196,2,27,248,22,161,13,23,197,2,28,23,193,2,
-192,87,94,23,193,1,248,22,162,13,23,197,2,11,12,250,22,132,9,195,2,
-21,23,197,2,28,248,22,161,13,23,195,2,12,248,22,158,11,249,22,167,10,
+94,87,94,28,27,248,22,141,13,23,196,2,28,23,193,2,192,87,94,23,193,
+1,28,248,22,159,6,23,196,2,27,248,22,163,13,23,197,2,28,23,193,2,
+192,87,94,23,193,1,248,22,164,13,23,197,2,11,12,250,22,132,9,195,2,
+21,23,197,2,28,248,22,163,13,23,195,2,12,248,22,160,11,249,22,169,10,
 248,22,188,6,250,22,143,7,2,22,199,23,201,1,247,22,23,249,22,3,89,
-162,8,44,36,49,9,223,2,33,33,196,248,22,158,11,249,22,133,11,23,196,
+162,8,44,36,49,9,223,2,33,33,196,248,22,160,11,249,22,135,11,23,196,
 1,247,22,23,87,94,250,80,159,38,39,36,2,6,196,197,251,80,159,39,41,
 36,2,6,32,0,89,162,8,44,36,44,9,222,33,35,197,198,32,37,89,162,
 43,41,58,65,99,108,111,111,112,222,33,38,28,248,22,73,23,199,2,87,94,
 23,198,1,248,23,196,1,251,22,143,7,2,23,23,199,1,28,248,22,73,23,
-203,2,87,94,23,202,1,23,201,1,250,22,1,22,157,13,23,204,1,23,205,
-1,23,198,1,27,249,22,157,13,248,22,66,23,202,2,23,199,2,28,248,22,
-152,13,23,194,2,27,250,22,1,22,157,13,23,197,1,23,202,2,28,248,22,
-152,13,23,194,2,192,87,94,23,193,1,27,248,22,67,23,202,1,28,248,22,
+203,2,87,94,23,202,1,23,201,1,250,22,1,22,159,13,23,204,1,23,205,
+1,23,198,1,27,249,22,159,13,248,22,66,23,202,2,23,199,2,28,248,22,
+154,13,23,194,2,27,250,22,1,22,159,13,23,197,1,23,202,2,28,248,22,
+154,13,23,194,2,192,87,94,23,193,1,27,248,22,67,23,202,1,28,248,22,
 73,23,194,2,87,94,23,193,1,248,23,199,1,251,22,143,7,2,23,23,202,
-1,28,248,22,73,23,206,2,87,94,23,205,1,23,204,1,250,22,1,22,157,
-13,23,207,1,23,208,1,23,201,1,27,249,22,157,13,248,22,66,23,197,2,
-23,202,2,28,248,22,152,13,23,194,2,27,250,22,1,22,157,13,23,197,1,
-204,28,248,22,152,13,193,192,253,2,37,203,204,205,206,23,15,248,22,67,201,
+1,28,248,22,73,23,206,2,87,94,23,205,1,23,204,1,250,22,1,22,159,
+13,23,207,1,23,208,1,23,201,1,27,249,22,159,13,248,22,66,23,197,2,
+23,202,2,28,248,22,154,13,23,194,2,27,250,22,1,22,159,13,23,197,1,
+204,28,248,22,154,13,193,192,253,2,37,203,204,205,206,23,15,248,22,67,201,
 253,2,37,202,203,204,205,206,248,22,67,200,87,94,23,193,1,27,248,22,67,
 23,201,1,28,248,22,73,23,194,2,87,94,23,193,1,248,23,198,1,251,22,
 143,7,2,23,23,201,1,28,248,22,73,23,205,2,87,94,23,204,1,23,203,
-1,250,22,1,22,157,13,23,206,1,23,207,1,23,200,1,27,249,22,157,13,
-248,22,66,23,197,2,23,201,2,28,248,22,152,13,23,194,2,27,250,22,1,
-22,157,13,23,197,1,203,28,248,22,152,13,193,192,253,2,37,202,203,204,205,
-206,248,22,67,201,253,2,37,201,202,203,204,205,248,22,67,200,27,247,22,180,
-13,253,2,37,198,199,200,201,202,198,87,95,28,28,248,22,140,13,23,194,2,
-10,27,248,22,139,13,23,195,2,28,23,193,2,192,87,94,23,193,1,28,248,
-22,159,6,23,195,2,27,248,22,161,13,23,196,2,28,23,193,2,192,87,94,
-23,193,1,248,22,162,13,23,196,2,11,12,252,22,132,9,23,200,2,2,24,
+1,250,22,1,22,159,13,23,206,1,23,207,1,23,200,1,27,249,22,159,13,
+248,22,66,23,197,2,23,201,2,28,248,22,154,13,23,194,2,27,250,22,1,
+22,159,13,23,197,1,203,28,248,22,154,13,193,192,253,2,37,202,203,204,205,
+206,248,22,67,201,253,2,37,201,202,203,204,205,248,22,67,200,27,247,22,182,
+13,253,2,37,198,199,200,201,202,198,87,95,28,28,248,22,142,13,23,194,2,
+10,27,248,22,141,13,23,195,2,28,23,193,2,192,87,94,23,193,1,28,248,
+22,159,6,23,195,2,27,248,22,163,13,23,196,2,28,23,193,2,192,87,94,
+23,193,1,248,22,164,13,23,196,2,11,12,252,22,132,9,23,200,2,2,24,
 35,23,198,2,23,199,2,28,28,248,22,159,6,23,195,2,10,248,22,147,7,
 23,195,2,87,94,23,194,1,12,252,22,132,9,23,200,2,2,25,36,23,198,
-2,23,199,1,91,159,38,11,90,161,38,35,11,248,22,160,13,23,197,2,87,
+2,23,199,1,91,159,38,11,90,161,38,35,11,248,22,162,13,23,197,2,87,
 94,23,195,1,87,94,28,192,12,250,22,133,9,23,201,1,2,26,23,199,1,
-249,22,7,194,195,91,159,37,11,90,161,37,35,11,87,95,28,28,248,22,140,
-13,23,196,2,10,27,248,22,139,13,23,197,2,28,23,193,2,192,87,94,23,
-193,1,28,248,22,159,6,23,197,2,27,248,22,161,13,23,198,2,28,23,193,
-2,192,87,94,23,193,1,248,22,162,13,23,198,2,11,12,252,22,132,9,2,
+249,22,7,194,195,91,159,37,11,90,161,37,35,11,87,95,28,28,248,22,142,
+13,23,196,2,10,27,248,22,141,13,23,197,2,28,23,193,2,192,87,94,23,
+193,1,28,248,22,159,6,23,197,2,27,248,22,163,13,23,198,2,28,23,193,
+2,192,87,94,23,193,1,248,22,164,13,23,198,2,11,12,252,22,132,9,2,
 9,2,24,35,23,200,2,23,201,2,28,28,248,22,159,6,23,197,2,10,248,
 22,147,7,23,197,2,12,252,22,132,9,2,9,2,25,36,23,200,2,23,201,
-2,91,159,38,11,90,161,38,35,11,248,22,160,13,23,199,2,87,94,23,195,
+2,91,159,38,11,90,161,38,35,11,248,22,162,13,23,199,2,87,94,23,195,
 1,87,94,28,192,12,250,22,133,9,2,9,2,26,23,201,2,249,22,7,194,
-195,27,249,22,149,13,250,22,132,14,0,18,35,114,120,35,34,40,91,46,93,
-91,94,46,93,42,124,41,36,34,248,22,145,13,23,201,1,28,248,22,159,6,
-23,203,2,249,22,171,7,23,204,1,8,63,23,202,1,28,248,22,140,13,23,
-199,2,248,22,141,13,23,199,1,87,94,23,198,1,247,22,142,13,28,248,22,
-139,13,194,249,22,157,13,195,194,192,91,159,37,11,90,161,37,35,11,87,95,
-28,28,248,22,140,13,23,196,2,10,27,248,22,139,13,23,197,2,28,23,193,
-2,192,87,94,23,193,1,28,248,22,159,6,23,197,2,27,248,22,161,13,23,
-198,2,28,23,193,2,192,87,94,23,193,1,248,22,162,13,23,198,2,11,12,
+195,27,249,22,151,13,250,22,134,14,0,18,35,114,120,35,34,40,91,46,93,
+91,94,46,93,42,124,41,36,34,248,22,147,13,23,201,1,28,248,22,159,6,
+23,203,2,249,22,171,7,23,204,1,8,63,23,202,1,28,248,22,142,13,23,
+199,2,248,22,143,13,23,199,1,87,94,23,198,1,247,22,144,13,28,248,22,
+141,13,194,249,22,159,13,195,194,192,91,159,37,11,90,161,37,35,11,87,95,
+28,28,248,22,142,13,23,196,2,10,27,248,22,141,13,23,197,2,28,23,193,
+2,192,87,94,23,193,1,28,248,22,159,6,23,197,2,27,248,22,163,13,23,
+198,2,28,23,193,2,192,87,94,23,193,1,248,22,164,13,23,198,2,11,12,
 252,22,132,9,2,10,2,24,35,23,200,2,23,201,2,28,28,248,22,159,6,
 23,197,2,10,248,22,147,7,23,197,2,12,252,22,132,9,2,10,2,25,36,
-23,200,2,23,201,2,91,159,38,11,90,161,38,35,11,248,22,160,13,23,199,
+23,200,2,23,201,2,91,159,38,11,90,161,38,35,11,248,22,162,13,23,199,
 2,87,94,23,195,1,87,94,28,192,12,250,22,133,9,2,10,2,26,23,201,
-2,249,22,7,194,195,27,249,22,149,13,249,22,157,7,250,22,133,14,0,9,
-35,114,120,35,34,91,46,93,34,248,22,145,13,23,203,1,6,1,1,95,28,
+2,249,22,7,194,195,27,249,22,151,13,249,22,157,7,250,22,135,14,0,9,
+35,114,120,35,34,91,46,93,34,248,22,147,13,23,203,1,6,1,1,95,28,
 248,22,159,6,23,202,2,249,22,171,7,23,203,1,8,63,23,201,1,28,248,
-22,140,13,23,199,2,248,22,141,13,23,199,1,87,94,23,198,1,247,22,142,
-13,28,248,22,139,13,194,249,22,157,13,195,194,192,249,247,22,190,4,194,11,
-249,80,158,37,46,9,9,249,80,158,37,46,195,9,27,247,22,182,13,249,80,
+22,142,13,23,199,2,248,22,143,13,23,199,1,87,94,23,198,1,247,22,144,
+13,28,248,22,141,13,194,249,22,159,13,195,194,192,249,247,22,190,4,194,11,
+249,80,158,37,46,9,9,249,80,158,37,46,195,9,27,247,22,184,13,249,80,
 158,38,47,28,23,195,2,27,248,22,176,7,6,11,11,80,76,84,67,79,76,
 76,69,67,84,83,28,192,192,6,0,0,6,0,0,27,28,23,196,1,250,22,
-157,13,248,22,178,13,69,97,100,100,111,110,45,100,105,114,247,22,174,7,6,
+159,13,248,22,180,13,69,97,100,100,111,110,45,100,105,114,247,22,174,7,6,
 8,8,99,111,108,108,101,99,116,115,11,27,248,80,159,41,52,36,250,22,79,
-23,203,1,248,22,75,248,22,178,13,72,99,111,108,108,101,99,116,115,45,100,
+23,203,1,248,22,75,248,22,180,13,72,99,111,108,108,101,99,116,115,45,100,
 105,114,23,204,1,28,23,194,2,249,22,65,23,196,1,23,195,1,192,32,47,
-89,162,8,44,38,54,2,18,222,33,48,27,249,22,189,13,23,197,2,23,198,
+89,162,8,44,38,54,2,18,222,33,48,27,249,22,191,13,23,197,2,23,198,
 2,28,23,193,2,87,94,23,196,1,27,248,22,90,23,195,2,27,27,248,22,
-99,23,197,1,27,249,22,189,13,23,201,2,23,196,2,28,23,193,2,87,94,
+99,23,197,1,27,249,22,191,13,23,201,2,23,196,2,28,23,193,2,87,94,
 23,194,1,27,248,22,90,23,195,2,27,250,2,47,23,203,2,23,204,1,248,
 22,99,23,199,1,28,249,22,153,7,23,196,2,2,27,249,22,79,23,202,2,
-194,249,22,65,248,22,148,13,23,197,1,23,195,1,87,95,23,199,1,23,193,
+194,249,22,65,248,22,150,13,23,197,1,23,195,1,87,95,23,199,1,23,193,
 1,28,249,22,153,7,23,196,2,2,27,249,22,79,23,200,2,9,249,22,65,
-248,22,148,13,23,197,1,9,28,249,22,153,7,23,196,2,2,27,249,22,79,
-197,194,87,94,23,196,1,249,22,65,248,22,148,13,23,197,1,194,87,94,23,
+248,22,150,13,23,197,1,9,28,249,22,153,7,23,196,2,2,27,249,22,79,
+197,194,87,94,23,196,1,249,22,65,248,22,150,13,23,197,1,194,87,94,23,
 193,1,28,249,22,153,7,23,198,2,2,27,249,22,79,195,9,87,94,23,194,
-1,249,22,65,248,22,148,13,23,199,1,9,87,95,28,28,248,22,147,7,194,
+1,249,22,65,248,22,150,13,23,199,1,9,87,95,28,28,248,22,147,7,194,
 10,248,22,159,6,194,12,250,22,132,9,2,13,6,21,21,98,121,116,101,32,
 115,116,114,105,110,103,32,111,114,32,115,116,114,105,110,103,196,28,28,248,22,
-74,195,249,22,4,22,139,13,196,11,12,250,22,132,9,2,13,6,13,13,108,
+74,195,249,22,4,22,141,13,196,11,12,250,22,132,9,2,13,6,13,13,108,
 105,115,116,32,111,102,32,112,97,116,104,115,197,250,2,47,197,195,28,248,22,
 159,6,197,248,22,170,7,197,196,32,50,89,162,8,44,39,57,2,18,222,33,
 53,32,51,89,162,8,44,38,54,70,102,111,117,110,100,45,101,120,101,99,222,
-33,52,28,23,193,2,91,159,38,11,90,161,38,35,11,248,22,160,13,23,199,
-2,87,95,23,195,1,23,194,1,27,28,23,198,2,27,248,22,165,13,23,201,
-2,28,249,22,166,8,23,195,2,23,202,2,11,28,248,22,161,13,23,194,2,
-250,2,51,23,201,2,23,202,2,249,22,157,13,23,200,2,23,198,1,250,2,
+33,52,28,23,193,2,91,159,38,11,90,161,38,35,11,248,22,162,13,23,199,
+2,87,95,23,195,1,23,194,1,27,28,23,198,2,27,248,22,167,13,23,201,
+2,28,249,22,166,8,23,195,2,23,202,2,11,28,248,22,163,13,23,194,2,
+250,2,51,23,201,2,23,202,2,249,22,159,13,23,200,2,23,198,1,250,2,
 51,23,201,2,23,202,2,23,196,1,11,28,23,193,2,192,87,94,23,193,1,
-27,28,248,22,139,13,23,196,2,27,249,22,157,13,23,198,2,23,201,2,28,
-28,248,22,152,13,193,10,248,22,151,13,193,192,11,11,28,23,193,2,192,87,
-94,23,193,1,28,23,199,2,11,27,248,22,165,13,23,202,2,28,249,22,166,
-8,23,195,2,23,203,1,11,28,248,22,161,13,23,194,2,250,2,51,23,202,
-1,23,203,1,249,22,157,13,23,201,1,23,198,1,250,2,51,201,202,195,194,
-28,248,22,73,23,197,2,11,27,248,22,164,13,248,22,66,23,199,2,27,249,
-22,157,13,23,196,1,23,197,2,28,248,22,151,13,23,194,2,250,2,51,198,
+27,28,248,22,141,13,23,196,2,27,249,22,159,13,23,198,2,23,201,2,28,
+28,248,22,154,13,193,10,248,22,153,13,193,192,11,11,28,23,193,2,192,87,
+94,23,193,1,28,23,199,2,11,27,248,22,167,13,23,202,2,28,249,22,166,
+8,23,195,2,23,203,1,11,28,248,22,163,13,23,194,2,250,2,51,23,202,
+1,23,203,1,249,22,159,13,23,201,1,23,198,1,250,2,51,201,202,195,194,
+28,248,22,73,23,197,2,11,27,248,22,166,13,248,22,66,23,199,2,27,249,
+22,159,13,23,196,1,23,197,2,28,248,22,153,13,23,194,2,250,2,51,198,
 199,195,87,94,23,193,1,27,248,22,67,23,200,1,28,248,22,73,23,194,2,
-11,27,248,22,164,13,248,22,66,23,196,2,27,249,22,157,13,23,196,1,23,
-200,2,28,248,22,151,13,23,194,2,250,2,51,201,202,195,87,94,23,193,1,
-27,248,22,67,23,197,1,28,248,22,73,23,194,2,11,27,248,22,164,13,248,
-22,66,195,27,249,22,157,13,23,196,1,202,28,248,22,151,13,193,250,2,51,
-204,205,195,251,2,50,204,205,206,248,22,67,199,87,95,28,27,248,22,139,13,
+11,27,248,22,166,13,248,22,66,23,196,2,27,249,22,159,13,23,196,1,23,
+200,2,28,248,22,153,13,23,194,2,250,2,51,201,202,195,87,94,23,193,1,
+27,248,22,67,23,197,1,28,248,22,73,23,194,2,11,27,248,22,166,13,248,
+22,66,195,27,249,22,159,13,23,196,1,202,28,248,22,153,13,193,250,2,51,
+204,205,195,251,2,50,204,205,206,248,22,67,199,87,95,28,27,248,22,141,13,
 23,196,2,28,23,193,2,192,87,94,23,193,1,28,248,22,159,6,23,196,2,
-27,248,22,161,13,23,197,2,28,23,193,2,192,87,94,23,193,1,248,22,162,
+27,248,22,163,13,23,197,2,28,23,193,2,192,87,94,23,193,1,248,22,164,
 13,23,197,2,11,12,250,22,132,9,2,14,6,25,25,112,97,116,104,32,111,
 114,32,115,116,114,105,110,103,32,40,115,97,110,115,32,110,117,108,41,23,197,
-2,28,28,23,195,2,28,27,248,22,139,13,23,197,2,28,23,193,2,192,87,
-94,23,193,1,28,248,22,159,6,23,197,2,27,248,22,161,13,23,198,2,28,
-23,193,2,192,87,94,23,193,1,248,22,162,13,23,198,2,11,248,22,161,13,
+2,28,28,23,195,2,28,27,248,22,141,13,23,197,2,28,23,193,2,192,87,
+94,23,193,1,28,248,22,159,6,23,197,2,27,248,22,163,13,23,198,2,28,
+23,193,2,192,87,94,23,193,1,248,22,164,13,23,198,2,11,248,22,163,13,
 23,196,2,11,10,12,250,22,132,9,2,14,6,29,29,35,102,32,111,114,32,
 114,101,108,97,116,105,118,101,32,112,97,116,104,32,111,114,32,115,116,114,105,
-110,103,23,198,2,28,28,248,22,161,13,23,195,2,91,159,38,11,90,161,38,
-35,11,248,22,160,13,23,198,2,249,22,164,8,194,68,114,101,108,97,116,105,
+110,103,23,198,2,28,28,248,22,163,13,23,195,2,91,159,38,11,90,161,38,
+35,11,248,22,162,13,23,198,2,249,22,164,8,194,68,114,101,108,97,116,105,
 118,101,11,27,248,22,176,7,6,4,4,80,65,84,72,251,2,50,23,199,1,
 23,200,1,23,201,1,28,23,197,2,27,249,80,159,43,47,37,23,200,1,9,
-28,249,22,164,8,247,22,178,7,2,20,249,22,65,248,22,148,13,5,1,46,
-23,195,1,192,9,27,248,22,164,13,23,196,1,28,248,22,151,13,193,250,2,
+28,249,22,164,8,247,22,178,7,2,20,249,22,65,248,22,150,13,5,1,46,
+23,195,1,192,9,27,248,22,166,13,23,196,1,28,248,22,153,13,193,250,2,
 51,198,199,195,11,250,80,158,38,48,196,197,11,250,80,158,38,48,196,11,11,
 87,94,249,22,150,6,247,22,186,4,195,248,22,176,5,249,22,172,3,35,249,
 22,156,3,197,198,27,28,23,197,2,87,95,23,196,1,23,195,1,23,197,1,
-87,94,23,197,1,27,248,22,178,13,2,19,27,249,80,159,40,48,37,23,196,
+87,94,23,197,1,27,248,22,180,13,2,19,27,249,80,159,40,48,37,23,196,
 1,11,27,27,248,22,175,3,23,200,1,28,192,192,35,27,27,248,22,175,3,
 23,202,1,28,192,192,35,249,22,153,5,23,197,1,83,158,39,20,97,95,89,
 162,8,44,35,47,9,224,3,2,33,57,23,195,1,23,196,1,27,248,22,138,
@@ -330,7 +330,7 @@
 36,43,2,11,222,33,43,80,159,35,45,36,83,158,35,16,2,83,158,38,20,
 96,96,2,12,89,162,43,35,43,9,223,0,33,44,89,162,43,36,44,9,223,
 0,33,45,89,162,43,37,54,9,223,0,33,46,80,159,35,46,36,83,158,35,
-16,2,27,248,22,185,13,248,22,170,7,27,28,249,22,164,8,247,22,178,7,
+16,2,27,248,22,187,13,248,22,170,7,27,28,249,22,164,8,247,22,178,7,
 2,20,6,1,1,59,6,1,1,58,250,22,143,7,6,14,14,40,91,94,126,
 97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,89,162,8,44,37,
 47,2,13,223,0,33,49,80,159,35,47,36,83,158,35,16,2,83,158,38,20,
@@ -342,7 +342,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 5009);
   }
   {
-    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,50,8,0,0,0,1,0,0,6,0,19,0,
+    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,51,8,0,0,0,1,0,0,6,0,19,0,
 34,0,48,0,62,0,76,0,111,0,0,0,1,1,0,0,65,113,117,111,116,
 101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37,
 110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122,
@@ -360,7 +360,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 294);
   }
   {
-    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,50,52,0,0,0,1,0,0,11,0,38,0,
+    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,51,52,0,0,0,1,0,0,11,0,38,0,
 44,0,57,0,71,0,93,0,119,0,131,0,149,0,169,0,181,0,197,0,220,
 0,0,1,5,1,10,1,15,1,24,1,29,1,60,1,64,1,72,1,81,1,
 89,1,192,1,237,1,1,2,30,2,61,2,117,2,127,2,174,2,184,2,191,
@@ -384,30 +384,30 @@
 63,108,105,98,67,105,103,110,111,114,101,100,249,22,14,195,80,159,37,45,37,
 249,80,159,37,48,36,195,10,27,28,23,195,2,28,249,22,164,8,23,197,2,
 80,158,38,46,87,94,23,195,1,80,158,36,47,27,248,22,173,4,23,197,2,
-28,248,22,139,13,23,194,2,91,159,38,11,90,161,38,35,11,248,22,160,13,
+28,248,22,141,13,23,194,2,91,159,38,11,90,161,38,35,11,248,22,162,13,
 23,197,1,87,95,83,160,37,11,80,158,40,46,198,83,160,37,11,80,158,40,
 47,192,192,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,191,4,28,
-192,192,247,22,179,13,20,14,159,80,158,35,39,250,80,158,38,40,249,22,27,
-11,80,158,40,39,22,191,4,28,248,22,139,13,23,198,2,23,197,1,87,94,
-23,197,1,247,22,179,13,247,194,250,22,157,13,23,197,1,23,199,1,249,80,
-158,42,38,23,198,1,2,17,252,22,157,13,23,199,1,23,201,1,2,18,247,
+192,192,247,22,181,13,20,14,159,80,158,35,39,250,80,158,38,40,249,22,27,
+11,80,158,40,39,22,191,4,28,248,22,141,13,23,198,2,23,197,1,87,94,
+23,197,1,247,22,181,13,247,194,250,22,159,13,23,197,1,23,199,1,249,80,
+158,42,38,23,198,1,2,17,252,22,159,13,23,199,1,23,201,1,2,18,247,
 22,179,7,249,80,158,44,38,23,200,1,80,159,44,35,37,87,94,23,194,1,
-27,250,22,174,13,196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249,
-22,65,195,194,11,27,252,22,157,13,23,200,1,23,202,1,2,18,247,22,179,
-7,249,80,158,45,38,23,201,1,80,159,45,35,37,27,250,22,174,13,196,11,
+27,250,22,176,13,196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249,
+22,65,195,194,11,27,252,22,159,13,23,200,1,23,202,1,2,18,247,22,179,
+7,249,80,158,45,38,23,201,1,80,159,45,35,37,27,250,22,176,13,196,11,
 32,0,89,162,8,44,35,40,9,222,11,28,192,249,22,65,195,194,11,249,247,
-22,184,13,248,22,66,195,195,27,250,22,157,13,23,198,1,23,200,1,249,80,
-158,43,38,23,199,1,2,17,27,250,22,174,13,196,11,32,0,89,162,8,44,
+22,186,13,248,22,66,195,195,27,250,22,159,13,23,198,1,23,200,1,249,80,
+158,43,38,23,199,1,2,17,27,250,22,176,13,196,11,32,0,89,162,8,44,
 35,40,9,222,11,28,192,249,22,65,195,194,11,249,247,22,189,4,248,22,66,
 195,195,249,247,22,189,4,194,195,87,94,28,248,80,158,36,37,23,195,2,12,
 250,22,132,9,77,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,
 100,6,25,25,112,97,116,104,32,111,114,32,118,97,108,105,100,45,112,97,116,
 104,32,115,116,114,105,110,103,23,197,2,91,159,41,11,90,161,36,35,11,28,
-248,22,163,13,23,201,2,23,200,1,27,247,22,191,4,28,23,193,2,249,22,
-164,13,23,203,1,23,195,1,200,90,161,38,36,11,248,22,160,13,23,194,2,
+248,22,165,13,23,201,2,23,200,1,27,247,22,191,4,28,23,193,2,249,22,
+166,13,23,203,1,23,195,1,200,90,161,38,36,11,248,22,162,13,23,194,2,
 87,94,23,196,1,90,161,36,39,11,28,249,22,164,8,23,196,2,68,114,101,
 108,97,116,105,118,101,87,94,23,194,1,2,16,23,194,1,90,161,36,40,11,
-247,22,181,13,27,89,162,43,36,49,62,122,111,225,7,5,3,33,27,27,89,
+247,22,183,13,27,89,162,43,36,49,62,122,111,225,7,5,3,33,27,27,89,
 162,43,36,51,9,225,8,6,4,33,28,27,249,22,5,89,162,8,44,36,46,
 9,223,5,33,29,23,203,2,27,28,23,195,1,27,249,22,5,89,162,8,44,
 36,52,9,225,13,11,9,33,30,23,205,2,27,28,23,196,2,11,193,28,192,
@@ -420,10 +420,10 @@
 203,89,162,43,35,45,9,224,15,2,33,33,249,80,159,48,54,36,203,89,162,
 43,35,44,9,224,15,7,33,34,32,36,89,162,8,44,36,54,2,19,222,33,
 38,0,17,35,114,120,34,94,40,46,42,63,41,47,40,46,42,41,36,34,27,
-249,22,189,13,2,37,23,196,2,28,23,193,2,87,94,23,194,1,249,22,65,
-248,22,90,23,196,2,27,248,22,99,23,197,1,27,249,22,189,13,2,37,23,
+249,22,191,13,2,37,23,196,2,28,23,193,2,87,94,23,194,1,249,22,65,
+248,22,90,23,196,2,27,248,22,99,23,197,1,27,249,22,191,13,2,37,23,
 196,2,28,23,193,2,87,94,23,194,1,249,22,65,248,22,90,23,196,2,27,
-248,22,99,23,197,1,27,249,22,189,13,2,37,23,196,2,28,23,193,2,87,
+248,22,99,23,197,1,27,249,22,191,13,2,37,23,196,2,28,23,193,2,87,
 94,23,194,1,249,22,65,248,22,90,23,196,2,248,2,36,248,22,99,23,197,
 1,248,22,75,194,248,22,75,194,248,22,75,194,32,39,89,162,43,36,54,2,
 19,222,33,40,28,248,22,73,248,22,67,23,195,2,249,22,7,9,248,22,66,
@@ -437,19 +437,19 @@
 39,193,87,95,28,248,22,171,4,195,12,250,22,132,9,2,20,6,20,20,114,
 101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97,116,104,197,28,
 24,193,2,248,24,194,1,195,87,94,23,193,1,12,27,27,250,22,139,2,80,
-159,41,42,37,248,22,145,14,247,22,186,11,11,28,23,193,2,192,87,94,23,
-193,1,27,247,22,123,87,94,250,22,137,2,80,159,42,42,37,248,22,145,14,
-247,22,186,11,195,192,250,22,137,2,195,198,66,97,116,116,97,99,104,251,211,
+159,41,42,37,248,22,147,14,247,22,188,11,11,28,23,193,2,192,87,94,23,
+193,1,27,247,22,123,87,94,250,22,137,2,80,159,42,42,37,248,22,147,14,
+247,22,188,11,195,192,250,22,137,2,195,198,66,97,116,116,97,99,104,251,211,
 197,198,199,10,28,192,250,22,131,9,11,196,195,248,22,129,9,194,28,249,22,
 165,6,194,6,1,1,46,2,16,28,249,22,165,6,194,6,2,2,46,46,62,
 117,112,192,28,249,22,166,8,248,22,67,23,200,2,23,197,1,28,249,22,164,
 8,248,22,66,23,200,2,23,196,1,251,22,129,9,2,20,6,26,26,99,121,
 99,108,101,32,105,110,32,108,111,97,100,105,110,103,32,97,116,32,126,101,58,
 32,126,101,23,200,1,249,22,2,22,67,248,22,80,249,22,65,23,206,1,23,
-202,1,12,12,247,192,20,14,159,80,159,39,44,37,249,22,65,248,22,145,14,
-247,22,186,11,23,197,1,20,14,159,80,158,39,39,250,80,158,42,40,249,22,
+202,1,12,12,247,192,20,14,159,80,159,39,44,37,249,22,65,248,22,147,14,
+247,22,188,11,23,197,1,20,14,159,80,158,39,39,250,80,158,42,40,249,22,
 27,11,80,158,44,39,22,153,4,23,196,1,249,247,22,190,4,23,198,1,248,
-22,54,248,22,143,13,23,198,1,87,94,28,28,248,22,139,13,23,197,2,10,
+22,54,248,22,145,13,23,198,1,87,94,28,28,248,22,141,13,23,197,2,10,
 248,22,177,4,23,197,2,12,28,23,198,2,250,22,131,9,11,6,15,15,98,
 97,100,32,109,111,100,117,108,101,32,112,97,116,104,23,201,2,250,22,132,9,
 2,20,6,19,19,109,111,100,117,108,101,45,112,97,116,104,32,111,114,32,112,
@@ -457,74 +457,74 @@
 23,199,2,2,3,11,248,22,172,4,248,22,90,197,28,28,248,22,63,23,197,
 2,249,22,164,8,248,22,66,23,199,2,66,112,108,97,110,101,116,11,87,94,
 28,207,12,20,14,159,80,158,37,39,250,80,158,40,40,249,22,27,11,80,158,
-42,39,22,186,11,23,197,1,90,161,36,35,10,249,22,154,4,21,94,2,21,
+42,39,22,188,11,23,197,1,90,161,36,35,10,249,22,154,4,21,94,2,21,
 6,18,18,112,108,97,110,101,116,47,114,101,115,111,108,118,101,114,46,115,115,
 1,27,112,108,97,110,101,116,45,109,111,100,117,108,101,45,110,97,109,101,45,
 114,101,115,111,108,118,101,114,12,251,211,199,200,201,202,87,94,23,193,1,27,
 89,162,8,44,36,45,79,115,104,111,119,45,99,111,108,108,101,99,116,105,111,
 110,45,101,114,114,223,6,33,44,27,28,248,22,53,23,199,2,27,250,22,139,
-2,80,159,43,43,37,249,22,65,23,204,2,247,22,180,13,11,28,23,193,2,
+2,80,159,43,43,37,249,22,65,23,204,2,247,22,182,13,11,28,23,193,2,
 192,87,94,23,193,1,91,159,37,11,90,161,37,35,11,249,80,159,44,48,36,
 248,22,56,23,204,2,11,27,251,80,158,47,50,2,20,23,202,1,28,248,22,
 73,23,199,2,23,199,2,248,22,66,23,199,2,28,248,22,73,23,199,2,9,
-248,22,67,23,199,2,249,22,157,13,23,195,1,28,248,22,73,23,197,1,87,
+248,22,67,23,199,2,249,22,159,13,23,195,1,28,248,22,73,23,197,1,87,
 94,23,197,1,6,7,7,109,97,105,110,46,115,115,249,22,182,6,23,199,1,
 6,3,3,46,115,115,28,248,22,159,6,23,199,2,87,94,23,194,1,27,248,
 80,159,41,55,36,23,201,2,27,250,22,139,2,80,159,44,43,37,249,22,65,
 23,205,2,23,199,2,11,28,23,193,2,192,87,94,23,193,1,91,159,37,11,
-90,161,37,35,11,249,80,159,45,48,36,23,204,2,11,250,22,1,22,157,13,
+90,161,37,35,11,249,80,159,45,48,36,23,204,2,11,250,22,1,22,159,13,
 23,199,1,249,22,79,249,22,2,32,0,89,162,8,44,36,43,9,222,33,45,
-23,200,1,248,22,75,23,200,1,28,248,22,139,13,23,199,2,87,94,23,194,
-1,28,248,22,162,13,23,199,2,23,198,2,248,22,75,6,26,26,32,40,97,
+23,200,1,248,22,75,23,200,1,28,248,22,141,13,23,199,2,87,94,23,194,
+1,28,248,22,164,13,23,199,2,23,198,2,248,22,75,6,26,26,32,40,97,
 32,112,97,116,104,32,109,117,115,116,32,98,101,32,97,98,115,111,108,117,116,
 101,41,28,249,22,164,8,248,22,66,23,201,2,2,21,27,250,22,139,2,80,
-159,43,43,37,249,22,65,23,204,2,247,22,180,13,11,28,23,193,2,192,87,
+159,43,43,37,249,22,65,23,204,2,247,22,182,13,11,28,23,193,2,192,87,
 94,23,193,1,91,159,38,11,90,161,37,35,11,249,80,159,45,48,36,248,22,
 90,23,205,2,11,90,161,36,37,11,28,248,22,73,248,22,92,23,204,2,28,
-248,22,73,23,194,2,249,22,191,13,0,8,35,114,120,34,91,46,93,34,23,
+248,22,73,23,194,2,249,22,129,14,0,8,35,114,120,34,91,46,93,34,23,
 196,2,11,10,27,27,28,23,197,2,249,22,79,28,248,22,73,248,22,92,23,
 208,2,21,93,6,5,5,109,122,108,105,98,249,22,1,22,79,249,22,2,80,
 159,51,56,36,248,22,92,23,211,2,23,197,2,28,248,22,73,23,196,2,248,
 22,75,23,197,2,23,195,2,251,80,158,49,50,2,20,23,204,1,248,22,66,
-23,198,2,248,22,67,23,198,1,249,22,157,13,23,195,1,28,23,198,1,87,
+23,198,2,248,22,67,23,198,1,249,22,159,13,23,195,1,28,23,198,1,87,
 94,23,196,1,23,197,1,28,248,22,73,23,197,1,87,94,23,197,1,6,7,
-7,109,97,105,110,46,115,115,28,249,22,191,13,0,8,35,114,120,34,91,46,
+7,109,97,105,110,46,115,115,28,249,22,129,14,0,8,35,114,120,34,91,46,
 93,34,23,199,2,23,197,1,249,22,182,6,23,199,1,6,3,3,46,115,115,
-28,249,22,164,8,248,22,66,23,201,2,64,102,105,108,101,249,22,164,13,248,
-22,168,13,248,22,90,23,202,2,248,80,159,42,55,36,23,202,2,12,87,94,
-28,28,248,22,139,13,23,194,2,10,248,22,181,7,23,194,2,87,94,23,200,
+28,249,22,164,8,248,22,66,23,201,2,64,102,105,108,101,249,22,166,13,248,
+22,170,13,248,22,90,23,202,2,248,80,159,42,55,36,23,202,2,12,87,94,
+28,28,248,22,141,13,23,194,2,10,248,22,181,7,23,194,2,87,94,23,200,
 1,12,28,23,200,2,250,22,131,9,67,114,101,113,117,105,114,101,249,22,143,
 7,6,17,17,98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,126,97,
 28,23,198,2,248,22,66,23,199,2,6,0,0,23,203,1,87,94,23,200,1,
 250,22,132,9,2,20,249,22,143,7,6,13,13,109,111,100,117,108,101,32,112,
 97,116,104,126,97,28,23,198,2,248,22,66,23,199,2,6,0,0,23,201,2,
-27,28,248,22,181,7,23,195,2,249,22,186,7,23,196,2,35,249,22,166,13,
-248,22,167,13,23,197,2,11,27,28,248,22,181,7,23,196,2,249,22,186,7,
+27,28,248,22,181,7,23,195,2,249,22,186,7,23,196,2,35,249,22,168,13,
+248,22,169,13,23,197,2,11,27,28,248,22,181,7,23,196,2,249,22,186,7,
 23,197,2,36,248,80,158,42,51,23,195,2,91,159,38,11,90,161,38,35,11,
 28,248,22,181,7,23,199,2,250,22,7,2,22,249,22,186,7,23,203,2,37,
-2,22,248,22,160,13,23,198,2,87,95,23,195,1,23,193,1,27,28,248,22,
+2,22,248,22,162,13,23,198,2,87,95,23,195,1,23,193,1,27,28,248,22,
 181,7,23,200,2,249,22,186,7,23,201,2,38,249,80,158,47,52,23,197,2,
 5,0,27,28,248,22,181,7,23,201,2,249,22,186,7,23,202,2,39,248,22,
-172,4,23,200,2,27,27,250,22,139,2,80,159,51,42,37,248,22,145,14,247,
-22,186,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,123,87,94,250,
-22,137,2,80,159,52,42,37,248,22,145,14,247,22,186,11,195,192,87,95,28,
+172,4,23,200,2,27,27,250,22,139,2,80,159,51,42,37,248,22,147,14,247,
+22,188,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,123,87,94,250,
+22,137,2,80,159,52,42,37,248,22,147,14,247,22,188,11,195,192,87,95,28,
 23,209,1,27,250,22,139,2,23,197,2,197,11,28,23,193,1,12,87,95,27,
 27,28,248,22,17,80,159,51,45,37,80,159,50,45,37,247,22,19,250,22,25,
-248,22,23,23,197,2,80,159,53,44,37,23,196,1,27,248,22,145,14,247,22,
-186,11,249,22,3,83,158,39,20,97,94,89,162,8,44,36,54,9,226,12,11,
+248,22,23,23,197,2,80,159,53,44,37,23,196,1,27,248,22,147,14,247,22,
+188,11,249,22,3,83,158,39,20,97,94,89,162,8,44,36,54,9,226,12,11,
 2,3,33,46,23,195,1,23,196,1,248,28,248,22,17,80,159,50,45,37,32,
 0,89,162,43,36,41,9,222,33,47,80,159,49,57,36,89,162,43,35,50,9,
 227,14,9,8,4,3,33,48,250,22,137,2,23,197,1,197,10,12,28,28,248,
 22,181,7,23,202,1,11,27,248,22,159,6,23,208,2,28,192,192,28,248,22,
 63,23,208,2,249,22,164,8,248,22,66,23,210,2,2,21,11,250,22,137,2,
 80,159,50,43,37,28,248,22,159,6,23,210,2,249,22,65,23,211,1,248,80,
-159,53,55,36,23,213,1,87,94,23,210,1,249,22,65,23,211,1,247,22,180,
+159,53,55,36,23,213,1,87,94,23,210,1,249,22,65,23,211,1,247,22,182,
 13,252,22,183,7,23,208,1,23,207,1,23,205,1,23,203,1,201,12,193,91,
 159,37,10,90,161,36,35,10,11,90,161,36,36,10,83,158,38,20,96,96,2,
 20,89,162,8,44,36,50,9,224,2,0,33,42,89,162,43,38,48,9,223,1,
 33,43,89,162,43,39,8,30,9,225,2,3,0,33,49,208,87,95,248,22,152,
-4,248,80,159,37,49,37,247,22,186,11,248,22,190,4,80,159,36,36,37,248,
-22,177,12,80,159,36,41,36,159,35,20,103,159,35,16,1,11,16,0,83,158,
+4,248,80,159,37,49,37,247,22,188,11,248,22,190,4,80,159,36,36,37,248,
+22,179,12,80,159,36,41,36,159,35,20,103,159,35,16,1,11,16,0,83,158,
 41,20,100,143,66,35,37,98,111,111,116,29,11,11,11,11,10,10,36,80,158,
 35,35,20,103,159,39,16,19,2,1,2,2,30,2,4,72,112,97,116,104,45,
 115,116,114,105,110,103,63,10,30,2,4,75,112,97,116,104,45,97,100,100,45,
diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c
index 645e0aabe7..42999c5960 100644
--- a/src/mzscheme/src/env.c
+++ b/src/mzscheme/src/env.c
@@ -92,6 +92,7 @@ static Scheme_Object *variable_top_level_namespace(int, Scheme_Object *[]);
 static Scheme_Object *variable_phase(int, Scheme_Object *[]);
 static Scheme_Object *now_transforming(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_exp_time_value(int argc, Scheme_Object *argv[]);
+static Scheme_Object *local_exp_time_value_one(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_exp_time_name(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_context(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_phase_level(int argc, Scheme_Object *argv[]);
@@ -522,6 +523,7 @@ static void make_kernel_env(void)
 
   GLOBAL_PRIM_W_ARITY("syntax-transforming?", now_transforming, 0, 0, env);
   GLOBAL_PRIM_W_ARITY("syntax-local-value", local_exp_time_value, 1, 3, env);
+  GLOBAL_PRIM_W_ARITY("syntax-local-value/immediate", local_exp_time_value_one, 1, 3, env);
   GLOBAL_PRIM_W_ARITY("syntax-local-name", local_exp_time_name, 0, 0, env);
   GLOBAL_PRIM_W_ARITY("syntax-local-context", local_context, 0, 0, env);
   GLOBAL_PRIM_W_ARITY("syntax-local-phase-level", local_phase_level, 0, 0, env);
@@ -1179,9 +1181,9 @@ void scheme_shadow(Scheme_Env *env, Scheme_Object *n, int stxtoo)
       v = scheme_lookup_in_table(env->syntax, (const char *)n);
       if (v) {
         v = SCHEME_PTR_VAL(v);
-        if (SAME_TYPE(SCHEME_TYPE(v), scheme_id_macro_type)) {
+        if (scheme_is_binding_rename_transformer(v)) {
           scheme_install_free_id_rename(n, 
-                                        SCHEME_PTR1_VAL(v), 
+                                        scheme_rename_transformer_id(v), 
                                         rn, 
                                         scheme_make_integer(env->phase));
         }
@@ -4169,9 +4171,9 @@ now_transforming(int argc, Scheme_Object *argv[])
 }
 
 static Scheme_Object *
-local_exp_time_value(int argc, Scheme_Object *argv[])
+do_local_exp_time_value(const char *name, int argc, Scheme_Object *argv[], int recur)
 {
-  Scheme_Object *v, *sym;
+  Scheme_Object *v, *sym, *a[2];
   Scheme_Env *menv;
   Scheme_Comp_Env *env;
   int renamed = 0;
@@ -4179,24 +4181,26 @@ local_exp_time_value(int argc, Scheme_Object *argv[])
   env = scheme_current_thread->current_local_env;
   if (!env)
     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
-		     "syntax-local-value: not currently transforming");
+		     "%s: not currently transforming",
+                     name);
 
   sym = argv[0];
 
   if (!(SCHEME_STXP(sym) && SCHEME_SYMBOLP(SCHEME_STX_VAL(sym))))
-    scheme_wrong_type("syntax-local-value", "syntax identifier", 0, argc, argv);
+    scheme_wrong_type(name, "syntax identifier", 0, argc, argv);
 
   if (argc > 1) {
-    scheme_check_proc_arity2("syntax-local-value", 0, 1, argc, argv, 1);
+    scheme_check_proc_arity2(name, 0, 1, argc, argv, 1);
     if ((argc > 2)
         && SCHEME_TRUEP(argv[2])) { 
       Scheme_Comp_Env *stx_env;
       if (!SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[2])))
-	scheme_wrong_type("syntax-local-value", "internal-definition context or #f", 2, argc, argv);
+	scheme_wrong_type(name, "internal-definition context or #f", 2, argc, argv);
       stx_env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(argv[2]);
       if (!scheme_is_sub_env(stx_env, env)) {
-	scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-value: transforming context does "
-			 "not match given internal-definition context");
+	scheme_raise_exn(MZEXN_FAIL_CONTRACT, "%s: transforming context does "
+			 "not match given internal-definition context",
+                         name);
       }
       env = stx_env;
     }
@@ -4227,7 +4231,7 @@ local_exp_time_value(int argc, Scheme_Object *argv[])
       if ((argc > 1) && SCHEME_TRUEP(argv[1]))
 	return _scheme_tail_apply(argv[1], 0, NULL);
       else
-	scheme_arg_mismatch("syntax-local-value",
+	scheme_arg_mismatch(name,
 			    (renamed 
 			     ? "not defined as syntax (after renaming): "
 			     : "not defined as syntax: "),
@@ -4235,17 +4239,38 @@ local_exp_time_value(int argc, Scheme_Object *argv[])
     }
     
     v = SCHEME_PTR_VAL(v);
-    if (SAME_TYPE(SCHEME_TYPE(v), scheme_id_macro_type)) {
-      sym = SCHEME_PTR1_VAL(v);
+    if (scheme_is_rename_transformer(v)) {
+      sym = scheme_rename_transformer_id(v);
       sym = scheme_stx_cert(sym, scheme_false, menv, sym, NULL, 1);
       renamed = 1;
       menv = NULL;
       SCHEME_USE_FUEL(1);
+      if (!recur) {
+        a[0] = v;
+        a[1] = sym;
+        return scheme_values(2, a);
+      }
+    } else if (!recur) {
+      a[0] = v;
+      a[1] = scheme_false;
+      return scheme_values(2, a);
     } else
       return v;
   }
 }
 
+static Scheme_Object *
+local_exp_time_value(int argc, Scheme_Object *argv[])
+{
+  return do_local_exp_time_value("syntax-local-value", argc, argv, 1);
+}
+
+static Scheme_Object *
+local_exp_time_value_one(int argc, Scheme_Object *argv[])
+{
+  return do_local_exp_time_value("syntax-local-value/immediate", argc, argv, 0);
+}
+
 static Scheme_Object *
 local_exp_time_name(int argc, Scheme_Object *argv[])
 {
@@ -4675,10 +4700,10 @@ local_make_delta_introduce(int argc, Scheme_Object *argv[])
     introducers = scheme_make_pair(introducer, introducers);
     
     v = SCHEME_PTR_VAL(v);
-    if (SAME_TYPE(SCHEME_TYPE(v), scheme_id_macro_type)) {
+    if (scheme_is_rename_transformer(v)) {
       certs = scheme_stx_extract_certs(sym, certs);
 
-      sym = SCHEME_PTR1_VAL(v);
+      sym = scheme_rename_transformer_id(v);
       sym = scheme_stx_activate_certs(sym);
 
       v = SCHEME_PTR2_VAL(v);
@@ -5039,7 +5064,7 @@ make_set_transformer(int argc, Scheme_Object *argv[])
 static Scheme_Object *
 set_transformer_p(int argc, Scheme_Object *argv[])
 {
-  return ((SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_set_macro_type))
+  return (scheme_is_set_transformer(argv[0])
 	  ? scheme_true
 	  : scheme_false);
 }
@@ -5047,10 +5072,10 @@ set_transformer_p(int argc, Scheme_Object *argv[])
 static Scheme_Object *
 set_transformer_proc(int argc, Scheme_Object *argv[])
 {
-  if (!(SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_set_macro_type)))
+  if (!scheme_is_set_transformer(argv[0]))
     scheme_wrong_type("set!-transformer-procedure", "set!-transformer", 1, argc, argv);
 
-  return SCHEME_PTR_VAL(argv[0]);
+  return scheme_set_transformer_proc(argv[0]);
 }
 
 static Scheme_Object *
@@ -5075,16 +5100,16 @@ make_rename_transformer(int argc, Scheme_Object *argv[])
 static Scheme_Object *
 rename_transformer_target(int argc, Scheme_Object *argv[])
 {
-  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_id_macro_type))
+  if (!scheme_is_rename_transformer(argv[0]))
     scheme_wrong_type("rename-transformer-target", "rename transformer", 0, argc, argv);
 
-  return SCHEME_PTR_VAL(argv[0]);
+  return scheme_rename_transformer_id(argv[0]);
 }
 
 static Scheme_Object *
 rename_transformer_p(int argc, Scheme_Object *argv[])
 {
-  return ((SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_id_macro_type))
+  return (scheme_is_rename_transformer(argv[0])
 	  ? scheme_true
 	  : scheme_false);
 }
diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c
index 5727de38cd..dcb3562b7a 100644
--- a/src/mzscheme/src/eval.c
+++ b/src/mzscheme/src/eval.c
@@ -5204,9 +5204,10 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
         SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first);
         return first;
       } else if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) {
-        if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(val)), scheme_id_macro_type)) {
+        if (scheme_is_rename_transformer(SCHEME_PTR_VAL(val))) {
           /* It's a rename. Look up the target name and try again. */
-          name = scheme_stx_cert(SCHEME_PTR_VAL(SCHEME_PTR_VAL(val)), scheme_false, menv, name, NULL, 1);
+          name = scheme_stx_cert(scheme_rename_transformer_id(SCHEME_PTR_VAL(val)), 
+                                 scheme_false, menv, name, NULL, 1);
           menv = NULL;
           SCHEME_USE_FUEL(1);
         } else {
@@ -5247,7 +5248,7 @@ compile_expand_macro_app(Scheme_Object *name, Scheme_Env *menv, Scheme_Object *m
 
   xformer = (Scheme_Object *)SCHEME_PTR_VAL(macro);
 
-  if (SAME_TYPE(SCHEME_TYPE(xformer), scheme_set_macro_type)) {
+  if (scheme_is_set_transformer(xformer)) {
     /* scheme_apply_macro unwraps it */
   } else {
     if (!scheme_check_proc_arity(NULL, 1, 0, -1, &xformer)) {
@@ -5402,10 +5403,10 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
         SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer,find_name);
 
 	if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
-	    && SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) {
+	    && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) {
 	  /* It's a rename. Look up the target name and try again. */
 	  Scheme_Object *new_name;
-	  new_name = SCHEME_PTR_VAL(SCHEME_PTR_VAL(var));
+	  new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var));
 	  if (!rec[drec].comp) {
 	    new_name = scheme_stx_track(new_name, find_name, find_name);
 	  }
@@ -5508,10 +5509,10 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
 
         SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name);
 	if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
-	    && SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) {
+	    && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) {
 	  /* It's a rename. Look up the target name and try again. */
 	  Scheme_Object *new_name;
-	  new_name = SCHEME_PTR_VAL(SCHEME_PTR_VAL(var));
+	  new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var));
 	  if (!rec[drec].comp) {
 	    new_name = scheme_stx_track(new_name, find_name, find_name);
 	  }
@@ -5595,10 +5596,10 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
       SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name);
 
       if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
-	  && SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) {
+	  && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) {
 	/* It's a rename. Look up the target name and try again. */
 	Scheme_Object *new_name;
-	new_name = SCHEME_PTR_VAL(SCHEME_PTR_VAL(var));
+	new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var));
 	if (!rec[drec].comp) {
 	  new_name = scheme_stx_track(new_name, find_name, find_name);
 	}
diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c
index df919cb3a5..a768c6c5a4 100644
--- a/src/mzscheme/src/fun.c
+++ b/src/mzscheme/src/fun.c
@@ -2603,10 +2603,10 @@ scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv,
   Scheme_Object *certs;
   certs = rec[drec].certs;
 
-  if (SAME_TYPE(SCHEME_TYPE(rator), scheme_id_macro_type)) {
+  if (scheme_is_rename_transformer(rator)) {
     Scheme_Object *mark;
    
-    rator = SCHEME_PTR1_VAL(rator);
+    rator = scheme_rename_transformer_id(rator);
     /* rator is now an identifier */
 
     /* and it's introduced by this expression: */
@@ -2639,8 +2639,8 @@ scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv,
 
     certs = scheme_stx_extract_certs(code, certs);
  
-    if (SAME_TYPE(SCHEME_TYPE(rator), scheme_set_macro_type))
-      rator = SCHEME_PTR_VAL(rator);
+    if (scheme_is_set_transformer(rator))
+      rator = scheme_set_transformer_proc(rator);
 
     mark = scheme_new_mark();
     code = scheme_add_remove_mark(code, mark);
diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c
index a8cba4d810..58d5157fdf 100644
--- a/src/mzscheme/src/module.c
+++ b/src/mzscheme/src/module.c
@@ -4519,8 +4519,8 @@ static void eval_exptime(Scheme_Object *names, int count,
 	  SCHEME_PTR_VAL(macro) = values[i];
 
           if (SCHEME_TRUEP(free_id_rename_rn)
-              && SAME_TYPE(SCHEME_TYPE(values[i]), scheme_id_macro_type))
-            scheme_install_free_id_rename(name, SCHEME_PTR1_VAL(values[i]), free_id_rename_rn, 
+              && scheme_is_binding_rename_transformer(values[i]))
+            scheme_install_free_id_rename(name, scheme_rename_transformer_id(values[i]), free_id_rename_rn, 
                                           scheme_make_integer(0));
 	} else
 	  macro = values[i];
@@ -4539,8 +4539,8 @@ static void eval_exptime(Scheme_Object *names, int count,
       SCHEME_PTR_VAL(macro) = vals;
 
       if (SCHEME_TRUEP(free_id_rename_rn)
-          && SAME_TYPE(SCHEME_TYPE(vals), scheme_id_macro_type))
-        scheme_install_free_id_rename(name, SCHEME_PTR1_VAL(vals), free_id_rename_rn, 
+          && scheme_is_binding_rename_transformer(vals))
+        scheme_install_free_id_rename(name, scheme_rename_transformer_id(vals), free_id_rename_rn, 
                                       scheme_make_integer(0));
     } else
       macro = vals;
@@ -7334,6 +7334,69 @@ static Scheme_Object *adjust_for_rename(Scheme_Object *out_name, Scheme_Object *
   return first;
 }
 
+static Scheme_Object *extract_free_id_name(Scheme_Object *name,
+                                           Scheme_Object *phase,
+                                           Scheme_Env *genv,
+                                           int always,
+                                           int *_implicit,
+                                           Scheme_Object **_implicit_src,
+                                           Scheme_Object **_implicit_src_name,
+                                           Scheme_Object **_implicit_mod_phase,
+                                           Scheme_Object **_implicit_nominal_name,
+                                           Scheme_Object **_implicit_nominal_mod)
+{
+  *_implicit = 0;
+
+  while (1) { /* loop for free-id=? renaming */
+    if (SCHEME_STXP(name)) {
+      if (genv
+          && (always
+              || SAME_OBJ(phase, scheme_make_integer(0))
+              || SAME_OBJ(phase, scheme_make_integer(1))))
+        name = scheme_tl_id_sym(genv, name, NULL, -1, phase, NULL);
+      else
+        name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */
+    }
+    
+    /* Check for free-id=? renaming: */
+    if (SAME_OBJ(phase, scheme_make_integer(0))) {
+      Scheme_Object *v2;
+      v2 = scheme_lookup_in_table(genv->syntax, (const char *)name);
+      if (v2 && scheme_is_binding_rename_transformer(SCHEME_PTR_VAL(v2))) {
+        Scheme_Object *name2;
+        Scheme_Object *mod, *id;
+
+        name2 = scheme_rename_transformer_id(SCHEME_PTR_VAL(v2));
+        id = name2;
+        mod = scheme_stx_module_name(0, &id, phase, 
+                                     _implicit_nominal_mod, _implicit_nominal_name,
+                                     _implicit_mod_phase, 
+                                     NULL, NULL, NULL, NULL);
+        if (SAME_TYPE(SCHEME_TYPE(mod), scheme_module_index_type)) {
+          if (SCHEME_FALSEP(((Scheme_Modidx *)mod)->path)) {
+            /* keep looking locally */
+            name = name2;
+            SCHEME_USE_FUEL(1);
+          } else {
+            /* free-id=? equivalence to a name that is not necessarily imported explicitly */
+            if (_implicit_src) {
+              *_implicit_src = mod;
+              *_implicit_src_name = id;
+            }
+            *_implicit = 1;
+            break;
+          }
+        } else
+          break;
+      } else
+        break;
+    } else
+      break;
+  }
+
+  return name;
+}
+
 char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables,
                              Scheme_Module_Exports *me,
                              Scheme_Env *genv,
@@ -7341,13 +7404,15 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table
                              Scheme_Object *form,
                              char **_phase1_protects)
 {
-  int i, count, z;
+  int i, count, z, implicit;
   Scheme_Object **exs, **exsns, **exss, **exsnoms, *phase;
   Scheme_Hash_Table *provided, *required;
   char *exps, *exets, *phase0_exps = NULL, *phase1_exps = NULL;
   int excount, exvcount;
   Scheme_Module_Phase_Exports *pt;
-  
+  Scheme_Object *implicit_src, *implicit_src_name, *implicit_mod_phase;
+  Scheme_Object *implicit_nominal_name, *implicit_nominal_mod;
+
   for (z = 0; z < all_provided->size; z++) {
     provided = (Scheme_Hash_Table *)all_provided->vals[z];
 
@@ -7400,16 +7465,13 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table
           v = provided->vals[i]; /* external name */
           name = SCHEME_CAR(v);  /* internal name (maybe already a symbol) */
           protected = SCHEME_TRUEP(SCHEME_CDR(v));
-
           prnt_name = name;
-          if (SCHEME_STXP(name)) {
-            if (genv)
-              name = scheme_tl_id_sym(genv, name, NULL, -1, phase, NULL);
-            else
-              name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */
-          }
 
-          if (genv 
+          name = extract_free_id_name(name, phase, genv, 1, &implicit, 
+                                      NULL, NULL, NULL, NULL, NULL);
+
+          if (!implicit
+              && genv 
               && (SAME_OBJ(phase, scheme_make_integer(0))
                   || SAME_OBJ(phase, scheme_make_integer(1)))
               && scheme_lookup_in_table(SAME_OBJ(phase, scheme_make_integer(0))
@@ -7425,10 +7487,13 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table
             if (SAME_OBJ(phase, scheme_make_integer(1)))
               exets[count] = 1;
             count++;
-          } else if (genv 
+          } else if (!implicit
+                     && genv 
                      && SAME_OBJ(phase, scheme_make_integer(0))
                      && scheme_lookup_in_table(genv->syntax, (const char *)name)) {
-            /* Skip for now. */
+            /* Skip syntax for now. */
+          } else if (implicit) {
+            /* Rename-transformer redirect; skip for now. */
           } else if ((v = scheme_hash_get(required, name))) {
             /* Required */
             if (protected) {
@@ -7473,17 +7538,13 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table
           name = SCHEME_CAR(v); /* internal name (maybe already a symbol) */
           protected = SCHEME_TRUEP(SCHEME_CDR(v));
 
-          if (SCHEME_STXP(name)) {
-            if (genv
-                && (SAME_OBJ(phase, scheme_make_integer(0))
-                    || SAME_OBJ(phase, scheme_make_integer(1))))
-              name = scheme_tl_id_sym(genv, name, NULL, -1, phase, NULL);
-            else {
-              name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */
-            }
-          }
+          name = extract_free_id_name(name, phase, genv, 0, &implicit,
+                                      &implicit_src, &implicit_src_name, 
+                                      &implicit_mod_phase,
+                                      &implicit_nominal_name, &implicit_nominal_mod);
 
-          if (genv 
+          if (!implicit
+              && genv 
               && SAME_OBJ(phase, scheme_make_integer(0))
               && scheme_lookup_in_table(genv->syntax, (const char *)name)) {
             /* Defined locally */
@@ -7493,6 +7554,16 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table
             exsnoms[count] = scheme_null; /* since "self" */
             exps[count] = protected;
             count++;
+          } else if (implicit) {
+            /* We record all free-id=?-based exprts as synatx, even though they may be values. */
+            Scheme_Object *noms;
+            exs[count] = provided->keys[i];
+            exsns[count] = implicit_src_name;
+            exss[count] = implicit_src;
+            noms = adjust_for_rename(exs[count], implicit_nominal_name, cons(implicit_nominal_mod, scheme_null));
+            exsnoms[count] = noms;
+            exps[count] = protected;            
+            count++;
           } else if ((v = scheme_hash_get(required, name))) {
             /* Required */
             if (SCHEME_FALSEP(SCHEME_VEC_ELS(v)[3])) {
diff --git a/src/mzscheme/src/schminc.h b/src/mzscheme/src/schminc.h
index 448a7dfaad..519ede6b74 100644
--- a/src/mzscheme/src/schminc.h
+++ b/src/mzscheme/src/schminc.h
@@ -13,7 +13,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 947
+#define EXPECTED_PRIM_COUNT 950
 
 #ifdef MZSCHEME_SOMETHING_OMITTED
 # undef USE_COMPILED_STARTUP
diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h
index 3c7920e318..7c9b7cc040 100644
--- a/src/mzscheme/src/schpriv.h
+++ b/src/mzscheme/src/schpriv.h
@@ -2515,6 +2515,12 @@ void scheme_unmarshal_wrap_set(Scheme_Unmarshal_Tables *ut,
                                Scheme_Object *wraps_key, 
                                Scheme_Object *v);
 
+int scheme_is_rename_transformer(Scheme_Object *o);
+int scheme_is_binding_rename_transformer(Scheme_Object *o);
+Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o);
+int scheme_is_set_transformer(Scheme_Object *o);
+Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o);
+
 /*========================================================================*/
 /*                         namespaces and modules                         */
 /*========================================================================*/
diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h
index 6aabc11135..3b6a3749fc 100644
--- a/src/mzscheme/src/schvers.h
+++ b/src/mzscheme/src/schvers.h
@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "4.1.5.2"
+#define MZSCHEME_VERSION "4.1.5.3"
 
 #define MZSCHEME_VERSION_X 4
 #define MZSCHEME_VERSION_Y 1
 #define MZSCHEME_VERSION_Z 5
-#define MZSCHEME_VERSION_W 2
+#define MZSCHEME_VERSION_W 3
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)
diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c
index 8c0c3d0753..d3f23a65ab 100644
--- a/src/mzscheme/src/struct.c
+++ b/src/mzscheme/src/struct.c
@@ -70,6 +70,8 @@ static Scheme_Object *check_equal_property_value_ok(int argc, Scheme_Object *arg
 static Scheme_Object *check_write_property_value_ok(int argc, Scheme_Object *argv[]);
 static Scheme_Object *check_input_port_property_value_ok(int argc, Scheme_Object *argv[]);
 static Scheme_Object *check_output_port_property_value_ok(int argc, Scheme_Object *argv[]);
+static Scheme_Object *check_rename_transformer_property_value_ok(int argc, Scheme_Object *argv[]);
+static Scheme_Object *check_set_transformer_property_value_ok(int argc, Scheme_Object *argv[]);
 
 static Scheme_Object *make_struct_type(int argc, Scheme_Object *argv[]);
 
@@ -134,6 +136,10 @@ static Scheme_Object *exn_source_get(int argc, Scheme_Object **argv);
 
 static Scheme_Object *procedure_extract_target(int argc, Scheme_Object **argv);
 
+static Scheme_Object *rename_transformer_property;
+static Scheme_Object *set_transformer_property;
+static Scheme_Object *not_free_id_symbol;
+
 #ifdef MZ_PRECISE_GC
 static void register_traversers(void);
 #endif
@@ -178,6 +184,7 @@ scheme_init_struct (Scheme_Env *env)
   Scheme_Object **loc_values, *loc_et;
   int loc_count;
   int i;
+  Scheme_Object *guard;
 
   static const char *arity_fields[1] = { "value" };
 #ifdef TIME_SYNTAX
@@ -253,7 +260,7 @@ scheme_init_struct (Scheme_Env *env)
 
   REGISTER_SO(write_property);
   {
-    Scheme_Object *guard, *a[2], *pred, *access;
+    Scheme_Object *a[2], *pred, *access;
     guard = scheme_make_prim_w_arity(check_write_property_value_ok,
 				     "guard-for-prop:custom-write",
 				     2, 2);
@@ -271,7 +278,6 @@ scheme_init_struct (Scheme_Env *env)
   
   REGISTER_SO(evt_property);
   {
-    Scheme_Object *guard;
     guard = scheme_make_prim_w_arity(check_evt_property_value_ok,
 				     "guard-for-prop:evt",
 				     2, 2);
@@ -292,7 +298,6 @@ scheme_init_struct (Scheme_Env *env)
   }
 
   {
-    Scheme_Object *guard;
     guard = scheme_make_prim_w_arity(check_equal_property_value_ok,
 				     "guard-for-prop:equal+hash",
 				     2, 2);
@@ -303,7 +308,6 @@ scheme_init_struct (Scheme_Env *env)
   }
 
   {
-    Scheme_Object *guard;
     REGISTER_SO(scheme_input_port_property);
     REGISTER_SO(scheme_output_port_property);
 
@@ -323,6 +327,33 @@ scheme_init_struct (Scheme_Env *env)
     scheme_add_global_constant("prop:output-port", scheme_output_port_property, env);
   }
 
+  {
+    REGISTER_SO(rename_transformer_property);
+
+    guard = scheme_make_prim_w_arity(check_rename_transformer_property_value_ok,
+				     "guard-for-prop:rename-transformer",
+				     2, 2);
+    rename_transformer_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("rename-transformer"),
+                                                                          guard);
+    
+    scheme_add_global_constant("prop:rename-transformer", rename_transformer_property, env);
+  }
+
+  {
+    REGISTER_SO(set_transformer_property);
+
+    guard = scheme_make_prim_w_arity(check_set_transformer_property_value_ok,
+				     "guard-for-prop:set!-transformer",
+				     2, 2);
+    set_transformer_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("set!-transformer"),
+                                                                        guard);
+    
+    scheme_add_global_constant("prop:set!-transformer", set_transformer_property, env);
+  }
+
+  REGISTER_SO(not_free_id_symbol);
+  not_free_id_symbol = scheme_intern_symbol("not-free-identifier=?");
+
   REGISTER_SO(scheme_recur_symbol);
   REGISTER_SO(scheme_display_symbol);
   REGISTER_SO(scheme_write_special_symbol);
@@ -552,7 +583,6 @@ scheme_init_struct (Scheme_Env *env)
 
   REGISTER_SO(scheme_source_property);
   {
-    Scheme_Object *guard;
     guard = scheme_make_prim_w_arity(check_exn_source_property_value_ok,
 				     "guard-for-prop:exn:srclocs",
 				     2, 2);
@@ -1073,25 +1103,22 @@ static int is_evt_struct(Scheme_Object *o)
 /*                            port structs                                */
 /*========================================================================*/
 
-static Scheme_Object *check_port_property_value_ok(const char *name, int input, int argc, Scheme_Object *argv[])
-/* This is the guard for prop:input-port and prop:output-port */
+typedef int (*Check_Val_Proc)(Scheme_Object *);
+
+static Scheme_Object *check_indirect_property_value_ok(const char *name, Check_Val_Proc ck, const char *complain,
+                                                       int argc, Scheme_Object *argv[])
 {
   Scheme_Object *v, *l, *acc;
   int pos, num_islots;
 
   v = argv[0];
-
-  if ((input && SCHEME_INPUT_PORTP(v))
-      || (!input && SCHEME_OUTPUT_PORTP(v)))
+  
+  if (ck(v))
     return v;
 
   if (!((SCHEME_INTP(v) && (SCHEME_INT_VAL(v) >= 0))
 	|| (SCHEME_BIGNUMP(v) && SCHEME_BIGPOS(v))))
-    scheme_arg_mismatch(name,
-                        (input
-                         ? "property value is not an input port or exact non-negative integer: "
-                         : "property value is not an output port or exact non-negative integer: "),
-			v);
+    scheme_arg_mismatch(name, complain, v);
   
   l = argv[1];
   l = SCHEME_CDR(l);
@@ -1131,6 +1158,20 @@ static Scheme_Object *check_port_property_value_ok(const char *name, int input,
   return v;
 }
 
+static int is_input_port(Scheme_Object *v) {  return SCHEME_INPUT_PORTP(v); }
+static int is_output_port(Scheme_Object *v) {  return SCHEME_OUTPUT_PORTP(v); }
+
+static Scheme_Object *check_port_property_value_ok(const char *name, int input, int argc, Scheme_Object *argv[])
+/* This is the guard for prop:input-port and prop:output-port */
+{
+  return check_indirect_property_value_ok(name, 
+                                          input ? is_input_port : is_output_port, 
+                                          (input
+                                           ? "property value is not an input port or exact non-negative integer: "
+                                           : "property value is not an output port or exact non-negative integer: "),
+                                          argc, argv);
+}
+
 static Scheme_Object *check_input_port_property_value_ok(int argc, Scheme_Object *argv[])
 {
   return check_port_property_value_ok("guard-for-prop:input-port", 1, argc, argv);
@@ -1207,6 +1248,107 @@ Scheme_Object *scheme_is_writable_struct(Scheme_Object *s)
   return scheme_struct_type_property_ref(write_property, s);
 }
 
+/*========================================================================*/
+/*                  rename and set! transformer properties                */
+/*========================================================================*/
+
+int scheme_is_rename_transformer(Scheme_Object *o)
+{
+  if (SAME_TYPE(SCHEME_TYPE(o), scheme_id_macro_type))
+    return 1;
+  if (SCHEME_STRUCTP(o)
+      && scheme_struct_type_property_ref(rename_transformer_property, o))
+    return 1;
+  return 0;
+}
+
+int scheme_is_binding_rename_transformer(Scheme_Object *o)
+{
+  if (scheme_is_rename_transformer(o)) {
+    o = scheme_rename_transformer_id(o);
+    o = scheme_stx_property(o, not_free_id_symbol, NULL);
+    if (o && SCHEME_TRUEP(o))
+      return 0;
+    return 1;
+  }
+  return 0;
+}
+
+static int is_stx_id(Scheme_Object *o) { return (SCHEME_STXP(o) && SCHEME_SYMBOLP(SCHEME_STX_VAL(o))); }
+
+Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o)
+{
+  if (SAME_TYPE(SCHEME_TYPE(o), scheme_id_macro_type))
+    return SCHEME_PTR1_VAL(o);
+  if (SCHEME_STRUCTP(o)) {
+    Scheme_Object *v;
+    v = scheme_struct_type_property_ref(rename_transformer_property, o);
+    if (SCHEME_BOXP(v)) v = SCHEME_BOX_VAL(v);
+    if (SCHEME_INTP(v)) {
+      v = ((Scheme_Structure *)o)->slots[SCHEME_INT_VAL(v)];
+      if (!is_stx_id(v)) {
+        v = scheme_datum_to_syntax(scheme_intern_symbol("?"), scheme_false, scheme_false, 0, 0);
+      }
+    }
+    return v;
+  }
+  return NULL;
+}
+
+static Scheme_Object *check_rename_transformer_property_value_ok(int argc, Scheme_Object *argv[])
+{
+  return check_indirect_property_value_ok("guard-for-prop:rename-transformer", 
+                                          is_stx_id, 
+                                          "property value is not an identifier or exact non-negative integer, optionaly boxed: ",
+                                          argc, argv);
+}
+
+int scheme_is_set_transformer(Scheme_Object *o)
+{
+  if (SAME_TYPE(SCHEME_TYPE(o), scheme_set_macro_type))
+    return 1;
+  if (SCHEME_STRUCTP(o)
+      && scheme_struct_type_property_ref(set_transformer_property, o))
+    return 1;
+  return 0;
+}
+
+static int is_proc_1(Scheme_Object *o) { return (SCHEME_PROCP(o) && scheme_check_proc_arity(NULL, 1, -1, 0, &o)); } 
+
+Scheme_Object *signal_bad_syntax(int argc, Scheme_Object **argv)
+{
+  scheme_wrong_syntax(NULL, NULL, argv[0], "bad syntax");
+  return NULL;
+}
+
+Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o)
+{
+  if (SAME_TYPE(SCHEME_TYPE(o), scheme_set_macro_type))
+    return SCHEME_PTR_VAL(o);
+  if (SCHEME_STRUCTP(o)) {
+    Scheme_Object *v;
+    v = scheme_struct_type_property_ref(set_transformer_property, o);
+    if (SCHEME_INTP(v)) {
+      v = ((Scheme_Structure *)o)->slots[SCHEME_INT_VAL(v)];
+      if (!is_proc_1(v)) {
+        v = scheme_make_prim_w_arity(signal_bad_syntax,
+                                     "bad-syntax-set!-transformer",
+                                     1, 1);
+      }
+    }
+    return v;
+  }
+  return NULL;
+}
+
+static Scheme_Object *check_set_transformer_property_value_ok(int argc, Scheme_Object *argv[])
+{
+  return check_indirect_property_value_ok("guard-for-prop:set!-transformer", 
+                                          is_proc_1, 
+                                          "property value is not an procedure (arity 1) or exact non-negative integer: ",
+                                          argc, argv);
+}
+
 /*========================================================================*/
 /*                             struct ops                                 */
 /*========================================================================*/
diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c
index 7f70231c20..bc3b812e74 100644
--- a/src/mzscheme/src/stxobj.c
+++ b/src/mzscheme/src/stxobj.c
@@ -4816,11 +4816,11 @@ Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *pha
 
 Scheme_Object *scheme_stx_module_name(int recur,
                                       Scheme_Object **a, Scheme_Object *phase, 
-				      Scheme_Object **nominal_modidx,
-				      Scheme_Object **nominal_name,
-				      Scheme_Object **mod_phase, 
-                                      Scheme_Object **src_phase_index,
-                                      Scheme_Object **nominal_src_phase,
+				      Scheme_Object **nominal_modidx,    /* how it was imported */
+				      Scheme_Object **nominal_name,      /* imported as name */
+				      Scheme_Object **mod_phase,         /* original defn phase level */
+                                      Scheme_Object **src_phase_index,   /* phase level of import from nominal modidx */ 
+                                      Scheme_Object **nominal_src_phase, /* phase level of export from nominal modidx */
                                       Scheme_Object **lex_env,
                                       int *_sealed)
      /* If module bound, result is module idx, and a is set to source name.
diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c
index 77444877c6..407abd05d4 100644
--- a/src/mzscheme/src/syntax.c
+++ b/src/mzscheme/src/syntax.c
@@ -1698,12 +1698,12 @@ set_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
     
     if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) {
       /* Redirect to a macro? */
-      if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_set_macro_type)) {
+      if (scheme_is_set_transformer(SCHEME_PTR_VAL(var))) {
 	form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, rec, drec, 1);
 	
 	return scheme_compile_expr(form, env, rec, drec);
-      } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) {
-	find_name = SCHEME_PTR_VAL(SCHEME_PTR_VAL(var));
+      } else if (scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) {
+	find_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var));
 	find_name = scheme_stx_cert(find_name, scheme_false, menv, find_name, NULL, 1);
 	SCHEME_USE_FUEL(1);
 	menv = NULL;
@@ -1787,7 +1787,7 @@ set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec,
 
     if ((erec[drec].depth != 0) && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) {
       /* Redirect to a macro? */
-      if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_set_macro_type)) {
+      if (scheme_is_set_transformer(SCHEME_PTR_VAL(var))) {
 
 	SCHEME_EXPAND_OBSERVE_ENTER_MACRO(erec[drec].observer, form);
 
@@ -1801,9 +1801,9 @@ set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec,
 	erec[drec].value_name = name;
 
 	return scheme_expand_expr(form, env, erec, drec);
-      } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) {
+      } else if (scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) {
 	Scheme_Object *new_name;
-	new_name = SCHEME_PTR_VAL(SCHEME_PTR_VAL(var));
+	new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var));
 	new_name = scheme_stx_track(new_name, find_name, find_name);
 	new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1);
 	find_name = new_name;
@@ -5732,14 +5732,13 @@ static void *eval_letmacro_rhs_k(void)
   return (void *)eval_letmacro_rhs(a, rhs_env, max_let_depth, rp, phase, certs);
 }
 
-
 void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a, 
                           Scheme_Env *exp_env, Scheme_Object *insp, 
                           Scheme_Compile_Expand_Info *rec, int drec,
                           Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env,
                           int *_pos, Scheme_Object *rename_rib)
 {
-  Scheme_Object **results, *l;
+  Scheme_Object **results, *l, *a_expr;
   Scheme_Comp_Env *eenv;
   Scheme_Object *certs;
   Resolve_Prefix *rp;
@@ -5795,7 +5794,8 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object
 
   SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
 
-  a = eval_letmacro_rhs(a, rhs_env, ri->max_let_depth, rp, eenv->genv->phase, certs);
+  a_expr = a;
+  a = eval_letmacro_rhs(a_expr, rhs_env, ri->max_let_depth, rp, eenv->genv->phase, certs);
 
   if (SAME_OBJ(a, SCHEME_MULTIPLE_VALUES)) {
     vc = scheme_current_thread->ku.multiple.count;
@@ -5846,9 +5846,9 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object
     
     scheme_set_local_syntax(i++, name, macro, stx_env);
 
-    if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(macro)), scheme_id_macro_type)) {
+    if (scheme_is_binding_rename_transformer(SCHEME_PTR_VAL(macro))) {
       /* Install a free-id=? rename */
-      scheme_install_free_id_rename(name, SCHEME_PTR1_VAL(SCHEME_PTR_VAL(macro)), rename_rib,
+      scheme_install_free_id_rename(name, scheme_rename_transformer_id(SCHEME_PTR_VAL(macro)), rename_rib,
                                     scheme_make_integer(rhs_env->genv->phase));
     }
   }