diff --git a/.bzrignore b/.bzrignore
new file mode 100644
index 0000000..bfbc335
--- /dev/null
+++ b/.bzrignore
@@ -0,0 +1,7 @@
+*.tmp
+*.out
+*.fasl
+.gdb_history
+.bzrignore
+.bzrignore
+./ikarus.boot.back
diff --git a/src/Makefile b/src/Makefile
index b90246e..c4847d2 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -2,7 +2,8 @@
 all: ikarus.boot
 
 ikarus.boot: *.ss
-	echo '(load "makefile.ss")' | ../runtime/ikarus ikarus.boot
+	cp ikarus.boot ikarus.boot.back
+	echo '(load "makefile.ss")' | time ../runtime/ikarus ikarus.boot
 
 clean:
 	rm -f *.fasl
diff --git a/src/build-date.tmp b/src/build-date.tmp
deleted file mode 100644
index 77c2433..0000000
--- a/src/build-date.tmp
+++ /dev/null
@@ -1 +0,0 @@
-2006-08-25
diff --git a/src/compiler-8.1.ss b/src/compiler-8.1.ss
deleted file mode 100644
index 1cee6fc..0000000
--- a/src/compiler-8.1.ss
+++ /dev/null
@@ -1,290 +0,0 @@
-
-
-;;; 8.1: * using chez-style io ports
-;;; 6.9: * creating a *system* environment
-;;; 6.8: * creating a core-primitive form in the expander
-;;; 6.2: * side-effects now modify the dirty-vector
-;;;      * added bwp-object?
-;;;      * added pointer-value
-;;;      * added tcbuckets
-;;; 6.1: * added case-lambda, dropped lambda
-;;; 6.0: * basic compiler
-
-
-
-
-(define macros
-  '(|#primitive| lambda case-lambda set! quote begin define if letrec
-    foreign-call $apply
-    quasiquote unquote unquote-splicing
-    define-syntax identifier-syntax let-syntax letrec-syntax
-    fluid-let-syntax alias meta eval-when with-implicit with-syntax
-    type-descriptor
-    syntax-case syntax-rules module $module import $import import-only
-    syntax quasisyntax unsyntax unsyntax-splicing datum
-    let let* let-values cond case define-record or and when unless do
-    include parameterize trace untrace trace-lambda))
-
-
-
-(define public-primitives
-  '(null? pair? char? fixnum? symbol? gensym? string? vector? list?
-    boolean? procedure? 
-    not
-    eof-object eof-object? bwp-object?
-    void
-    fx= fx< fx<= fx> fx>= fxzero?
-    fx+ fx- fx* fxadd1 fxsub1 fxquotient fxremainder fxmodulo 
-    fxsll fxsra fxlognot fxlogor fxlogand fxlogxor
-    integer->char char->integer
-    char=? char<? char<=? char>? char>=?
-    cons car cdr set-car! set-cdr!
-    caar cadr cdar cddr 
-    caaar caadr cadar caddr cdaar cdadr cddar cdddr 
-    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr 
-    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr 
-    list list* make-list length list-ref
-    append
-    make-vector vector-ref vector-set! vector-length vector
-    vector->list list->vector
-    make-string string-ref string-set! string-length string list->string
-    uuid
-    string-append substring 
-    string=? string<? string<=? string>? string>=?
-    remprop putprop getprop property-list
-    apply
-    map for-each andmap ormap
-    memq memv assq 
-    eq? equal?
-    reverse
-    string->symbol symbol->string oblist 
-    top-level-value set-top-level-value! top-level-bound?
-    gensym gensym-count gensym-prefix print-gensym
-    gensym->unique-string
-    call-with-values values
-    make-parameter dynamic-wind
-    display write fasl-write printf format print-error
-    read-token read
-    error exit call/cc
-    current-error-handler
-    eval current-eval interpret compile compile-file new-cafe load
-    system
-    expand sc-expand current-expand expand-mode 
-    environment? interaction-environment
-    identifier? free-identifier=? bound-identifier=? literal-identifier=?
-    datum->syntax-object syntax-object->datum syntax-error
-    syntax->list
-    generate-temporaries
-    record? record-set! record-ref record-length
-    record-type-descriptor make-record-type
-    record-printer record-name record-field-accessor
-    record-field-mutator record-predicate record-constructor
-    record-type-name record-type-symbol record-type-field-names 
-    hash-table? make-hash-table get-hash-table put-hash-table!
-    assembler-output
-    $make-environment
-    features
-
-    port? input-port? output-port? 
-    make-input-port make-output-port make-input/output-port
-    port-handler
-    port-input-buffer port-input-index port-input-size 
-    port-output-buffer port-output-index port-output-size 
-    set-port-input-index! set-port-input-size! 
-    set-port-output-index! set-port-output-size!
-    port-name input-port-name output-port-name
-    write-char read-char unread-char peek-char
-    newline 
-    reset-input-port!  flush-output-port
-    close-input-port close-output-port
-    console-input-port current-input-port
-    standard-output-port standard-error-port
-    console-output-port current-output-port
-    open-output-file open-input-file
-    open-output-string get-output-string
-    with-output-to-file call-with-output-file
-    with-input-from-file call-with-input-file
-    date-string   
-
-    ))
-
-(define system-primitives
-  '(immediate? $unbound-object? $forward-ptr?
-    pointer-value 
-    primitive-ref primitive-set!
-    $fx= $fx< $fx<= $fx> $fx>= $fxzero?
-    $fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient $fxremainder $fxmodulo 
-    $fxsll $fxsra $fxlognot $fxlogor $fxlogand $fxlogxor
-    $fixnum->char $char->fixnum
-    $char= $char< $char<= $char> $char>=
-    $car $cdr $set-car! $set-cdr!
-    $make-vector $vector-ref $vector-set! $vector-length
-    $make-string $string-ref $string-set! $string-length $string
-    $symbol-string $symbol-unique-string $symbol-value
-    $set-symbol-string! $set-symbol-unique-string! $set-symbol-value!
-    $make-symbol $set-symbol-plist!  $symbol-plist
-    $sc-put-cte 
-    $record? $record/rtd? $record-set! $record-ref $record-rtd
-    $make-record $record
-    $base-rtd
-    $code? $code-reloc-vector $code-freevars $code-size $code-ref $code-set!
-    $code->closure list*->code* 
-    make-code code? set-code-reloc-vector! code-reloc-vector code-freevars
-    code-size code-ref code-set!
-    $frame->continuation $fp-at-base $current-frame $seal-frame-and-call
-    $make-call-with-values-procedure $make-values-procedure
-    do-overflow collect
-    $make-tcbucket $tcbucket-next $tcbucket-key $tcbucket-val
-    $set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc!
-    call/cf trace-symbol! untrace-symbol! make-traced-procedure
-    fixnum->string 
-    vector-memq vector-memv
-
-    ;;; must open-code
-    $make-port/input
-    $make-port/output
-    $make-port/both
-    $make-input-port $make-output-port $make-input/output-port
-    $port-handler
-    $port-input-buffer $port-input-index $port-input-size 
-    $port-output-buffer $port-output-index $port-output-size 
-    $set-port-input-index! $set-port-input-size!
-    $set-port-output-index! $set-port-output-size!
-
-    ;;; better open-code
-    $write-char $read-char $peek-char $unread-char
-
-    ;;; never open-code 
-    $reset-input-port! $close-input-port
-    $close-output-port $flush-output-port
-    *standard-output-port* *standard-error-port* *current-output-port*
-    *standard-input-port* *current-input-port*
-    ))
- 
-
-
-(define (whack-system-env setenv?)
-  (define add-prim
-    (lambda (x)
-      (let ([g (gensym (symbol->string x))])
-        (putprop x '|#system| g)
-        (putprop g '*sc-expander* (cons 'core-primitive x)))))
-  (define add-macro
-    (lambda (x)
-      (let ([g (gensym (symbol->string x))]
-            [e (getprop x '*sc-expander*)])
-        (when e 
-          (putprop x '|#system| g)
-          (putprop g '*sc-expander* e)))))
-  (define (foo)
-    (eval 
-      `(begin
-         (define-syntax compile-time-date-string
-           (lambda (x)
-             #'(quote ,(date-string))))
-         (define-syntax public-primitives
-           (lambda (x)
-             #'(quote ,public-primitives)))
-         (define-syntax system-primitives
-           (lambda (x)
-             #'(quote ,system-primitives))) 
-         (define-syntax macros
-           (lambda (x)
-             #'(quote ,macros))))))
-  (set! system-env ($make-environment '|#system| #t))
-  (for-each add-macro macros)
-  (for-each add-prim public-primitives)
-  (for-each add-prim system-primitives)
-  (if setenv?
-      (parameterize ([interaction-environment system-env])
-        (foo))
-      (foo)))
-
-
-
-(when (eq? "" "")
-  (load "chez-compat.ss")
-  (set! primitive-ref top-level-value)
-  (set! primitive-set! set-top-level-value!)
-  (set! chez-expand sc-expand)
-  (set! chez-current-expand current-expand)
-  (printf "loading psyntax.pp ...\n")
-  (load "psyntax-7.1.pp")
-  (chez-current-expand
-    (lambda (x . args)
-      (apply chez-expand (sc-expand x) args)))
-  (whack-system-env #f)
-  (printf "loading psyntax.ss ...\n")
-  (load "psyntax-7.1-6.9.ss")
-  (chez-current-expand
-    (lambda (x . args)
-      (apply chez-expand (sc-expand x) args)))
-  (whack-system-env #t)
-  (printf "ok\n")
-  (load "libassembler-compat-6.7.ss") ; defines make-code etc.
-  (load "libintelasm-6.9.ss") ; uses make-code, etc.
-  (load "libfasl-6.7.ss") ; uses code? etc.
-  (load "libcompile-8.1.ss") ; uses fasl-write
-)
-
-
-(whack-system-env #t)
-
-(define scheme-library-files
-  '(["libhandlers-6.9.ss"   #t  "libhandlers.fasl"]
-    ["libcontrol-6.1.ss"    #t  "libcontrol.fasl"]
-    ["libcollect-6.1.ss"    #t  "libcollect.fasl"]
-    ["librecord-6.4.ss"     #t  "librecord.fasl"]
-    ["libcxr-6.0.ss"        #t  "libcxr.fasl"]
-    ["libcore-6.9.ss"       #t  "libcore.fasl"]
-    ["libchezio-8.1.ss"     #t  "libchezio.fasl"]
-    ["libwriter-6.2.ss"     #t  "libwriter.fasl"]
-    ["libtokenizer-6.1.ss"  #t  "libtokenizer.fasl"]
-    ["libassembler-6.7.ss"  #t  "libassembler.ss"]
-    ["libintelasm-6.9.ss"   #t  "libintelasm.fasl"]
-    ["libfasl-6.7.ss"       #t  "libfasl.fasl"]
-    ["libcompile-8.1.ss"    #t  "libcompile.fasl"]
-    ["psyntax-7.1-6.9.ss"   #t  "psyntax.fasl"]
-    ["libinterpret-6.5.ss"  #t  "libinterpret.fasl"]
-    ["libcafe-6.1.ss"       #t  "libcafe.fasl"]
-    ["libtrace-6.9.ss"      #t  "libtrace.fasl"]
-    ["libposix-6.0.ss"      #t  "libposix.fasl"]
-    ["libhash-6.2.ss"       #t  "libhash.fasl"]
-    ["libtoplevel-6.9.ss"   #t  "libtoplevel.fasl"]
-    ))
-
-
-
-(define (compile-library ifile ofile)
-  (parameterize ([assembler-output #f] 
-                 [expand-mode 'bootstrap]
-                 [interaction-environment system-env])
-     (printf "compiling ~a ...\n" ifile)
-     (compile-file ifile ofile 'replace)))
-
-(for-each 
-  (lambda (x)
-    (when (cadr x)
-      (compile-library (car x) (caddr x))))
-  scheme-library-files)
-
-
-(define (join s ls)
-  (cond
-    [(null? ls) ""]
-    [else
-     (let ([str (open-output-string)])
-       (let f ([a (car ls)] [d (cdr ls)])
-         (cond
-           [(null? d)
-            (display a str)
-            (get-output-string str)]
-           [else
-            (display a str)
-            (display s str)
-            (f (car d) (cdr d))])))]))
-   
-
-(system
-  (format "cat ~a > ikarus.fasl"
-          (join " " (map caddr scheme-library-files))))
diff --git a/src/compiler-9.0.ss b/src/compiler-9.0.ss
deleted file mode 100644
index f3ab9c7..0000000
--- a/src/compiler-9.0.ss
+++ /dev/null
@@ -1,290 +0,0 @@
-
-
-;;; 8.1: * using chez-style io ports
-;;; 6.9: * creating a *system* environment
-;;; 6.8: * creating a core-primitive form in the expander
-;;; 6.2: * side-effects now modify the dirty-vector
-;;;      * added bwp-object?
-;;;      * added pointer-value
-;;;      * added tcbuckets
-;;; 6.1: * added case-lambda, dropped lambda
-;;; 6.0: * basic compiler
-
-
-
-
-(define macros
-  '(|#primitive| lambda case-lambda set! quote begin define if letrec
-    foreign-call $apply
-    quasiquote unquote unquote-splicing
-    define-syntax identifier-syntax let-syntax letrec-syntax
-    fluid-let-syntax alias meta eval-when with-implicit with-syntax
-    type-descriptor
-    syntax-case syntax-rules module $module import $import import-only
-    syntax quasisyntax unsyntax unsyntax-splicing datum
-    let let* let-values cond case define-record or and when unless do
-    include parameterize trace untrace trace-lambda))
-
-
-
-(define public-primitives
-  '(null? pair? char? fixnum? symbol? gensym? string? vector? list?
-    boolean? procedure? 
-    not
-    eof-object eof-object? bwp-object?
-    void
-    fx= fx< fx<= fx> fx>= fxzero?
-    fx+ fx- fx* fxadd1 fxsub1 fxquotient fxremainder fxmodulo 
-    fxsll fxsra fxlognot fxlogor fxlogand fxlogxor
-    integer->char char->integer
-    char=? char<? char<=? char>? char>=?
-    cons car cdr set-car! set-cdr!
-    caar cadr cdar cddr 
-    caaar caadr cadar caddr cdaar cdadr cddar cdddr 
-    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr 
-    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr 
-    list list* make-list length list-ref
-    append
-    make-vector vector-ref vector-set! vector-length vector
-    vector->list list->vector
-    make-string string-ref string-set! string-length string list->string
-    uuid
-    string-append substring 
-    string=? string<? string<=? string>? string>=?
-    remprop putprop getprop property-list
-    apply
-    map for-each andmap ormap
-    memq memv assq 
-    eq? equal?
-    reverse
-    string->symbol symbol->string oblist 
-    top-level-value set-top-level-value! top-level-bound?
-    gensym gensym-count gensym-prefix print-gensym
-    gensym->unique-string
-    call-with-values values
-    make-parameter dynamic-wind
-    display write print-graph fasl-write printf format print-error
-    read-token read
-    error exit call/cc
-    current-error-handler
-    eval current-eval interpret compile compile-file new-cafe load
-    system
-    expand sc-expand current-expand expand-mode 
-    environment? interaction-environment
-    identifier? free-identifier=? bound-identifier=? literal-identifier=?
-    datum->syntax-object syntax-object->datum syntax-error
-    syntax->list
-    generate-temporaries
-    record? record-set! record-ref record-length
-    record-type-descriptor make-record-type
-    record-printer record-name record-field-accessor
-    record-field-mutator record-predicate record-constructor
-    record-type-name record-type-symbol record-type-field-names 
-    hash-table? make-hash-table get-hash-table put-hash-table!
-    assembler-output
-    $make-environment
-    features
-
-    port? input-port? output-port? 
-    make-input-port make-output-port make-input/output-port
-    port-handler
-    port-input-buffer port-input-index port-input-size 
-    port-output-buffer port-output-index port-output-size 
-    set-port-input-index! set-port-input-size! 
-    set-port-output-index! set-port-output-size!
-    port-name input-port-name output-port-name
-    write-char read-char unread-char peek-char
-    newline 
-    reset-input-port!  flush-output-port
-    close-input-port close-output-port
-    console-input-port current-input-port
-    standard-output-port standard-error-port
-    console-output-port current-output-port
-    open-output-file open-input-file
-    open-output-string get-output-string
-    with-output-to-file call-with-output-file
-    with-input-from-file call-with-input-file
-    date-string   
-
-    ))
-
-(define system-primitives
-  '(immediate? $unbound-object? $forward-ptr?
-    pointer-value 
-    primitive-ref primitive-set!
-    $fx= $fx< $fx<= $fx> $fx>= $fxzero?
-    $fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient $fxremainder $fxmodulo 
-    $fxsll $fxsra $fxlognot $fxlogor $fxlogand $fxlogxor
-    $fixnum->char $char->fixnum
-    $char= $char< $char<= $char> $char>=
-    $car $cdr $set-car! $set-cdr!
-    $make-vector $vector-ref $vector-set! $vector-length
-    $make-string $string-ref $string-set! $string-length $string
-    $symbol-string $symbol-unique-string $symbol-value
-    $set-symbol-string! $set-symbol-unique-string! $set-symbol-value!
-    $make-symbol $set-symbol-plist!  $symbol-plist
-    $sc-put-cte 
-    $record? $record/rtd? $record-set! $record-ref $record-rtd
-    $make-record $record
-    $base-rtd
-    $code? $code-reloc-vector $code-freevars $code-size $code-ref $code-set!
-    $code->closure list*->code* 
-    make-code code? set-code-reloc-vector! code-reloc-vector code-freevars
-    code-size code-ref code-set!
-    $frame->continuation $fp-at-base $current-frame $seal-frame-and-call
-    $make-call-with-values-procedure $make-values-procedure
-    do-overflow collect
-    $make-tcbucket $tcbucket-next $tcbucket-key $tcbucket-val
-    $set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc!
-    call/cf trace-symbol! untrace-symbol! make-traced-procedure
-    fixnum->string 
-    vector-memq vector-memv
-
-    ;;; must open-code
-    $make-port/input
-    $make-port/output
-    $make-port/both
-    $make-input-port $make-output-port $make-input/output-port
-    $port-handler
-    $port-input-buffer $port-input-index $port-input-size 
-    $port-output-buffer $port-output-index $port-output-size 
-    $set-port-input-index! $set-port-input-size!
-    $set-port-output-index! $set-port-output-size!
-
-    ;;; better open-code
-    $write-char $read-char $peek-char $unread-char
-
-    ;;; never open-code 
-    $reset-input-port! $close-input-port
-    $close-output-port $flush-output-port
-    *standard-output-port* *standard-error-port* *current-output-port*
-    *standard-input-port* *current-input-port*
-    ))
- 
-
-
-(define (whack-system-env setenv?)
-  (define add-prim
-    (lambda (x)
-      (let ([g (gensym (symbol->string x))])
-        (putprop x '|#system| g)
-        (putprop g '*sc-expander* (cons 'core-primitive x)))))
-  (define add-macro
-    (lambda (x)
-      (let ([g (gensym (symbol->string x))]
-            [e (getprop x '*sc-expander*)])
-        (when e 
-          (putprop x '|#system| g)
-          (putprop g '*sc-expander* e)))))
-  (define (foo)
-    (eval 
-      `(begin
-         (define-syntax compile-time-date-string
-           (lambda (x)
-             #'(quote ,(date-string))))
-         (define-syntax public-primitives
-           (lambda (x)
-             #'(quote ,public-primitives)))
-         (define-syntax system-primitives
-           (lambda (x)
-             #'(quote ,system-primitives))) 
-         (define-syntax macros
-           (lambda (x)
-             #'(quote ,macros))))))
-  (set! system-env ($make-environment '|#system| #t))
-  (for-each add-macro macros)
-  (for-each add-prim public-primitives)
-  (for-each add-prim system-primitives)
-  (if setenv?
-      (parameterize ([interaction-environment system-env])
-        (foo))
-      (foo)))
-
-
-
-(when (eq? "" "")
-  (load "chez-compat.ss")
-  (set! primitive-ref top-level-value)
-  (set! primitive-set! set-top-level-value!)
-  (set! chez-expand sc-expand)
-  (set! chez-current-expand current-expand)
-  (printf "loading psyntax.pp ...\n")
-  (load "psyntax-7.1.pp")
-  (chez-current-expand
-    (lambda (x . args)
-      (apply chez-expand (sc-expand x) args)))
-  (whack-system-env #f)
-  (printf "loading psyntax.ss ...\n")
-  (load "psyntax-7.1-6.9.ss")
-  (chez-current-expand
-    (lambda (x . args)
-      (apply chez-expand (sc-expand x) args)))
-  (whack-system-env #t)
-  (printf "ok\n")
-  (load "libassembler-compat-6.7.ss") ; defines make-code etc.
-  (load "libintelasm-6.9.ss") ; uses make-code, etc.
-  (load "libfasl-6.7.ss") ; uses code? etc.
-  (load "libcompile-8.1.ss") ; uses fasl-write
-)
-
-
-(whack-system-env #t)
-
-(define scheme-library-files
-  '(["libhandlers-6.9.ss"   #t  "libhandlers.fasl"]
-    ["libcontrol-6.1.ss"    #t  "libcontrol.fasl"]
-    ["libcollect-6.1.ss"    #t  "libcollect.fasl"]
-    ["librecord-6.4.ss"     #t  "librecord.fasl"]
-    ["libcxr-6.0.ss"        #t  "libcxr.fasl"]
-    ["libcore-6.9.ss"       #t  "libcore.fasl"]
-    ["libchezio-8.1.ss"     #t  "libchezio.fasl"]
-    ["libhash-6.2.ss"       #t  "libhash.fasl"]
-    ["libwriter-9.0.ss"     #t  "libwriter.fasl"]
-    ["libtokenizer-9.0.ss"  #t  "libtokenizer.fasl"]
-    ["libassembler-6.7.ss"  #t  "libassembler.ss"]
-    ["libintelasm-6.9.ss"   #t  "libintelasm.fasl"]
-    ["libfasl-6.7.ss"       #t  "libfasl.fasl"]
-    ["libcompile-9.0.ss"    #t  "libcompile.fasl"]
-    ["psyntax-7.1-9.0.ss"   #t  "psyntax.fasl"]
-    ["libinterpret-6.5.ss"  #t  "libinterpret.fasl"]
-    ["libcafe-6.1.ss"       #t  "libcafe.fasl"]
-    ["libtrace-6.9.ss"      #t  "libtrace.fasl"]
-    ["libposix-6.0.ss"      #t  "libposix.fasl"]
-    ["libtoplevel-6.9.ss"   #t  "libtoplevel.fasl"]
-    ))
-
-
-
-(define (compile-library ifile ofile)
-  (parameterize ([assembler-output #f] 
-                 [expand-mode 'bootstrap]
-                 [interaction-environment system-env])
-     (printf "compiling ~a ...\n" ifile)
-     (compile-file ifile ofile 'replace)))
-
-(for-each 
-  (lambda (x)
-    (when (cadr x)
-      (compile-library (car x) (caddr x))))
-  scheme-library-files)
-
-
-(define (join s ls)
-  (cond
-    [(null? ls) ""]
-    [else
-     (let ([str (open-output-string)])
-       (let f ([a (car ls)] [d (cdr ls)])
-         (cond
-           [(null? d)
-            (display a str)
-            (get-output-string str)]
-           [else
-            (display a str)
-            (display s str)
-            (f (car d) (cdr d))])))]))
-   
-
-(system
-  (format "cat ~a > ikarus.fasl"
-          (join " " (map caddr scheme-library-files))))
diff --git a/src/compiler-9.1.ss b/src/compiler-9.1.ss
deleted file mode 100644
index 160f2e1..0000000
--- a/src/compiler-9.1.ss
+++ /dev/null
@@ -1,297 +0,0 @@
-
-
-;;; 9.1: * starting with libnumerics
-;;; 9.0: * graph marks for both reader and writer 
-;;;      * circularity detection during read 
-;;; 8.1: * using chez-style io ports
-;;; 6.9: * creating a *system* environment
-;;; 6.8: * creating a core-primitive form in the expander
-;;; 6.2: * side-effects now modify the dirty-vector
-;;;      * added bwp-object?
-;;;      * added pointer-value
-;;;      * added tcbuckets
-;;; 6.1: * added case-lambda, dropped lambda
-;;; 6.0: * basic compiler
-
-
-
-
-(define macros
-  '(|#primitive| lambda case-lambda set! quote begin define if letrec
-    foreign-call $apply
-    quasiquote unquote unquote-splicing
-    define-syntax identifier-syntax let-syntax letrec-syntax
-    fluid-let-syntax alias meta eval-when with-implicit with-syntax
-    type-descriptor
-    syntax-case syntax-rules module $module import $import import-only
-    syntax quasisyntax unsyntax unsyntax-splicing datum
-    let let* let-values cond case define-record or and when unless do
-    include parameterize trace untrace trace-lambda))
-
-
-
-(define public-primitives
-  '(null? pair? char? fixnum? symbol? gensym? string? vector? list?
-    boolean? procedure? 
-    not
-    eof-object eof-object? bwp-object?
-    void
-    fx= fx< fx<= fx> fx>= fxzero?
-    fx+ fx- fx* fxadd1 fxsub1 fxquotient fxremainder fxmodulo 
-    fxsll fxsra fxlognot fxlogor fxlogand fxlogxor
-    integer->char char->integer
-    char=? char<? char<=? char>? char>=?
-    cons car cdr set-car! set-cdr!
-    caar cadr cdar cddr 
-    caaar caadr cadar caddr cdaar cdadr cddar cdddr 
-    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr 
-    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr 
-    list list* make-list length list-ref
-    append
-    make-vector vector-ref vector-set! vector-length vector
-    vector->list list->vector
-    make-string string-ref string-set! string-length string list->string
-    uuid
-    string-append substring 
-    string=? string<? string<=? string>? string>=?
-    remprop putprop getprop property-list
-    apply
-    map for-each andmap ormap
-    memq memv assq 
-    eq? equal?
-    reverse
-    string->symbol symbol->string oblist 
-    top-level-value set-top-level-value! top-level-bound?
-    gensym gensym-count gensym-prefix print-gensym
-    gensym->unique-string
-    call-with-values values
-    make-parameter dynamic-wind
-    display write print-graph fasl-write printf format print-error
-    read-token read
-    error exit call/cc
-    current-error-handler
-    eval current-eval interpret compile compile-file new-cafe load
-    system
-    expand sc-expand current-expand expand-mode 
-    environment? interaction-environment
-    identifier? free-identifier=? bound-identifier=? literal-identifier=?
-    datum->syntax-object syntax-object->datum syntax-error
-    syntax->list
-    generate-temporaries
-    record? record-set! record-ref record-length
-    record-type-descriptor make-record-type
-    record-printer record-name record-field-accessor
-    record-field-mutator record-predicate record-constructor
-    record-type-name record-type-symbol record-type-field-names 
-    hash-table? make-hash-table get-hash-table put-hash-table!
-    assembler-output
-    $make-environment
-    features
-
-    port? input-port? output-port? 
-    make-input-port make-output-port make-input/output-port
-    port-handler
-    port-input-buffer port-input-index port-input-size 
-    port-output-buffer port-output-index port-output-size 
-    set-port-input-index! set-port-input-size! 
-    set-port-output-index! set-port-output-size!
-    port-name input-port-name output-port-name
-    write-char read-char unread-char peek-char
-    newline 
-    reset-input-port!  flush-output-port
-    close-input-port close-output-port
-    console-input-port current-input-port
-    standard-output-port standard-error-port
-    console-output-port current-output-port
-    open-output-file open-input-file
-    open-output-string get-output-string
-    with-output-to-file call-with-output-file
-    with-input-from-file call-with-input-file
-    date-string
-
-    + - add1 sub1 * expt number? positive? negative? zero? number->string
-    logand
-    = < > <= >=
-    ))
-
-(define system-primitives
-  '(immediate? $unbound-object? $forward-ptr?
-    pointer-value 
-    primitive-ref primitive-set!
-    $fx= $fx< $fx<= $fx> $fx>= $fxzero?
-    $fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient $fxremainder $fxmodulo 
-    $fxsll $fxsra $fxlognot $fxlogor $fxlogand $fxlogxor
-    $fixnum->char $char->fixnum
-    $char= $char< $char<= $char> $char>=
-    $car $cdr $set-car! $set-cdr!
-    $make-vector $vector-ref $vector-set! $vector-length
-    $make-string $string-ref $string-set! $string-length $string
-    $symbol-string $symbol-unique-string $symbol-value
-    $set-symbol-string! $set-symbol-unique-string! $set-symbol-value!
-    $make-symbol $set-symbol-plist!  $symbol-plist
-    $sc-put-cte 
-    $record? $record/rtd? $record-set! $record-ref $record-rtd
-    $make-record $record
-    $base-rtd
-    $code? $code-reloc-vector $code-freevars $code-size $code-ref $code-set!
-    $code->closure list*->code* 
-    make-code code? set-code-reloc-vector! code-reloc-vector code-freevars
-    code-size code-ref code-set!
-    $frame->continuation $fp-at-base $current-frame $seal-frame-and-call
-    $make-call-with-values-procedure $make-values-procedure
-    do-overflow collect
-    $make-tcbucket $tcbucket-next $tcbucket-key $tcbucket-val
-    $set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc!
-    call/cf trace-symbol! untrace-symbol! make-traced-procedure
-    fixnum->string 
-    vector-memq vector-memv
-
-    ;;; must open-code
-    $make-port/input
-    $make-port/output
-    $make-port/both
-    $make-input-port $make-output-port $make-input/output-port
-    $port-handler
-    $port-input-buffer $port-input-index $port-input-size 
-    $port-output-buffer $port-output-index $port-output-size 
-    $set-port-input-index! $set-port-input-size!
-    $set-port-output-index! $set-port-output-size!
-
-    ;;; better open-code
-    $write-char $read-char $peek-char $unread-char
-
-    ;;; never open-code 
-    $reset-input-port! $close-input-port
-    $close-output-port $flush-output-port
-    *standard-output-port* *standard-error-port* *current-output-port*
-    *standard-input-port* *current-input-port*
-    ))
- 
-
-
-(define (whack-system-env setenv?)
-  (define add-prim
-    (lambda (x)
-      (let ([g (gensym (symbol->string x))])
-        (putprop x '|#system| g)
-        (putprop g '*sc-expander* (cons 'core-primitive x)))))
-  (define add-macro
-    (lambda (x)
-      (let ([g (gensym (symbol->string x))]
-            [e (getprop x '*sc-expander*)])
-        (when e 
-          (putprop x '|#system| g)
-          (putprop g '*sc-expander* e)))))
-  (define (foo)
-    (eval 
-      `(begin
-         (define-syntax compile-time-date-string
-           (lambda (x)
-             #'(quote ,(date-string))))
-         (define-syntax public-primitives
-           (lambda (x)
-             #'(quote ,public-primitives)))
-         (define-syntax system-primitives
-           (lambda (x)
-             #'(quote ,system-primitives))) 
-         (define-syntax macros
-           (lambda (x)
-             #'(quote ,macros))))))
-  (set! system-env ($make-environment '|#system| #t))
-  (for-each add-macro macros)
-  (for-each add-prim public-primitives)
-  (for-each add-prim system-primitives)
-  (if setenv?
-      (parameterize ([interaction-environment system-env])
-        (foo))
-      (foo)))
-
-
-
-(when (eq? "" "")
-  (load "chez-compat.ss")
-  (set! primitive-ref top-level-value)
-  (set! primitive-set! set-top-level-value!)
-  (set! chez-expand sc-expand)
-  (set! chez-current-expand current-expand)
-  (printf "loading psyntax.pp ...\n")
-  (load "psyntax-7.1.pp")
-  (chez-current-expand
-    (lambda (x . args)
-      (apply chez-expand (sc-expand x) args)))
-  (whack-system-env #f)
-  (printf "loading psyntax.ss ...\n")
-  (load "psyntax-7.1-6.9.ss")
-  (chez-current-expand
-    (lambda (x . args)
-      (apply chez-expand (sc-expand x) args)))
-  (whack-system-env #t)
-  (printf "ok\n")
-  (load "libassembler-compat-6.7.ss") ; defines make-code etc.
-  (load "libintelasm-6.9.ss") ; uses make-code, etc.
-  (load "libfasl-6.7.ss") ; uses code? etc.
-  (load "libcompile-8.1.ss") ; uses fasl-write
-)
-
-
-(whack-system-env #t)
-
-(define scheme-library-files
-  '(["libhandlers-6.9.ss"   #t  "libhandlers.fasl"]
-    ["libcontrol-6.1.ss"    #t  "libcontrol.fasl"]
-    ["libcollect-6.1.ss"    #t  "libcollect.fasl"]
-    ["librecord-6.4.ss"     #t  "librecord.fasl"]
-    ["libcxr-6.0.ss"        #t  "libcxr.fasl"]
-    ["libnumerics-9.1.ss"   #t  "libnumerics.fasl"]
-    ["libcore-6.9.ss"       #t  "libcore.fasl"]
-    ["libchezio-8.1.ss"     #t  "libchezio.fasl"]
-    ["libhash-6.2.ss"       #t  "libhash.fasl"]
-    ["libwriter-9.1.ss"     #t  "libwriter.fasl"]
-    ["libtokenizer-9.1.ss"  #t  "libtokenizer.fasl"]
-    ["libassembler-6.7.ss"  #t  "libassembler.ss"]
-    ["libintelasm-6.9.ss"   #t  "libintelasm.fasl"]
-    ["libfasl-6.7.ss"       #t  "libfasl.fasl"]
-    ["libcompile-9.1.ss"    #t  "libcompile.fasl"]
-    ["psyntax-7.1-9.1.ss"   #t  "psyntax.fasl"]
-    ["libinterpret-6.5.ss"  #t  "libinterpret.fasl"]
-    ["libcafe-6.1.ss"       #t  "libcafe.fasl"]
-    ["libtrace-6.9.ss"      #t  "libtrace.fasl"]
-    ["libposix-6.0.ss"      #t  "libposix.fasl"]
-    ["libtoplevel-6.9.ss"   #t  "libtoplevel.fasl"]
-    ))
-
-
-
-(define (compile-library ifile ofile)
-  (parameterize ([assembler-output #f] 
-                 [expand-mode 'bootstrap]
-                 [interaction-environment system-env])
-     (printf "compiling ~a ...\n" ifile)
-     (compile-file ifile ofile 'replace)))
-
-(for-each 
-  (lambda (x)
-    (when (cadr x)
-      (compile-library (car x) (caddr x))))
-  scheme-library-files)
-
-
-(define (join s ls)
-  (cond
-    [(null? ls) ""]
-    [else
-     (let ([str (open-output-string)])
-       (let f ([a (car ls)] [d (cdr ls)])
-         (cond
-           [(null? d)
-            (display a str)
-            (get-output-string str)]
-           [else
-            (display a str)
-            (display s str)
-            (f (car d) (cdr d))])))]))
-   
-
-(system
-  (format "cat ~a > ikarus.fasl"
-          (join " " (map caddr scheme-library-files))))
diff --git a/src/ikarus.boot b/src/ikarus.boot
index eba0775..1ea6a1c 100644
Binary files a/src/ikarus.boot and b/src/ikarus.boot differ
diff --git a/src/ikarus.boot.back b/src/ikarus.boot.back
new file mode 100644
index 0000000..ff79ab8
Binary files /dev/null and b/src/ikarus.boot.back differ
diff --git a/src/libassembler-6.7.ss b/src/libassembler.ss
similarity index 100%
rename from src/libassembler-6.7.ss
rename to src/libassembler.ss
diff --git a/src/libcafe-6.1.ss b/src/libcafe.ss
similarity index 100%
rename from src/libcafe-6.1.ss
rename to src/libcafe.ss
diff --git a/src/libchezio-8.1.ss b/src/libchezio.ss
similarity index 100%
rename from src/libchezio-8.1.ss
rename to src/libchezio.ss
diff --git a/src/libcollect-6.1.ss b/src/libcollect.ss
similarity index 100%
rename from src/libcollect-6.1.ss
rename to src/libcollect.ss
diff --git a/src/libcompile-8.1.ss b/src/libcompile-8.1.ss
deleted file mode 100644
index 984d346..0000000
--- a/src/libcompile-8.1.ss
+++ /dev/null
@@ -1,3771 +0,0 @@
-
-;;; 6.7: * open-coded top-level-value, car, cdr
-;;; 6.2: * side-effects now modify the dirty-vector
-;;;      * added bwp-object?
-;;;      * added pointer-value
-;;;      * added tcbuckets
-;;; 6.1: * added case-lambda, dropped lambda
-;;; 6.0: * basic compiler
-
-(let ()
-
-(define-syntax cond-expand
-  (lambda (x)
-    (syntax-case x ()
-      [(_ test conseq altern)
-       (if (eval (syntax-object->datum #'test))
-           #'conseq
-           #'altern)])))
-
-(cond-expand (eq? "" "")
-  (include "record-case.chez.ss")
-  (include "record-case.ss"))
-
-
-(include "set-operations.ss")
-
-
-(define open-coded-primitives
-;;; these primitives, when found in operator position with the correct
-;;; number of arguments, will be open-coded by the generator.  If an 
-;;; incorrect number of args is detected, or if they appear in non-operator
-;;; position, then they cannot be open-coded, and the pcb-primitives table
-;;; is consulted for a reference of the pcb slot containing the primitive.
-;;; If it's not found there, an error is signalled.
-;;;
-;;; prim-name          args
-  '([$constant-ref      1   value]
-    [$constant-set!     2   effect]
-    [$pcb-ref           1   value]
-    [$pcb-set!          2   effect]
-    ;;; type predicates
-    [fixnum?            1   pred]
-    [immediate?         1   pred]
-    [boolean?           1   pred]
-    [char?              1   pred]
-    [pair?              1   pred]
-    [symbol?            1   pred]
-    [vector?            1   pred]
-    [string?            1   pred]
-    [procedure?         1   pred]
-    [null?              1   pred]
-    [eof-object?        1   pred]
-    [bwp-object?        1   pred]
-    [$unbound-object?   1   pred]
-    [$forward-ptr?      1   pred]
-    [not                1   pred]
-    [pointer-value      1  value]
-    [eq?                2   pred]
-    ;;; fixnum primitives
-    [$fxadd1            1   value]
-    [$fxsub1            1   value]
-    [$fx+               2   value]
-    [$fx-               2   value]
-    [$fx*               2   value]
-    [$fxsll             2   value]
-    [$fxsra             2   value]
-    [$fxlogand          2   value]
-    [$fxlogor           2   value]
-    [$fxlogxor          2   value]
-    [$fxlognot          1   value]
-    [$fxquotient        2   value]
-    [$fxmodulo          2   value]
-    ;;; fixnum predicates
-    [$fxzero?           1   pred]
-    [$fx=               2   pred]
-    [$fx<               2   pred]
-    [$fx<=              2   pred]
-    [$fx>               2   pred]
-    [$fx>=              2   pred]
-    ;;; character predicates
-    [$char=             2   pred]
-    [$char<             2   pred]
-    [$char<=            2   pred]
-    [$char>             2   pred]
-    [$char>=            2   pred]
-    ;;; character conversion
-    [$fixnum->char      1   value]
-    [$char->fixnum      1   value]
-    ;;; lists/pairs
-    [cons               2   value]
-    [list*         positive value]
-    [list             any   value]
-    [car                1   value]
-    [cdr                1   value]
-    [$car               1   value]
-    [$cdr               1   value]
-    [$set-car!          2   effect]
-    [$set-cdr!          2   effect]
-    ;;; vectors
-    [$make-vector       1   value]
-    [vector           any   value]
-    [$vector-length     1   value]
-    [$vector-ref        2   value]
-    [$vector-set!       3   effect]
-    [$vector-memq       2   value]
-    ;;; strings
-    [$make-string       1   value]
-    [$string          any   value]
-    [$string-length     1   value]
-    [$string-ref        2   value]
-    [$string-set!       3   effect]
-    ;;; symbols
-    [$make-symbol       1   value]
-    [$symbol-value      1   value]
-    [$symbol-string     1   value]
-    [$symbol-unique-string     1   value]
-    [$set-symbol-value! 2   effect]
-    [$set-symbol-string! 2   effect]
-    [$set-symbol-unique-string! 2   effect]
-    [$symbol-plist      1   value]
-    [$set-symbol-plist! 2   effect]
-    [primitive-ref 1 value]
-    [primitive-set! 2 effect]
-    [top-level-value      1   value]
-    ;;; ports
-    [port?                    1 pred]
-    [input-port?              1 pred]
-    [output-port?             1 pred]
-    [$make-port/input         7 value]
-    [$make-port/output        7 value]
-    [$make-port/both          7 value]
-    [$port-handler            1 value]
-    [$port-input-buffer       1 value]
-    [$port-input-index        1 value]
-    [$port-input-size         1 value]
-    [$port-output-buffer      1 value]
-    [$port-output-index       1 value]
-    [$port-output-size        1 value]
-    [$set-port-input-index!   2 effect]
-    [$set-port-input-size!    2 effect]
-    [$set-port-output-index!  2 effect]
-    [$set-port-output-size!   2 effect]
-    ;;; tcbuckets
-    [$make-tcbucket       4   value]
-    [$tcbucket-key        1   value]
-    [$tcbucket-val        1   value]
-    [$tcbucket-next       1   value]
-    [$set-tcbucket-val!   2  effect]
-    [$set-tcbucket-next!  2  effect]
-    [$set-tcbucket-tconc! 2  effect]
-    ;;; misc
-    [eof-object         0   value]
-    [void               0   value]
-    [$exit              1   effect]
-    [$fp-at-base        0   pred]
-    [$current-frame     0   value]
-    [$seal-frame-and-call 1  tail]
-    [$frame->continuation 1 value]
-    ;;; 
-    ;;; records
-    ;;;
-    [$make-record       2   value]
-    [$record?           1    pred]
-    [$record/rtd?       2    pred]
-    [$record-rtd        1   value]
-    [$record-ref        2   value]
-    [$record-set!       3  effect]
-    [$record          any   value]
-    ;;;
-    ;;; asm
-    ;;;
-    [$code?              1    pred]
-    [$code-size          1    value]
-    [$code-reloc-vector  1    value]
-    [$code-freevars      1    value]
-    [$code-ref           2    value]
-    [$code-set!          3    value]
-    [$code->closure      1    value]
-    ;;;
-    [$make-call-with-values-procedure 0 value]
-    [$make-values-procedure 0 value]
-    [$install-underflow-handler 0 effect]
-   ))
-
-(define (primitive-context x)
-  (cond
-    [(assq x open-coded-primitives) => caddr]
-    [else (error 'primitive-context "unknown prim ~s" x)]))
-
-(define (open-codeable? x)
-  (cond
-    [(assq x open-coded-primitives) #t]
-    [else  #f]))
-
-(define (open-coded-primitive-args x)
-  (cond
-    [(assq x open-coded-primitives) => cadr]
-    [else (error 'open-coded-primitive-args "invalid ~s" x)]))
-
-;;; end of primitives table section
-
-  
-(define-record constant (value))
-(define-record code-loc (label))
-(define-record foreign-label (label))
-(define-record var (name assigned))
-(define-record cp-var (idx))
-(define-record frame-var (idx))
-(define-record new-frame (base-idx size body))
-(define-record save-cp (loc))
-(define-record eval-cp (check body))
-(define-record return (value))
-(define-record call-cp
-  (call-convention rp-convention base-idx arg-count live-mask))
-(define-record tailcall-cp (convention arg-count))
-(define-record primcall (op arg*))
-(define-record primref (name))
-(define-record conditional (test conseq altern))
-(define-record bind (lhs* rhs* body))
-(define-record recbind (lhs* rhs* body))
-(define-record fix (lhs* rhs* body))
-
-(define-record seq (e0 e1))
-(define-record clambda-case (arg* proper body))
-(define-record clambda (cases))
-(define-record clambda-code (label cases free))
-(define-record closure (code free*))
-(define-record funcall (op rand*))
-(define-record appcall (op rand*))
-(define-record forcall (op rand*))
-(define-record code-rec (arg* proper free* body))
-(define-record codes (list body))
-(define-record assign (lhs rhs))
-
-(define (unique-var x)
-  (make-var (gensym (symbol->string x)) #f))
-
-
-(define (make-bind^ lhs* rhs* body)
-  (if (null? lhs*)
-      body
-      (make-bind lhs* rhs* body)))
-
-(define (recordize x)
-  (define (gen-fml* fml*)
-    (cond
-      [(pair? fml*)
-       (cons (unique-var (car fml*))
-             (gen-fml* (cdr fml*)))]
-      [(symbol? fml*)
-       (unique-var fml*)]
-      [else '()]))
-  (define (properize fml*)
-    (cond
-      [(pair? fml*)
-       (cons (car fml*) (properize (cdr fml*)))]
-      [(null? fml*) '()]
-      [else (list fml*)]))
-  (define (extend-env fml* nfml* env)
-    (cons (cons fml* nfml*) env))
-  (define (quoted-sym x)
-    (if (and (list? x)
-             (fx= (length x) 2)
-             (eq? 'quote (car x))
-             (symbol? (cadr x)))
-        (cadr x)
-        (error 'quoted-sym "not a quoted symbol ~s" x)))
-   (define (quoted-string x)
-    (if (and (list? x)
-             (fx= (length x) 2)
-             (eq? 'quote (car x))
-             (string? (cadr x)))
-        (cadr x)
-        (error 'quoted-string "not a quoted string ~s" x)))
-  (define (lookup^ x lhs* rhs*)
-    (cond
-      [(pair? lhs*)
-       (if (eq? x (car lhs*))
-           (car rhs*)
-           (lookup^ x (cdr lhs*) (cdr rhs*)))]
-      [(eq? x lhs*) rhs*]
-      [else #f]))
-  (define (lookup x env)
-    (cond
-      [(pair? env)
-       (or (lookup^ x (caar env) (cdar env))
-           (lookup x (cdr env)))]
-      [else #f]))
-  (define (E x env)
-    (cond
-      [(pair? x)
-       (case (car x)
-         [(quote)  (make-constant (cadr x))]
-         [(if) 
-          (make-conditional 
-            (E (cadr x) env)
-            (E (caddr x) env)
-            (E (cadddr x) env))]
-         [(set!)
-          (let ([lhs (cadr x)] [rhs (caddr x)])
-            (make-assign
-              (or (lookup lhs env) 
-                  (error 'recordize "invalid assignment ~s" x))
-              (E rhs env)))]
-         [(begin)
-          (let f ([a (cadr x)] [d (cddr x)])
-            (cond
-              [(null? d) (E a env)]
-              [else
-               (make-seq 
-                 (E a env)
-                 (f (car d) (cdr d)))]))]
-         [(letrec)
-          (unless (fx= (length x) 3) (syntax-error x))
-          (let ([bind* (cadr x)] [body (caddr x)])
-            (let ([lhs* (map car bind*)]
-                  [rhs* (map cadr bind*)])
-              (let ([nlhs* (gen-fml* lhs*)])
-                (let ([env (extend-env lhs* nlhs* env)])
-                  (make-recbind nlhs* 
-                                (map (lambda (rhs) (E rhs env)) rhs*)
-                                (E body env))))))]
-         [(letrec)
-          (unless (fx= (length x) 3) (syntax-error x))
-          (let ([bind* (cadr x)] [body (caddr x)])
-            (let ([lhs* (map car bind*)]
-                  [rhs* (map cadr bind*)]
-                  [v* (map (lambda (x) '(void)) bind*)]
-                  [t* (map (lambda (x) (gensym)) bind*)])
-              (E `((case-lambda 
-                     [,lhs* 
-                       ((case-lambda 
-                          [,t* 
-                           (begin ,@(map (lambda (x v) `(set! ,x ,v)) lhs* t*)
-                                  ,body)])
-                        ,@rhs*)])
-                   ,@v*)
-                 env)))]
-         [(case-lambda)
-          (let ([cls*
-                 (map
-                   (lambda (cls)
-                     (let ([fml* (car cls)] [body (cadr cls)])
-                       (let ([nfml* (gen-fml* fml*)])
-                         (let ([body (E body (extend-env fml* nfml* env))])
-                           (make-clambda-case 
-                             (properize nfml*) 
-                             (list? fml*) 
-                             body)))))
-                   (cdr x))])
-            (make-clambda cls*))]
-         [(foreign-call)
-          (let ([name (quoted-string (cadr x))] [arg* (cddr x)])
-            (make-forcall name
-              (map (lambda (x) (E x env)) arg*)))]
-         [(|#primitive|)
-          (let ([var (cadr x)])
-            (make-primref var))]
-         ;;; [(|#primitive|)
-         ;;;  (let ([var (cadr x)])
-         ;;;    (if (primitive? var)
-         ;;;        (make-primref var)
-         ;;;        (error 'recordize "invalid primitive ~s" var)))]
-         [(top-level-value)
-          (let ([var (quoted-sym (cadr x))])
-            (if (eq? (expand-mode) 'bootstrap)
-                (error 'compile "reference to ~s in bootstrap mode" var)
-                ;(make-primref var)
-                (make-funcall
-                  (make-primref 'top-level-value)
-                  (list (make-constant var)))))]
-         ;;; [(top-level-value)
-         ;;;  (let ([var (quoted-sym (cadr x))])
-         ;;;    (if (eq? (expand-mode) 'bootstrap)
-         ;;;        (if (primitive? var)
-         ;;;            (make-primref var)
-         ;;;            (error 'compile "invalid primitive ~s" var))
-         ;;;        (make-funcall
-         ;;;          (make-primref 'top-level-value)
-         ;;;          (list (make-constant var)))))]
-         [(set-top-level-value!)
-          (make-funcall (make-primref 'set-top-level-value!)
-                        (map (lambda (x) (E x env)) (cdr x)))]
-         [(memv) 
-          (make-funcall
-             (make-primref 'memq)
-             (map (lambda (x) (E x env)) (cdr x)))]
-         [($apply)
-          (let ([proc (cadr x)] [arg* (cddr x)])
-            (make-appcall
-              (E proc env)
-              (map (lambda (x) (E x env)) arg*)))]
-         [(void) 
-          (make-constant (void))]
-         [else
-          (make-funcall 
-            (E (car x) env)
-            (map (lambda (x) (E x env)) (cdr x)))])]
-      [(symbol? x)
-       (or (lookup x env)
-           (error 'recordize "invalid reference in ~s" x))]
-      [else (error 'recordize "invalid expression ~s" x)]))
-  (E x '()))
-
-
-(define (unparse x)
-  (define (E-args proper x)
-    (if proper 
-        (map E x)
-        (let f ([a (car x)] [d (cdr x)])
-          (cond
-            [(null? d) (E a)]
-            [else (cons (E a) (f (car d) (cdr d)))]))))
-  (define (E x)
-    (record-case x
-      [(constant c) `(quote ,c)]
-      [(code-loc x) `(code-loc ,x)]
-      [(var x) (string->symbol (format "v:~a" x))]
-      [(primref x) x]
-      [(conditional test conseq altern) 
-       `(if ,(E test) ,(E conseq) ,(E altern))]
-      [(primcall op arg*) `(,op . ,(map E arg*))]
-      [(bind lhs* rhs* body) 
-       `(let ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
-          ,(E body))]
-      [(recbind lhs* rhs* body) 
-       `(letrec ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
-          ,(E body))]
-      [(fix lhs* rhs* body) 
-       `(fix ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
-          ,(E body))]
-      [(seq e0 e1) `(begin ,(E e0) ,(E e1))]
-      [(clambda-case args proper body)
-       `(clambda-case ,(E-args proper args) ,(E body))]
-      [(clambda cls*)
-       `(case-lambda . ,(map E cls*))]
-      [(clambda-code label clauses free)
-       `(code ,label . ,(map E clauses))]
-      [(closure code free*)
-       `(closure ,(E code) ,(map E free*))]
-      [(code-rec arg* proper free* body) 
-       `(code-rec [arg: ,(E-args proper arg*)]
-              [free: ,(map E free*)]
-          ,(E body))]
-      [(codes list body)
-       `(codes ,(map E list)
-          ,(E body))]
-      [(funcall rator rand*) `(funcall ,(E rator) . ,(map E rand*))]
-      [(appcall rator rand*) `(appcall ,(E rator) . ,(map E rand*))]
-      [(forcall rator rand*) `(foreign-call ,rator . ,(map E rand*))]
-      [(assign lhs rhs) `(set! ,(E lhs) ,(E rhs))]
-      [(return x) `(return ,(E x))]
-      [(new-frame base-idx size body)
-       `(new-frame [base: ,base-idx]
-                   [size: ,size]
-          ,(E body))]
-      [(frame-var idx) 
-       (string->symbol (format "fv.~a" idx))]
-      [(cp-var idx) 
-       (string->symbol (format "cp.~a" idx))]
-      [(save-cp expr)
-       `(save-cp ,(E expr))]
-      [(eval-cp check body)
-       `(eval-cp ,check ,(E body))]
-      [(call-cp call-convention rp-convention base-idx arg-count live-mask)
-       `(call-cp [conv: ,call-convention]
-                 [rpconv: ,rp-convention]
-                 [base-idx: ,base-idx]
-                 [arg-count: ,arg-count]
-                 [live-mask: ,live-mask])]
-      [(foreign-label x) `(foreign-label ,x)]
-      [else (error 'unparse "invalid record ~s" x)]))
-  (E x))
-
-(define (optimize-direct-calls x)
-  (define who 'optimize-direct-calls)
-  (define (make-conses ls)
-    (cond
-      [(null? ls) (make-constant '())]
-      [else 
-       (make-primcall 'cons 
-         (list (car ls) (make-conses (cdr ls))))]))      
-  (define (properize lhs* rhs*)
-    (cond
-      [(null? lhs*) (error who "improper improper")]
-      [(null? (cdr lhs*)) 
-       (list (make-conses rhs*))]
-      [else (cons (car rhs*) (properize (cdr lhs*) (cdr rhs*)))]))
-  (define (inline-case cls rand*)
-    (record-case cls
-      [(clambda-case fml* proper body)
-       (if proper
-           (and (fx= (length fml*) (length rand*))
-                (make-bind fml* rand* body))
-           (and (fx<= (length fml*) (length rand*))
-                (make-bind fml* (properize fml* rand*) body)))]))
-  (define (try-inline cls* rand* default)
-    (cond
-      [(null? cls*) default]
-      [(inline-case (car cls*) rand*)]
-      [else (try-inline (cdr cls*) rand* default)]))
-  (define (inline rator rand*)
-    (record-case rator
-      [(clambda cls*)
-       (try-inline cls* rand*
-           (make-funcall rator rand*))]
-      [else (make-funcall rator rand*)]))
-  (define (Expr x)
-    (record-case x
-      [(constant) x]
-      [(var) x]
-      [(primref) x]
-      [(bind lhs* rhs* body)
-       (make-bind lhs* (map Expr rhs*) (Expr body))]
-      [(recbind lhs* rhs* body)
-       (make-recbind lhs* (map Expr rhs*) (Expr body))]
-      [(conditional test conseq altern)
-       (make-conditional 
-         (Expr test)
-         (Expr conseq)
-         (Expr altern))]
-      [(seq e0 e1) 
-       (make-seq (Expr e0) (Expr e1))]
-      [(clambda cls*)
-       (make-clambda
-         (map (lambda (x)
-                (record-case x
-                  [(clambda-case fml* proper body)
-                   (make-clambda-case fml* proper (Expr body))]))
-              cls*))]
-      [(primcall rator rand*) 
-       (make-primcall rator (map Expr rand*))]
-      [(funcall rator rand*)
-       (inline (Expr rator) (map Expr rand*))]
-      [(appcall rator rand*)
-       (make-appcall (Expr rator) (map Expr rand*))]
-      [(forcall rator rand*) 
-       (make-forcall rator (map Expr rand*))]
-      [(assign lhs rhs)
-       (make-assign lhs (Expr rhs))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (Expr x))
-
-
-
-
-(define lambda-both 0)
-(define lambda-producer 0)
-(define lambda-consumer 0)
-(define lambda-none 0)
-(define branching-producer 0)
-
-
-(define (analyze-cwv x)
-  (define who 'analyze-cwv)
-  (define (lambda? x)
-    (record-case x
-      [(clambda) #t]
-      [else      #f]))
-  (define (branching-producer? x)
-    (define (bt? x)
-      (record-case x
-        [(bind lhs* rhs* body) (bt? body)]
-        [(recbind lhs* rhs* body) (bt? body)]
-        [(conditional test conseq altern) #t]
-        [(seq e0 e1) (bt? e1)]
-        [else #f]))
-    (define (branching-clause? x)
-      (record-case x 
-        [(clambda-case fml* proper body) 
-         (bt? body)]))
-    (record-case x
-      [(clambda cls*)
-       (ormap branching-clause? cls*)]
-      [else #f]))
-  (define (analyze producer consumer)
-    (cond
-      [(and (lambda? producer) (lambda? consumer))
-       (set! lambda-both (fxadd1 lambda-both))]
-      [(lambda? producer) 
-       (set! lambda-producer (fxadd1 lambda-producer))]
-      [(lambda? consumer)
-       (set! lambda-consumer (fxadd1 lambda-consumer))]
-      [else 
-       (set! lambda-none (fxadd1 lambda-none))])
-    (when (branching-producer? producer)
-      (set! branching-producer (fxadd1 branching-producer)))
-    (printf "both=~s p=~s c=~s none=~s branching-prod=~s\n"
-            lambda-both lambda-producer lambda-consumer lambda-none
-            branching-producer))
-  (define (E x)
-    (record-case x
-      [(constant) (void)]
-      [(var) (void)]
-      [(primref) (void)]
-      [(bind lhs* rhs* body)
-       (for-each E rhs*) (E body)]
-      [(recbind lhs* rhs* body)
-       (for-each E rhs*) (E body)]
-      [(conditional test conseq altern)
-       (E test)
-       (E conseq)
-       (E altern)]
-      [(seq e0 e1) (E e0) (E e1)]
-      [(clambda cls*)
-       (for-each 
-         (lambda (x)
-           (record-case x
-             [(clambda-case fml* proper body) (E body)]))
-         cls*)]
-      [(primcall rator rand*) 
-       (for-each E rand*)
-       (when (and (eq? rator 'call-with-values) (fx= (length rand*) 2))
-         (analyze (car rand*) (cadr rand*)))]
-      [(funcall rator rand*)
-       (E rator) (for-each E rand*)
-       (when (and (record-case rator
-                    [(primref op) (eq? op 'call-with-values)]
-                    [else #f])
-                  (fx= (length rand*) 2))
-         (analyze (car rand*) (cadr rand*)))]
-      [(appcall rator rand*)
-       (E rator) (for-each E rand*)]
-      [(forcall rator rand*) 
-       (for-each E rand*)]
-      [(assign lhs rhs)
-       (E rhs)]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (E x))
-
-
-
-
-(define (optimize-letrec x)
-  (define who 'optimize-letrec)
-  (define (extend-hash lhs* h ref)
-    (for-each (lambda (lhs) (put-hash-table! h lhs #t)) lhs*)
-    (lambda (x)
-      (unless (get-hash-table h x #f)
-        (put-hash-table! h x #t)
-        (ref x))))
-  (define (E* x* ref comp)
-    (cond
-      [(null? x*) '()]
-      [else
-       (cons (E (car x*) ref comp)
-             (E* (cdr x*) ref comp))]))  
-  (define (do-rhs* i lhs* rhs* ref comp vref vcomp)
-    (cond
-      [(null? rhs*) '()]
-      [else
-       (let ([h (make-hash-table)])
-         (let ([ref
-                (lambda (x)
-                  (unless (get-hash-table h x #f)
-                    (put-hash-table! h x #t)
-                    (ref x)
-                    (when (memq x lhs*)
-                      (vector-set! vref i #t))))]
-               [comp
-                (lambda ()
-                  (vector-set! vcomp i #t)
-                  (comp))])
-           (cons (E (car rhs*) ref comp)
-                 (do-rhs* (fxadd1 i) lhs* (cdr rhs*) ref comp vref vcomp))))]))
-  (define (partition-rhs* i lhs* rhs* vref vcomp)
-    (cond
-      [(null? lhs*) (values '() '() '() '() '() '())]
-      [else
-       (let-values 
-         ([(slhs* srhs* llhs* lrhs* clhs* crhs*)
-           (partition-rhs* (fxadd1 i) (cdr lhs*) (cdr rhs*) vref vcomp)]
-          [(lhs rhs) (values (car lhs*) (car rhs*))])
-         (cond
-           [(var-assigned lhs) 
-            (values slhs* srhs* llhs* lrhs* (cons lhs clhs*) (cons rhs crhs*))]
-           [(clambda? rhs)
-            (values slhs* srhs* (cons lhs llhs*) (cons rhs lrhs*) clhs* crhs*)]
-           [(or (vector-ref vref i) (vector-ref vcomp i))
-            (values slhs* srhs* llhs* lrhs* (cons lhs clhs*) (cons rhs crhs*))]
-           [else
-            (values (cons lhs slhs*) (cons rhs srhs*) llhs* lrhs* clhs* crhs*)]
-           ))]))
-  (define (do-recbind lhs* rhs* body ref comp)
-    (let ([h (make-hash-table)]
-          [vref (make-vector (length lhs*) #f)]
-          [vcomp (make-vector (length lhs*) #f)])
-      (let* ([ref (extend-hash lhs* h ref)]
-             [body (E body ref comp)])
-        (let ([rhs* (do-rhs* 0 lhs* rhs* ref comp vref vcomp)])
-          (let-values ([(slhs* srhs* llhs* lrhs* clhs* crhs*)
-                        (partition-rhs* 0 lhs* rhs* vref vcomp)])
-            (let ([v* (map (lambda (x) (make-primcall 'void '())) clhs*)]
-                  [t* (map (lambda (x) (unique-var 'tmp)) clhs*)])
-              (make-bind slhs* srhs*
-                (make-bind clhs* v*
-                  (make-fix llhs* lrhs*
-                    (make-bind t* crhs*
-                      (build-assign* clhs* t* body)))))))))))
-  (define (build-assign* lhs* rhs* body)
-    (cond
-      [(null? lhs*)  body]
-      [else
-       (make-seq
-         (make-assign (car lhs*) (car rhs*))
-         (build-assign* (cdr lhs*) (cdr rhs*) body))]))
-  (define (E x ref comp)
-    (record-case x
-      [(constant) x]
-      [(var) (ref x) x]
-      [(assign lhs rhs)
-       (set-var-assigned! lhs #t)
-       (ref lhs)
-       (make-assign lhs (E rhs ref comp))]
-      [(primref) x]
-      [(bind lhs* rhs* body)
-       (let ([rhs* (E* rhs* ref comp)])
-         (let ([h (make-hash-table)])
-           (let ([body (E body (extend-hash lhs* h ref) comp)])
-             (make-bind lhs* rhs* body))))]
-      [(recbind lhs* rhs* body)
-       (if (null? lhs*)
-           (E body ref comp)
-           (do-recbind lhs* rhs* body ref comp))]
-      [(conditional e0 e1 e2)
-       (make-conditional (E e0 ref comp) (E e1 ref comp) (E e2 ref comp))]
-      [(seq e0 e1) (make-seq (E e0 ref comp) (E e1 ref comp))]
-      [(clambda cls*)
-       (make-clambda
-         (map (lambda (x)
-                (record-case x
-                  [(clambda-case fml* proper body)
-                   (let ([h (make-hash-table)])
-                     (let ([body (E body (extend-hash fml* h ref) void)])
-                       (make-clambda-case fml* proper body)))]))
-              cls*))]
-      [(primcall rator rand*) 
-       (when (memq rator '(call/cc call/cf))
-         (comp))
-       (make-primcall rator (E* rand* ref comp))]
-      [(funcall rator rand*)
-       (let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)])
-         (record-case rator
-           [(primref op)
-            (when (memq op '(call/cc call/cf))
-              (comp))]
-           [else
-            (comp)])
-         (make-funcall rator rand*))]
-      [(appcall rator rand*)
-       (let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)])
-         (record-case rator
-           [(primref op)
-            (when (memq op '(call/cc call/cf))
-              (comp))]
-           [else
-            (comp)])
-         (make-appcall rator rand*))]
-      [(forcall rator rand*) 
-       (make-forcall rator (E* rand* ref comp))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (E x (lambda (x) (error who "free var ~s found" x))
-       void))
-
-
-(define (remove-letrec x)
-  (define who 'remove-letrec)
-  (define (Expr x)
-    (record-case x
-      [(constant) x]
-      [(var) x]
-      [(primref) x]
-      [(bind lhs* rhs* body)
-       (make-bind lhs* (map Expr rhs*) (Expr body))]
-      [(recbind lhs* rhs* body)
-       (let ([t* (map (lambda (lhs) (unique-var 'tmp)) lhs*)]
-             [v* (map (lambda (lhs) (make-primcall 'void '())) lhs*)])
-         (make-bind lhs* v*
-           (make-bind t* (map Expr rhs*)
-             (let f ([lhs* lhs*] [t* t*])
-               (cond
-                 [(null? lhs*) (Expr body)]
-                 [else
-                  (make-seq
-                    (make-assign (car lhs*) (car t*))
-                    (f (cdr lhs*) (cdr t*)))])))))]
-      ;[(fix lhs* rhs* body)
-      ; (Expr (make-recbind lhs* rhs* body))]
-      [(fix lhs* rhs* body)
-       (make-fix lhs* (map Expr rhs*) (Expr body))]
-      [(conditional test conseq altern)
-       (make-conditional 
-         (Expr test)
-         (Expr conseq)
-         (Expr altern))]
-      [(seq e0 e1) 
-       (make-seq (Expr e0) (Expr e1))]
-      [(clambda cls*)
-       (make-clambda
-         (map (lambda (x)
-                (record-case x
-                  [(clambda-case fml* proper body)
-                   (make-clambda-case fml* proper (Expr body))]))
-              cls*))]
-      [(primcall rator rand*) 
-       (make-primcall rator (map Expr rand*))]
-      [(funcall rator rand*)
-       (make-funcall (Expr rator) (map Expr rand*))]
-      [(appcall rator rand*)
-       (make-appcall (Expr rator) (map Expr rand*))]
-      [(forcall rator rand*) 
-       (make-forcall rator (map Expr rand*))]
-      [(assign lhs rhs)
-       (make-assign lhs (Expr rhs))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (Expr x))
-
-
-
-(define (uncover-assigned x)
-  (define who 'uncover-assigned)
-  (define (Expr* x*)
-    (for-each Expr x*))
-  (define (Expr x)
-    (record-case x
-      [(constant) (void)]
-      [(var) (void)]
-      [(primref) (void)]
-      [(bind lhs* rhs* body)
-       (begin (Expr body) (Expr* rhs*))]
-      [(recbind lhs* rhs* body)
-       (begin (Expr body) (Expr* rhs*))]
-      [(fix lhs* rhs* body)
-       (Expr* rhs*) 
-       (Expr body)
-       (when (ormap var-assigned lhs*)
-         (error 'uncover-assigned "a fix lhs is assigned"))]
-      [(conditional test conseq altern)
-       (begin (Expr test) (Expr conseq) (Expr altern))]
-      [(seq e0 e1) (begin (Expr e0) (Expr e1))]
-      [(clambda cls*)
-       (for-each
-         (lambda (cls)
-           (Expr (clambda-case-body cls)))
-         cls*)]
-      [(primcall rator rand*) (Expr* rand*)]
-      [(funcall rator rand*)
-       (begin (Expr rator) (Expr* rand*))]
-      [(appcall rator rand*)
-       (begin (Expr rator) (Expr* rand*))]
-      [(forcall rator rand*) (Expr* rand*)]
-      [(assign lhs rhs)
-       (set-var-assigned! lhs #t)
-       (Expr rhs)]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (Expr x))
-
-
-
-(define (rewrite-assignments x)
-  (define who 'rewrite-assignments)
-  (define (fix-lhs* lhs*)
-    (cond
-      [(null? lhs*) (values '() '() '())]
-      [else
-       (let ([x (car lhs*)])
-         (let-values ([(lhs* a-lhs* a-rhs*) (fix-lhs* (cdr lhs*))])
-           (cond
-             [(var-assigned x)
-              (let ([t (unique-var 'assignment-tmp)])
-                (values (cons t lhs*) (cons x a-lhs*) (cons t a-rhs*)))]
-             [else
-              (values (cons x lhs*) a-lhs* a-rhs*)])))]))
-  (define (bind-assigned lhs* rhs* body)
-    (cond
-      [(null? lhs*) body]
-      [else
-       (make-bind lhs*
-         (map (lambda (rhs) (make-primcall 'vector (list rhs))) rhs*)
-         body)]))
-  (define (Expr x)
-    (record-case x
-      [(constant) x]
-      [(var) 
-       (cond
-         [(var-assigned x) 
-          (make-primcall '$vector-ref (list x (make-constant 0)))]
-         [else x])]
-      [(primref) x]
-      [(bind lhs* rhs* body)
-       (let-values ([(lhs* a-lhs* a-rhs*) (fix-lhs* lhs*)]) 
-         (make-bind lhs* (map Expr rhs*) 
-           (bind-assigned a-lhs* a-rhs* (Expr body))))]
-      [(fix lhs* rhs* body)
-       (make-fix lhs* (map Expr rhs*) (Expr body))]
-      [(conditional test conseq altern)
-       (make-conditional (Expr test) (Expr conseq) (Expr altern))]
-      [(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
-      [(clambda cls*) 
-       (make-clambda
-         (map (lambda (cls)
-                (record-case cls
-                  [(clambda-case fml* proper body)
-                   (let-values ([(fml* a-lhs* a-rhs*) (fix-lhs* fml*)])
-                     (make-clambda-case fml* proper 
-                       (bind-assigned a-lhs* a-rhs* (Expr body))))]))
-              cls*))]
-      [(primcall op rand*)
-       (make-primcall op (map Expr rand*))]
-      [(forcall op rand*)
-       (make-forcall op (map Expr rand*))]
-      [(funcall rator rand*)
-       (make-funcall (Expr rator) (map Expr rand*))]
-      [(appcall rator rand*)
-       (make-appcall (Expr rator) (map Expr rand*))]
-      [(assign lhs rhs)
-       (unless (var-assigned lhs)
-         (error 'rewrite-assignments "not assigned ~s in ~s" lhs x))
-       (make-primcall '$vector-set! (list lhs (make-constant 0) (Expr rhs)))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (Expr x))
- 
-
-(define (remove-assignments x)
-    (uncover-assigned x)
-    (rewrite-assignments x))
-  
-
-
-
-
-(define (convert-closures prog)
-  (define who 'convert-closures)
-  (define (Expr* x*)
-    (cond
-      [(null? x*) (values '() '())]
-      [else
-       (let-values ([(a a-free) (Expr (car x*))]
-                    [(d d-free) (Expr* (cdr x*))])
-         (values (cons a d) (union a-free d-free)))]))
-   (define (do-clambda* x*)
-    (cond
-      [(null? x*) (values '() '())]
-      [else
-       (let-values ([(a a-free) (do-clambda (car x*))]
-                    [(d d-free) (do-clambda* (cdr x*))])
-         (values (cons a d) (union a-free d-free)))]))
-  (define (do-clambda x)
-    (record-case x 
-      [(clambda cls*)
-       (let-values ([(cls* free) 
-                     (let f ([cls* cls*])
-                       (cond
-                         [(null? cls*) (values '() '())]
-                         [else
-                          (record-case (car cls*)
-                            [(clambda-case fml* proper body)
-                             (let-values ([(body body-free) (Expr body)]
-                                          [(cls* cls*-free) (f (cdr cls*))])
-                               (values
-                                 (cons (make-clambda-case fml* proper body)
-                                       cls*)
-                                 (union (difference body-free fml*) 
-                                        cls*-free)))])]))])
-          (values (make-closure (make-clambda-code (gensym) cls* free) free)
-                  free))]))
-  (define (Expr ex)
-    (record-case ex
-      [(constant) (values ex '())]
-      [(var) (values ex (singleton ex))]
-      [(primref) (values ex '())]
-      [(bind lhs* rhs* body)
-       (let-values ([(rhs* rhs-free) (Expr* rhs*)] 
-                    [(body body-free) (Expr body)])
-          (values (make-bind lhs* rhs* body)
-                  (union rhs-free (difference body-free lhs*))))]
-      [(fix lhs* rhs* body)
-       (let-values ([(rhs* rfree) (do-clambda* rhs*)]
-                    [(body bfree) (Expr body)])
-          (values (make-fix lhs* rhs* body)
-                  (difference (union bfree rfree) lhs*)))]
-      [(conditional test conseq altern)
-       (let-values ([(test test-free) (Expr test)]
-                    [(conseq conseq-free) (Expr conseq)]
-                    [(altern altern-free) (Expr altern)])
-         (values (make-conditional test conseq altern)
-                 (union test-free (union conseq-free altern-free))))]
-      [(seq e0 e1) 
-       (let-values ([(e0 e0-free) (Expr e0)]
-                    [(e1 e1-free) (Expr e1)])
-         (values (make-seq e0 e1) (union e0-free e1-free)))]
-      [(clambda)
-       (do-clambda ex)]
-      [(primcall op rand*)
-       (let-values ([(rand* rand*-free) (Expr* rand*)])
-         (values (make-primcall op rand*)  rand*-free))]
-      [(forcall op rand*)
-       (let-values ([(rand* rand*-free) (Expr* rand*)])
-         (values (make-forcall op rand*)  rand*-free))]
-      [(funcall rator rand*)
-       (let-values ([(rator rat-free) (Expr rator)]
-                    [(rand* rand*-free) (Expr* rand*)])
-         (values (make-funcall rator rand*) 
-                 (union rat-free rand*-free)))]
-      [(appcall rator rand*)
-       (let-values ([(rator rat-free) (Expr rator)]
-                    [(rand* rand*-free) (Expr* rand*)])
-         (values (make-appcall rator rand*) 
-                 (union rat-free rand*-free)))]
-      [else (error who "invalid expression ~s" (unparse ex))]))
-  (let-values ([(prog free) (Expr prog)])
-    (unless (null? free) 
-      (error 'convert-closures "free vars ~s encountered in ~a"
-          free (unparse prog)))
-   prog))
-
-
-(define (lift-codes x)
-  (define who 'lift-codes)
-  (define all-codes '())
-  (define (do-code x)
-    (record-case x
-      [(clambda-code label cls* free) 
-       (let ([cls* (map 
-                     (lambda (x)
-                       (record-case x
-                         [(clambda-case fml* proper body)
-                          (make-clambda-case fml* proper (E body))]))
-                     cls*)])
-         (let ([g (make-code-loc label)])
-           (set! all-codes
-             (cons (make-clambda-code label cls* free) all-codes))
-           g))]))
-  (define (E x)
-    (record-case x
-      [(constant) x]
-      [(var)      x]
-      [(primref)  x]
-      [(bind lhs* rhs* body)
-       (make-bind lhs* (map E rhs*) (E body))]
-      [(fix lhs* rhs* body)
-       (make-fix lhs* (map E rhs*) (E body))]
-      [(conditional test conseq altern)
-       (make-conditional (E test) (E conseq) (E altern))]
-      [(seq e0 e1)           (make-seq (E e0) (E e1))]
-      [(closure c free)      (make-closure (do-code c) free)]
-      [(primcall op rand*)   (make-primcall op (map E rand*))]
-      [(forcall op rand*)    (make-forcall op (map E rand*))]
-      [(funcall rator rand*) (make-funcall (E rator) (map E rand*))]
-      [(appcall rator rand*) (make-appcall (E rator) (map E rand*))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (let ([x (E x)])
-    (make-codes all-codes x)))
-
-
-
-            
-(define (syntactically-valid? op rand*)
-  (define (valid-arg-count? op rand*)
-    (let ([n (open-coded-primitive-args op)] [m (length rand*)])
-      (cond
-        [(eq? n 'any) #t]
-        [(eq? n 'positive) (fx> m 1)]
-        [(eq? n 'no-code) 
-         (error 'syntactically-valid
-           "should not primcall non codable prim ~s" op)]
-        [(fixnum? n) 
-         (cond
-          [(fx= n m) #t]
-          [else
-           (error 'compile 
-             "Possible incorrect number of args in ~s"
-              (cons op (map unparse rand*)))
-           #f])]
-        [else (error 'do-primcall "BUG: what ~s" n)])))
-  (define (check op pred?)
-    (lambda (arg)
-      (record-case arg
-        [(constant c)
-         (cond
-           [(pred? c) #t]
-           [else
-            (error 'compile "Possible argument error to primitive ~s" op)
-            #f])]
-        [(primref) 
-         (cond
-           [(pred? (lambda (x) x)) #t]
-           [else
-            (error 'compile "Possible argument error to primitive ~s" op)
-            #f])]
-        [else #t])))
-  (define (nonnegative-fixnum? n)
-    (and (fixnum? n) (fx>= n 0)))
-  (define (byte? n)
-    (and (fixnum? n) (fx<= 0 n) (fx<= n 127)))
-  (define (valid-arg-types? op rand*)
-    (case op
-      [(fixnum? immediate? boolean? char? vector? string? procedure?
-        null? pair? not cons eq? vector symbol? error eof-object eof-object? 
-        void $unbound-object? $code? $forward-ptr? bwp-object?
-        pointer-value top-level-value car cdr list* list $record
-        port? input-port? output-port?
-        $make-port/input $make-port/output $make-port/both
-        $port-handler 
-        $port-input-buffer $port-input-index $port-input-size
-        $port-output-buffer $port-output-index $port-output-size 
-        $set-port-input-index! $set-port-input-size! 
-        $set-port-output-index! $set-port-output-size! ) 
-       '#t]
-      [($fxadd1 $fxsub1 $fxzero? $fxlognot $fxlogor $fxlogand $fx+ $fx- $fx* 
-        $fx= $fx< $fx<= $fx> $fx>= $fxquotient $fxmodulo $fxsll $fxsra $fxlogxor $exit) 
-       (andmap (check op fixnum?) rand*)]
-      [($fixnum->char) 
-       (andmap (check op byte?) rand*)]
-      [($char->fixnum $char= $char< $char<= $char> $char>= $string)
-       (andmap (check op char?) rand*)]
-      [($make-vector $make-string)
-       (andmap (check op nonnegative-fixnum?) rand*)]
-      [($car $cdr) 
-       (andmap (check op pair?) rand*)]
-      [($vector-length) 
-       (andmap (check op vector?) rand*)]
-      [($string-length) 
-       (andmap (check op string?) rand*)]
-      [($set-car! $set-cdr!)
-       ((check op pair?) (car rand*))]
-      [($vector-ref $vector-set!)
-       (and ((check op vector?) (car rand*))
-            ((check op nonnegative-fixnum?) (cadr rand*)))]
-      [($string-ref $string-set!
-        $string-ref-16+0 $string-ref-16+1 $string-ref-8+0 $string-ref-8+2)
-       (and ((check op string?) (car rand*))
-            ((check op nonnegative-fixnum?) (cadr rand*)))]
-      [($symbol-string $symbol-unique-string)
-       (andmap (check op symbol?) rand*)]
-      [($constant-ref $set-constant! $intern $pcb-set! $pcb-ref $make-symbol
-        $symbol-value $set-symbol-value! $symbol-plist $set-symbol-plist!
-        $set-symbol-system-value! $set-symbol-system-value!
-        $set-symbol-unique-string!
-        $set-symbol-string!
-        $seal-frame-and-call  $frame->continuation $code->closure
-        $code-size $code-reloc-vector $code-freevars 
-        $code-ref $code-set!
-        $make-record $record? $record/rtd? $record-rtd $record-ref $record-set!
-        primitive-set! primitive-ref
-        $make-tcbucket $tcbucket-key $tcbucket-val $tcbucket-next
-        $set-tcbucket-val! $set-tcbucket-next! $set-tcbucket-tconc!)
-       #t]
-      [else (error 'valid-arg-types? "unhandled op ~s" op)]))
-  (and (valid-arg-count? op rand*)
-       (or (null? rand*)
-           (valid-arg-types? op rand*))))
-
-
-;;; the output of simplify-operands differs from the input in that the 
-;;; operands to primcalls are all simple (variables, primrefs, or constants).
-;;; funcalls to open-codable primrefs whos arguments are "ok" are converted to
-;;; primcalls.  
-
-
-(define uninlined '())
-(define (mark-uninlined x)
-  (cond
-    [(assq x uninlined) =>
-     (lambda (p) (set-cdr! p (fxadd1 (cdr p))))]
-    [else (set! uninlined (cons (cons x 1) uninlined))]))
-
-(module ()
-  (primitive-set! 'uninlined-stats 
-    (lambda () 
-      (let f ([ls uninlined] [ac '()])
-        (cond
-          [(null? ls) ac]
-          [(fx> (cdar ls) 15)
-           (f (cdr ls) (cons (car ls) ac))]
-          [else (f (cdr ls) ac)])))))
-
-(define (introduce-primcalls x)
-  (define who 'introduce-primcalls)
-  (define (simple? x) 
-    (or (constant? x) (var? x) (primref? x)))
-  (define (Expr x)
-    (record-case x
-      [(constant) x]
-      [(var) x]
-      [(primref) x]
-      [(closure) x]
-      [(bind lhs* rhs* body)
-       (make-bind lhs* (map Expr rhs*) (Expr body))]
-      [(fix lhs* rhs* body)
-       (make-fix lhs* (map Expr rhs*) (Expr body))]
-      [(conditional test conseq altern)
-       (make-conditional (Expr test) (Expr conseq) (Expr altern))]
-      [(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
-      [(primcall op arg*)
-       (case op
-         ;[(values) 
-         ; (if (fx= (length arg*) 1)
-         ;     (Expr (car arg*))
-         ;     (begin
-         ;       (warning 'compile "possible incorrect number of values")
-         ;       (make-funcall (make-primref 'values) (map Expr arg*))))]
-         [else 
-          (make-primcall op (map Expr arg*))])]
-      [(forcall op arg*)
-       (make-forcall op (map Expr arg*))]
-      [(funcall rator rand*)
-       (cond
-         [(and (primref? rator) 
-               (open-codeable? (primref-name rator))
-               (syntactically-valid? (primref-name rator) rand*))
-          (Expr (make-primcall (primref-name rator) rand*))]
-         [else
-          (when (primref? rator)
-            (mark-uninlined (primref-name rator)))
-          (make-funcall (Expr rator) (map Expr rand*))])]
-      [(appcall op arg*)
-       (make-appcall (Expr op) (map Expr arg*))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (define (Tail x)
-    (record-case x
-      [(constant) (make-return x)]
-      [(var) (make-return x)]
-      [(primref) (make-return x)]
-      [(closure) (make-return x)]
-      [(bind lhs* rhs* body)
-       (make-bind lhs* (map Expr rhs*) (Tail body))]
-      [(fix lhs* rhs* body)
-       (make-fix lhs* (map Expr rhs*) (Tail body))]
-      [(conditional test conseq altern)
-       (make-conditional (Expr test) (Tail conseq) (Tail altern))]
-      [(seq e0 e1) (make-seq (Expr e0) (Tail e1))]
-      [(primcall op arg*)
-       (case op
-         ;[(values) 
-         ; (if (fx= (length arg*) 1)
-         ;     (make-return (Expr (car arg*)))
-         ;     (make-return* (map Expr arg*)))]
-         [else
-          (make-return (make-primcall op (map Expr arg*)))])]
-      [(forcall op arg*)
-       (make-return (make-forcall op (map Expr arg*)))]
-      [(funcall rator rand*)
-       (cond
-         [(and (primref? rator)
-               (open-codeable? (primref-name rator))
-               (syntactically-valid? (primref-name rator) rand*))
-          (Tail (make-primcall (primref-name rator) rand*))]
-         [else
-          (make-funcall (Expr rator) (map Expr rand*))])]
-      [(appcall op arg*)
-       (make-appcall (Expr op) (map Expr arg*))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (define (CaseExpr x)
-    (record-case x
-      [(clambda-case fml* proper body)
-       (make-clambda-case fml* proper (Tail body))]))
-  (define (CodeExpr x)
-    (record-case x
-      [(clambda-code L cases free) 
-       (make-clambda-code L (map CaseExpr cases) free)]))
-  (define (CodesExpr x)
-    (record-case x 
-      [(codes list body)
-       (make-codes (map CodeExpr list) (Tail body))]))
-  (CodesExpr x))
-
-
-(define (simplify-operands x)
-  (define who 'simplify-operands)
-  (define (simple? x) 
-    (or (constant? x) (var? x) (primref? x)))
-  (define (simplify arg lhs* rhs* k)
-    (if (simple? arg)
-        (k arg lhs* rhs*)
-        (let ([v (unique-var 'tmp)])
-          (k v (cons v lhs*) (cons (Expr arg) rhs*)))))
-  (define (simplify* arg* lhs* rhs* k)
-    (cond
-      [(null? arg*) (k '() lhs* rhs*)]
-      [else 
-       (simplify (car arg*) lhs* rhs*
-         (lambda (a lhs* rhs*)
-           (simplify* (cdr arg*) lhs* rhs*
-             (lambda (d lhs* rhs*)
-               (k (cons a d) lhs* rhs*)))))]))
-  (define (Expr x)
-    (record-case x
-      [(constant) x]
-      [(var) x]
-      [(primref) x]
-      [(closure) x]
-      [(bind lhs* rhs* body)
-       (make-bind lhs* (map Expr rhs*) (Expr body))]
-      [(fix lhs* rhs* body)
-       (make-fix lhs* (map Expr rhs*) (Expr body))]
-      [(conditional test conseq altern)
-       (make-conditional (Expr test) (Expr conseq) (Expr altern))]
-      [(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
-      [(primcall op arg*)
-       (cond
-         [(memq op '(not car cdr))
-          (make-primcall op (map Expr arg*))]
-         [else
-          (simplify* arg* '() '()
-            (lambda (arg* lhs* rhs*)
-              (make-bind^ lhs* rhs* 
-                (make-primcall op arg*))))])]
-      [(forcall op arg*)
-       (make-forcall op (map Expr arg*))]
-      [(funcall rator rand*)
-       (make-funcall (Expr rator) (map Expr rand*))]
-      [(appcall op arg*)
-       (make-appcall (Expr op) (map Expr arg*))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (define (Tail x)
-    (record-case x
-      [(return v) (make-return (Expr v))]
-      [(bind lhs* rhs* body)
-       (make-bind lhs* (map Expr rhs*) (Tail body))]
-      [(fix lhs* rhs* body)
-       (make-fix lhs* (map Expr rhs*) (Tail body))]
-      [(conditional test conseq altern)
-       (make-conditional (Expr test) (Tail conseq) (Tail altern))]
-      [(seq e0 e1) (make-seq (Expr e0) (Tail e1))]
-      [(funcall rator rand*)
-       (make-funcall (Expr rator) (map Expr rand*))]
-      [(appcall op arg*)
-       (make-appcall (Expr op) (map Expr arg*))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (define (CaseExpr x)
-    (record-case x 
-      [(clambda-case fml* proper body)
-       (make-clambda-case fml* proper (Tail body))]))
-  (define (CodeExpr x)
-    (record-case x
-      [(clambda-code L clauses free)
-       (make-clambda-code L (map CaseExpr clauses) free)]))
-  (define (CodesExpr x)
-    (record-case x 
-      [(codes list body)
-       (make-codes (map CodeExpr list) (Tail body))]))
-  (CodesExpr x))
-
-
-(define (insert-stack-overflow-checks x)
-  (define who 'insert-stack-overflow-checks)
-  (define (insert-check body)
-    (make-seq
-      (make-conditional 
-        (make-primcall '$fp-overflow '())
-        (make-funcall (make-primref 'do-stack-overflow) '())
-        (make-primcall 'void '()))
-      body))
-  (define (Expr x)
-    (record-case x
-      [(constant) #f]
-      [(var) #f]
-      [(primref) #f]
-      [(closure code free*) #f]
-      [(bind lhs* rhs* body)
-       (or (ormap Expr rhs*) (Expr body))]
-      [(fix lhs* rhs* body) (Expr body)]
-      [(conditional test conseq altern)
-       (or (Expr test) (Expr conseq) (Expr altern))]
-      [(seq e0 e1) (or (Expr e0) (Expr e1))]
-      [(primcall op arg*) (ormap Expr arg*)]
-      [(forcall op arg*)  (ormap Expr arg*)]
-      [(funcall rator arg*) #t] 
-      [(appcall rator arg*)    #t]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (define (Tail x)
-    (record-case x
-      [(return v) (Expr v)]
-      [(bind lhs* rhs* body)
-       (or (ormap Expr rhs*) (Tail body))]
-      [(fix lhs* rhs* body) (Tail body)]
-      [(conditional test conseq altern)
-       (or (Expr test) (Tail conseq) (Tail altern))]
-      [(seq e0 e1) (or (Expr e0) (Tail e1))]
-      [(funcall rator arg*) (or (Expr rator) (ormap Expr arg*))] 
-      [(appcall rator arg*) (or (Expr rator) (ormap Expr arg*))]
-      [else (error who "invalid tail expression ~s" (unparse x))]))
-  (define (CaseExpr x)
-    (record-case x 
-      [(clambda-case fml* proper body)
-       (if (Tail body)
-           (make-clambda-case fml* proper (insert-check body))
-           x)]))
-  (define (CodeExpr x)
-    (record-case x
-      [(clambda-code L cases free)
-       (make-clambda-code L (map CaseExpr cases) free)]))
-  (define (CodesExpr x)
-    (record-case x 
-      [(codes list body)
-       (make-codes (map CodeExpr list)
-                   (if (Tail body)
-                       (insert-check body)
-                       body))]))
-  (CodesExpr x))
-
-
-(define (insert-allocation-checks x)
-  (define who 'insert-allocation-checks)
-  (define (check-bytes n var body)
-    (make-seq
-      (make-conditional 
-        (make-primcall '$ap-check-bytes
-          (list (make-constant n) var))
-        (make-forcall "ik_collect" ;(make-primref 'do-overflow) 
-                      (list 
-                        (make-primcall '$fx+ 
-                          (list (make-constant (fx+ n 4096)) var))))
-        (make-primcall 'void '()))
-      body))
-  (define (check-words n var body)
-    (make-seq
-      (make-conditional 
-        (make-primcall '$ap-check-words
-          (list (make-constant n) var))
-        (make-forcall "ik_collect" ; (make-primref 'do-overflow-words)
-                      (list
-                        (make-primcall '$fx+ 
-                          (list (make-constant (fx+ n 4096)) var))))
-        (make-primcall 'void '()))
-      body))
-  (define (check-const n body)
-    (make-seq
-      (make-conditional 
-        (make-primcall '$ap-check-const
-          (list (make-constant n)))
-        (make-forcall "ik_collect" ;(make-primref 'do-overflow) 
-                      (list (make-constant (fx+ n 4096))))
-        (make-primcall 'void '()))
-      body))
-  (define (closure-size x)
-    (record-case x 
-      [(closure code free*)
-       (align (fx+ disp-closure-data (fx* (length free*) wordsize)))]
-      [else (error 'closure-size "~s is not a closure" x)]))
-  (define (sum ac ls)
-    (cond
-      [(null? ls) ac]
-      [else (sum (fx+ ac (car ls)) (cdr ls))]))
-  (define (Expr x)
-    (record-case x
-      [(constant) x]
-      [(var) x]
-      [(primref) x]
-      [(closure) 
-       (check-const (closure-size x) x)]
-      [(fix lhs* rhs* body)
-       (if (null? lhs*)
-           (Expr body)
-           (check-const (sum 0 (map closure-size rhs*))
-             (make-fix lhs* rhs* 
-               (Expr body))))]
-      [(bind lhs* rhs* body)
-       (make-bind lhs* (map Expr rhs*) (Expr body))]
-      [(conditional test conseq altern)
-       (make-conditional (Expr test) (Expr conseq) (Expr altern))]
-      [(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
-      [(primcall op arg*)
-       (let ([x (make-primcall op (map Expr arg*))])
-         (case op
-           [(cons) (check-const pair-size x)]
-           [($make-symbol) (check-const symbol-size x)]
-           [($make-tcbucket) (check-const tcbucket-size x)]
-           [($frame->continuation $code->closure) 
-            (check-const (fx+ disp-closure-data (fx* (length arg*) wordsize)) x)]
-           [($make-string) 
-            (record-case (car arg*)
-              [(constant i)
-               (check-const (fx+ i (fx+ disp-string-data 1)) x)]
-              [else
-               (check-bytes (fxadd1 disp-string-data) (car arg*) x)])]
-           [($string)
-            (check-const (fx+ (length arg*) (fx+ disp-string-data 1)) x)]
-           [($make-port/input $make-port/output $make-port/both)
-            (check-const port-size x)]
-           [($make-vector) 
-            (record-case (car arg*)
-              [(constant i)
-               (check-const (fx+ (fx* i wordsize) disp-vector-data) x)]
-              [else
-               (check-words (fxadd1 disp-vector-data) (car arg*) x)])]
-           [($make-record) 
-            (record-case (cadr arg*)
-              [(constant i)
-               (check-const (fx+ (fx* i wordsize) disp-record-data) x)]
-              [else
-               (check-words (fxadd1 disp-record-data) (cadr arg*) x)])]
-           [(list*)
-            (check-const (fx* (fxsub1 (length arg*)) pair-size) x)]
-           [(list)
-            (check-const (fx* (length arg*) pair-size) x)]
-           [(vector $record)
-            (check-const (fx+ (fx* (length arg*) wordsize) disp-vector-data) x)]
-           [else x]))]
-      [(forcall op arg*)
-       (make-forcall op (map Expr arg*))]
-      [(funcall rator rand*)
-       (make-funcall (Expr rator) (map Expr rand*))]
-      [(appcall op arg*)
-       (make-appcall (Expr op) (map Expr arg*))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (define (Tail x)
-    (record-case x
-      [(return v) (make-return (Expr v))]
-      [(bind lhs* rhs* body)
-       (make-bind lhs* (map Expr rhs*) (Tail body))]
-      [(fix lhs* rhs* body)
-       (if (null? lhs*)
-           (Tail body)
-           (check-const (sum 0 (map closure-size rhs*))
-             (make-fix lhs* rhs* 
-               (Tail body))))]
-      [(conditional test conseq altern)
-       (make-conditional (Expr test) (Tail conseq) (Tail altern))]
-      [(seq e0 e1) (make-seq (Expr e0) (Tail e1))]
-      [(funcall rator rand*)
-       (make-funcall (Expr rator) (map Expr rand*))]
-      [(appcall op arg*)
-       (make-appcall (Expr op) (map Expr arg*))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (define (CaseExpr x)
-    (record-case x 
-      [(clambda-case fml* proper body)
-       (make-clambda-case fml* proper (Tail body))]))
-  (define (CodeExpr x)
-    (record-case x
-      [(clambda-code L cases free)
-       (make-clambda-code L (map CaseExpr cases) free)]))
-  (define (CodesExpr x)
-    (record-case x 
-      [(codes list body)
-       (make-codes (map CodeExpr list) (Tail body))]))
-  (CodesExpr x))
-
-
-              
-(define (remove-local-variables x)
-  (define who 'remove-local-variables)
-  (define (simple* x* r)
-    (map (lambda (x) 
-           (cond
-             [(assq x r) => cdr]
-             [else
-               (when (var? x) (error who "unbound var ~s" x))
-               x]))
-          x*))
-  (define (env->mask r sz)
-    (let ([s (make-vector (fxsra (fx+ sz 7) 3) 0)])
-      (for-each 
-        (lambda (idx) 
-           (let ([q (fxsra idx 3)]
-                 [r (fxlogand idx 7)])
-             (vector-set! s q 
-               (fxlogor (vector-ref s q) (fxsll 1 r)))))
-        r)
-      s))
-  (define (check? x)
-    (cond
-      [(primref? x) #f]  ;;;; PRIMREF CHECK
-      [else         #t]))
-  (define (do-new-frame op rand* si r call-convention rp-convention orig-live)
-    (make-new-frame (fxadd1 si) (fx+ (length rand*) 2)
-      (let f ([r* rand*] [nsi (fx+ si 2)] [live orig-live])
-        (cond
-          [(null? r*) 
-           (make-seq
-             (make-seq 
-               (make-save-cp (make-frame-var si))
-               (case call-convention
-                 [(normal apply)
-                  (make-eval-cp (check? op) (Expr op nsi r (cons si live)))]
-                 [(foreign)
-                  (make-eval-cp #f (make-foreign-label op))]
-                 [else (error who "invalid convention ~s" call-convention)]))
-             (make-call-cp call-convention 
-                rp-convention
-                (fxadd1 si)    ; frame size
-                (length rand*) ; argc
-                (env->mask (cons si orig-live) ; cp and everything before it
-                           (fxadd1 si))))] ; mask-size ~~ frame size
-          [else
-           (make-seq 
-             (make-assign (make-frame-var nsi)
-               (Expr (car r*) nsi r live))
-             (f (cdr r*) (fxadd1 nsi) (cons nsi live)))]))))
-  (define (nop) (make-primcall 'void '()))
-  (define (do-bind lhs* rhs* body si r live k)
-    (let f ([lhs* lhs*] [rhs* rhs*] [si si] [nr r] [live live])
-      (cond
-        [(null? lhs*) (k body si nr live)]
-        [else
-         (let ([v (make-frame-var si)])
-           (make-seq
-             (make-assign v (Expr (car rhs*) si r live))
-             (f (cdr lhs*) (cdr rhs*) (fxadd1 si)
-                (cons (cons (car lhs*) v) nr)
-                (cons si live))))])))
-  (define (do-closure r)
-    (lambda (x)
-      (record-case x
-        [(closure code free*)
-         (make-closure code (simple* free* r))])))
-  (define (do-fix lhs* rhs* body si r live k)
-    (let f ([l* lhs*] [nlhs* '()] [si si] [r r] [live live])
-      (cond
-        [(null? l*) 
-         (make-fix (reverse nlhs*) 
-                   (map (do-closure r) rhs*)
-                   (k body si r live))]
-        [else
-         (let ([v (make-frame-var si)])
-           (f (cdr l*) (cons v nlhs*) (fxadd1 si) 
-              (cons (cons (car l*) v) r)
-              (cons si live)))])))
-  (define (do-tail-frame-old op rand* si r call-conv live)
-    (define (const? x)
-      (record-case x
-        [(constant) #t]
-        [(primref)  #t]
-        [else       #f]))
-    (define (evalrand* rand* i si r live)
-      (cond
-        [(null? rand*) 
-         (make-eval-cp (check? op) (Expr op si r live))]
-        [(const? (car rand*))
-         (evalrand* (cdr rand*) (fxadd1 i) (fxadd1 si) r live)]
-        [else
-         (let ([v (make-frame-var si)]
-               [rhs (Expr (car rand*) si r live)])
-           (cond
-             [(and (frame-var? rhs)
-                   (fx= (frame-var-idx rhs) i))
-              (evalrand* (cdr rand*) (fx+ i 1) (fx+ si 1) r (cons si live))]
-             [else
-              (make-seq
-                (make-assign v rhs)
-                (evalrand* (cdr rand*) (fx+ 1 i) (fx+ 1 si) r
-                           (cons si live)))]))]))
-    (define (moverand* rand* i si ac)
-      (cond
-        [(null? rand*) ac]
-        [(const? (car rand*))
-         (make-seq
-           (make-assign (make-frame-var i) (car rand*))
-           (moverand* (cdr rand*) (fxadd1 i) (fxadd1 si) ac))]
-        [else
-         (make-seq
-           (make-assign (make-frame-var i) (make-frame-var si))
-           (moverand* (cdr rand*) (fxadd1 i) (fxadd1 si) ac))]))
-    (make-seq
-      (evalrand* rand* 1 si r live)
-      (moverand* rand* 1 si
-        (make-tailcall-cp call-conv (length rand*))))) 
-  (define (do-tail-frame op rand* si r call-conv live)
-    (define (const? x)
-      (record-case x
-        [(constant) #t]
-        [(primref)  #t]
-        [else       #f]))
-    (define (evalrand* rand* i si r live ac)
-      (cond
-        [(null? rand*) 
-         (make-seq
-           (make-eval-cp (check? op) (Expr op si r live))
-           ac)]
-        [(const? (car rand*))
-         (evalrand* (cdr rand*) (fxadd1 i) (fxadd1 si) r live
-           (make-seq ac
-             (make-assign (make-frame-var i) (car rand*))))]
-        [else
-         (let ([vsi (make-frame-var si)]
-               [rhs (Expr (car rand*) si r live)])
-           (cond
-             [(and (frame-var? rhs)
-                   (fx= (frame-var-idx rhs) i))
-              (evalrand* (cdr rand*) (fx+ i 1) (fx+ si 1) r (cons si live) ac)]
-             [(fx= i si)
-              (make-seq 
-                (make-assign vsi rhs)
-                (evalrand* (cdr rand*) (fx+ i 1) (fx+ si 1) r
-                           (cons si live) ac))]
-             [else
-              (make-seq
-                (make-assign vsi rhs)
-                (evalrand* (cdr rand*) (fxadd1 i) (fxadd1 si) r (cons si live)
-                  (make-seq ac
-                    (make-assign (make-frame-var i) vsi))))]))]))
-    (make-seq
-      (evalrand* rand* 1 si r live (make-primcall 'void '()))
-      (make-tailcall-cp call-conv (length rand*))))
-  (define (Tail x si r live)
-    (record-case x
-      [(return v) (make-return (Expr v si r live))]
-      [(bind lhs* rhs* body)
-       (do-bind lhs* rhs* body si r live Tail)]
-      [(fix lhs* rhs* body)
-       (do-fix lhs* rhs* body si r live Tail)]
-      [(conditional test conseq altern)
-       (make-conditional 
-         (Expr test si r live)
-         (Tail conseq si r live) 
-         (Tail altern si r live))]
-      [(seq e0 e1) (make-seq (Effect e0 si r live) (Tail e1 si r live))]
-      [(primcall op arg*)
-       (make-return 
-         (make-primcall op 
-           (map (lambda (x) (Expr x si r live)) arg*)))]
-                                  
-      [(funcall op rand*)
-       (do-tail-frame op rand* si r 'normal live)]
-      [(appcall op rand*)
-       (do-tail-frame op rand* si r 'apply live)]
-;;;      [(funcall op rand*)
-;;;       (do-new-frame op rand* si r 'normal 'tail live)]
-;;;      [(appcall op rand*)
-;;;       (do-new-frame op rand* si r 'apply 'tail live)]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (define (Effect x si r live)
-    (record-case x
-      [(constant) (nop)]
-      [(var) (nop)] 
-      [(primref) (nop)]
-      [(closure code free*) (nop)]
-      [(bind lhs* rhs* body)
-       (do-bind lhs* rhs* body si r live Effect)]
-      [(fix lhs* rhs* body)
-       (do-fix lhs* rhs* body si r live Effect)]
-      [(conditional test conseq altern)
-       (make-conditional 
-         (Expr test si r live)
-         (Effect conseq si r live) 
-         (Effect altern si r live))]
-      [(seq e0 e1) (make-seq (Effect e0 si r live) (Effect e1 si r live))]
-      [(primcall op arg*)
-       (make-primcall op 
-         (map (lambda (x) (Expr x si r live)) arg*))]
-      [(forcall op rand*)
-       (do-new-frame op rand* si r 'foreign 'effect live)]
-      [(funcall op rand*)
-       (do-new-frame op rand* si r 'normal 'effect live)]
-      [(appcall op rand*)
-       (do-new-frame op rand* si r 'apply 'effect live)]
-      [else (error who "invalid effect expression ~s" (unparse x))]))
-  (define (Expr x si r live)
-    (record-case x
-      [(constant) x]
-      [(var) 
-       (cond
-         [(assq x r) => cdr]
-         [else (error who "unbound var ~s" x)])]
-      [(primref) x]
-      [(closure code free*) 
-       (make-closure code (simple* free* r))]
-      [(bind lhs* rhs* body)
-       (do-bind lhs* rhs* body si r live Expr)]
-      [(fix lhs* rhs* body)
-       (do-fix lhs* rhs* body si r live Expr)]
-      [(conditional test conseq altern)
-       (make-conditional 
-         (Expr test si r live)
-         (Expr conseq si r live) 
-         (Expr altern si r live))]
-      [(seq e0 e1) (make-seq (Effect e0 si r live) (Expr e1 si r live))]
-      [(primcall op arg*)
-       (make-primcall op 
-         (map (lambda (x) (Expr x si r live)) arg*))]
-      [(forcall op rand*)
-       (do-new-frame op rand* si r 'foreign 'value live)]
-      [(funcall op rand*)
-       (do-new-frame op rand* si r 'normal 'value live)]
-      [(appcall op rand*)
-       (do-new-frame op rand* si r 'apply 'value live)]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (define (bind-fml* fml* r)
-    (let f ([si 1] [fml* fml*])
-      (cond
-        [(null? fml*) (values '() si r '())]
-        [else
-          (let-values ([(nfml* nsi r live) (f (fxadd1 si) (cdr fml*))])
-            (let ([v (make-frame-var si)])
-              (values (cons v nfml*)
-                      nsi
-                      (cons (cons (car fml*) v) r)
-                      (cons si live))))])))
-  (define (bind-free* free*)
-    (let f ([free* free*] [idx 0] [r '()])
-      (cond
-        [(null? free*) r]
-        [else
-          (f (cdr free*) (fxadd1 idx)
-             (cons (cons (car free*) (make-cp-var idx)) r))])))
-  (define CaseExpr 
-    (lambda (r)
-      (lambda (x)
-        (record-case x 
-          [(clambda-case fml* proper body)
-           (let-values ([(fml* si r live) (bind-fml* fml* r)])
-             (make-clambda-case fml* proper (Tail body si r live)))]))))
-  (define (CodeExpr x)
-    (record-case x
-      [(clambda-code L cases free)
-       (let ([r (bind-free* free)])
-         (make-clambda-code L (map (CaseExpr r) cases) free))]))
-  (define (CodesExpr x)
-    (record-case x 
-      [(codes list body)
-       (make-codes (map CodeExpr list) 
-                   (Tail body 1 '() '()))]))
-  (CodesExpr x))
-
-
-
-(define checks-elim-count 0)
-(define (optimize-ap-check x)
-  (define who 'optimize-ap-check)
-  (define (min x y)
-    (if (fx< x y) x y))
-  (define (Tail x f)
-    (record-case x
-      [(return v)
-       (let-values ([(v f) (NonTail v f)])
-         (make-return v))]
-      [(fix lhs* rhs* body)
-       (make-fix lhs* rhs* (Tail body f))]
-      [(conditional test conseq altern)
-       (let-values ([(test f) (NonTail test f)])
-         (make-conditional 
-           test
-           (Tail conseq f)
-           (Tail altern f)))]
-      [(seq e0 e1) 
-       (let-values ([(e0 f) (NonTail e0 f)])
-         (make-seq e0 (Tail e1 f)))]
-      [(tailcall-cp) x]
-      [else (error who "invalid tail expression ~s" (unparse x))]))
-  (define (do-primcall op arg* f)
-    (case op
-      [($ap-check-const)
-       (let ([n (constant-value (car arg*))])
-         (cond
-           [(fx< n f) 
-            ;(set! checks-elim-count (fxadd1 checks-elim-count))
-            ;(printf "~s checks eliminated\n" checks-elim-count)
-            (values (make-constant #f) (fx- f n))]
-           [(fx<= n 4096)
-            (values (make-primcall '$ap-check-const 
-                                   (list (make-constant 4096)))
-                    (fx- 4096 n))]
-           [else
-            (values (make-primcall '$ap-check-const 
-                                   (list (make-constant (fx+ n 4096))))
-                    4096)]))]
-      [($ap-check-bytes $ap-check-words)
-       (values (make-primcall op 
-                 (list (make-constant (fx+ (constant-value (car arg*)) 
-                                           4096))
-                       (cadr arg*)))
-               4096)]
-      [else (values (make-primcall op arg*) f)]))
-  (define (NonTail x f)
-    (record-case x
-      [(constant)         (values x f)]
-      [(frame-var)        (values x f)]
-      [(cp-var)           (values x f)]
-      [(save-cp)          (values x f)]
-      [(foreign-label)    (values x f)]
-      [(primref)          (values x f)]
-      [(closure)          (values x f)]
-      [(call-cp call-conv) 
-       (if (eq? call-conv 'foreign)
-           (values x f)
-           (values x 0))]
-      [(primcall op arg*) (do-primcall op arg* f)]
-      [(fix lhs* rhs* body)
-       (let-values ([(body f) (NonTail body f)])
-         (values (make-fix lhs* rhs* body) f))]
-      [(conditional test conseq altern)
-       (let-values ([(test f) (NonTail test f)])
-         (if (constant? test)
-             (if (constant-value test)
-                 (NonTail conseq f)
-                 (NonTail altern f))
-             (let-values ([(conseq f0) (NonTail conseq f)]
-                          [(altern f1) (NonTail altern f)])
-               (values (make-conditional test conseq altern)
-                       (min f0 f1)))))]
-      [(seq e0 e1) 
-       (let-values ([(e0 f) (NonTail e0 f)])
-         (let-values ([(e1 f) (NonTail e1 f)])
-           (values (make-seq e0 e1) f)))]
-      [(assign lhs rhs)
-       (let-values ([(rhs f) (NonTail rhs f)])
-         (values (make-assign lhs rhs) f))]
-      [(eval-cp check body)
-       (let-values ([(body f) (NonTail body f)])
-         (values (make-eval-cp check body) f))]
-      [(new-frame base-idx size body)
-       (let-values ([(body f) (NonTail body f)])
-         (values (make-new-frame base-idx size body) f))]
-      [else (error who "invalid nontail expression ~s" (unparse x))]))
-  (define CaseExpr 
-    (lambda (x)
-      (record-case x 
-        [(clambda-case fml* proper body)
-         (make-clambda-case fml* proper (Tail body 0))])))
-  (define (CodeExpr x)
-    (record-case x
-      [(clambda-code L cases free)
-       (make-clambda-code L (map CaseExpr cases) free)]))
-  (define (CodesExpr x)
-    (record-case x 
-      [(codes list body)
-       (make-codes (map CodeExpr list) 
-                   (Tail body 0))]))
-  (CodesExpr x))
-
-(begin
-  (define fx-shift 2)
-  (define fx-mask #x03)
-  (define fx-tag 0)
-  (define bool-f #x2F)
-  (define bool-t #x3F)
-  (define bool-mask #xEF)
-  (define bool-tag #x2F)
-  (define bool-shift 4)
-  (define nil     #x4F)
-  (define eof     #x5F) ; double check
-  (define unbound #x6F) ; double check
-  (define void-object #x7F) ; double check
-  (define bwp-object  #x8F) ; double check
-  (define char-shift 8)
-  (define char-tag #x0F)
-  (define char-mask #xFF)
-  (define pair-mask 7)
-  (define pair-tag  1)
-  (define disp-car  0)
-  (define disp-cdr  4)
-  (define pair-size 8)
-  (define pagesize 4096)
-  (define pageshift 12)
-  (define wordsize  4)
-  (define wordshift 2)
-  
-  (define symbol-mask 7)
-  (define symbol-tag 2)
-  (define disp-symbol-string         0)
-  (define disp-symbol-unique-string  4)
-  (define disp-symbol-value          8)
-  (define disp-symbol-plist         12)
-  (define disp-symbol-system-value  16)
-  (define disp-symbol-system-plist  20)
-  (define symbol-size 24)
-  (define vector-tag 5)
-  (define vector-mask 7)
-  (define disp-vector-length 0)
-  (define disp-vector-data 4)
-  (define string-mask 7)
-  (define string-tag 6)
-  (define disp-string-length 0)
-  (define disp-string-data 4)
-  (define closure-mask 7)
-  (define closure-tag 3)
-  (define disp-closure-data 4)
-  (define disp-closure-code 0)
-  (define continuation-size       16)
-  (define continuation-tag      #x1F)
-  (define disp-continuation-top    4)
-  (define disp-continuation-size   8)
-  (define disp-continuation-next  12)
-  (define code-tag              #x2F)
-  (define disp-code-instrsize      4)
-  (define disp-code-relocsize      8)
-  (define disp-code-freevars      12)
-  (define disp-code-data          16)
-  (define port-tag              #x3F)
-  (define input-port-tag        #x7F)
-  (define output-port-tag       #xBF)
-  (define input/output-port-tag #xFF)
-  (define port-mask             #x3F)
-  (define disp-port-handler        4)
-  (define disp-port-input-buffer   8)
-  (define disp-port-input-index   12)
-  (define disp-port-input-size    16)
-  (define disp-port-output-buffer 20)
-  (define disp-port-output-index  24)
-  (define disp-port-output-size   28)
-  (define port-size               32)
-  (define disp-tcbucket-tconc 0)
-  (define disp-tcbucket-key   4)
-  (define disp-tcbucket-val   8)
-  (define disp-tcbucket-next 12)
-  (define tcbucket-size      16)
-  (define record-ptag  5)
-  (define record-pmask 7)
-  (define disp-record-rtd     0)
-  (define disp-record-data    4)
-  (define disp-frame-size -17)
-  (define disp-frame-offset -13)
-  (define disp-multivalue-rp -9)
-  (define object-alignment 8)
-  (define align-shift 3)
-  (define dirty-word -1))
-
-(define (align n)
-  (fxsll (fxsra (fx+ n (fxsub1 object-alignment)) align-shift) align-shift))
-
-(begin
-  (define (mem off val)
-    (cond
-      [(fixnum? off) (list 'disp (int off) val)]
-      [(register? off) (list 'disp off val)]
-      [else (error 'mem "invalid disp ~s" off)]))
-  (define (int x) (list 'int x))
-  (define (obj x) (list 'obj x))
-  (define (byte x) (list 'byte x))
-  (define (byte-vector x) (list 'byte-vector x))
-  (define (movzbl src targ) (list 'movzbl src targ))
-  (define (sall src targ) (list 'sall src targ))
-  (define (sarl src targ) (list 'sarl src targ))
-  (define (shrl src targ) (list 'shrl src targ))
-  (define (notl src) (list 'notl src))
-  (define (pushl src) (list 'pushl src))
-  (define (popl src) (list 'popl src))
-  (define (orl src targ) (list 'orl src targ))
-  (define (xorl src targ) (list 'xorl src targ))
-  (define (andl src targ) (list 'andl src targ))
-  (define (movl src targ) (list 'movl src targ))
-  (define (movb src targ) (list 'movb src targ))
-  (define (addl src targ) (list 'addl src targ))
-  (define (imull src targ) (list 'imull src targ))
-  (define (idivl src) (list 'idivl src))
-  (define (subl src targ) (list 'subl src targ))
-  (define (push src) (list 'push src))
-  (define (pop targ) (list 'pop targ))
-  (define (sete targ) (list 'sete targ))
-  (define (call targ) (list 'call targ))
-  (define (tail-indirect-cpr-call)
-    (jmp (mem (fx- disp-closure-code closure-tag) cpr)))
-  (define (indirect-cpr-call)
-    (call (mem (fx- disp-closure-code closure-tag) cpr)))
-  (define (negl targ) (list 'negl targ))
-  (define (label x) (list 'label x))
-  (define (label-address x) (list 'label-address x))
-  (define (ret) '(ret))
-  (define (cltd) '(cltd))
-  (define (cmpl arg1 arg2) (list 'cmpl arg1 arg2))
-  (define (je label) (list 'je label))
-  (define (jne label) (list 'jne label))
-  (define (jle label) (list 'jle label))
-  (define (jge label) (list 'jge label))
-  (define (jg label) (list 'jg label))
-  (define (jl label) (list 'jl label))
-  (define (jb label) (list 'jb label))
-  (define (ja label) (list 'ja label))
-  (define (jmp label) (list 'jmp label))
-  (define edi '%edx) ; closure pointer
-  (define esi '%esi) ; pcb
-  (define ebp '%ebp) ; allocation pointer
-  (define esp '%esp) ; stack base pointer 
-  (define al '%al)
-  (define ah '%ah)
-  (define bh '%bh)
-  (define cl '%cl)
-  (define eax '%eax)
-  (define ebx '%ebx)
-  (define ecx '%ecx)
-  (define edx '%edx)
-  (define apr '%ebp)
-  (define fpr '%esp)
-  (define cpr '%edi)
-  (define pcr '%esi)
-  (define register? symbol?)
-  (define (argc-convention n)
-    (fx- 0 (fxsll n fx-shift))))
-
-
-(define pcb-ref
-  (lambda (x)
-    (case x
-      [(allocation-pointer) (mem  0 pcr)]
-      [(allocation-redline) (mem  4 pcr)]
-      [(frame-pointer)      (mem  8 pcr)]
-      [(frame-base)         (mem 12 pcr)]
-      [(frame-redline)      (mem 16 pcr)]
-      [(next-continuation)  (mem 20 pcr)]
-      [(system-stack)       (mem 24 pcr)]
-      [(dirty-vector)       (mem 28 pcr)]
-      [else (error 'pcb-ref "invalid arg ~s" x)])))
-
-(define (primref-loc op)
-  (unless (symbol? op) (error 'primref-loc "not a symbol ~s" op))
-  (mem (fx- disp-symbol-system-value symbol-tag)
-        (obj op)))
-
-
-(define (generate-code x)
-  (define who 'generate-code)
-  (define (rp-label x)
-    (case x
-      [(value) (label-address SL_multiple_values_error_rp)]
-      [(effect) (label-address SL_multiple_values_ignore_rp)]
-      [else (error who "invalid rp-convention ~s" x)]))
-  (define unique-label
-    (lambda ()
-      (label (gensym))))
-  (define (constant-val x)
-    (cond
-      [(fixnum? x) (obj x)]
-      [(boolean? x) (int (if x bool-t bool-f))]
-      [(null? x) (int nil)]
-      [(char? x) (int (fx+ (fxsll (char->integer x) char-shift) char-tag))]
-      [(eq? x (void)) (int void-object)]
-      [else (obj x)]))
-  (define (cond-branch op Lt Lf ac)
-    (define (opposite x)
-      (cadr (assq x '([je jne] [jl jge] [jle jg] [jg jle] [jge jl]))))
-    (unless (or Lt Lf)
-      (error 'cond-branch "no labels"))
-    (cond
-      [(not Lf) (cons (list op Lt) ac)]
-      [(not Lt) (cons (list (opposite op) Lf) ac)] 
-      [else (list* (list op Lt) (jmp Lf) ac)]))
-  (define (indirect-type-pred pri-mask pri-tag sec-mask sec-tag rand* Lt Lf ac)
-    (cond
-      [(and Lt Lf)
-       (list* (movl (Simple (car rand*)) eax)
-              (movl eax ebx)
-              (andl (int pri-mask) ebx)
-              (cmpl (int pri-tag) ebx)
-              (jne Lf)
-              (movl (mem (fx- 0 pri-tag) eax) ebx)
-              (if sec-mask
-                  (andl (int sec-mask) ebx)
-                  '(nop))
-              (cmpl (int sec-tag) ebx)
-              (jne Lf)
-              (jmp Lt)
-              ac)]
-      [Lf
-       (list* (movl (Simple (car rand*)) eax)
-              (movl eax ebx)
-              (andl (int pri-mask) ebx)
-              (cmpl (int pri-tag) ebx)
-              (jne Lf)
-              (movl (mem (fx- 0 pri-tag) eax) ebx)
-              (if sec-mask
-                  (andl (int sec-mask) ebx)
-                  '(nop))
-              (cmpl (int sec-tag) ebx)
-              (jne Lf)
-              ac)]
-      [Lt
-       (let ([L_END (unique-label)])
-         (list* (movl (Simple (car rand*)) eax)
-                (movl eax ebx)
-                (andl (int pri-mask) ebx)
-                (cmpl (int pri-tag) ebx)
-                (jne L_END)
-                (movl (mem (fx- 0 pri-tag) eax) ebx)
-                (if sec-mask
-                    (andl (int sec-mask) ebx)
-                    '(nop))
-                (cmpl (int sec-tag) ebx)
-                (je Lt)
-                L_END
-                ac))]
-      [else ac]))
-  (define (type-pred mask tag rand* Lt Lf ac)
-    (cond
-      [mask
-       (list* 
-         (movl (Simple (car rand*)) eax)
-         (andl (int mask) eax)
-         (cmpl (int tag) eax)
-         (cond-branch 'je Lt Lf ac))]
-      [else 
-       (let ([v (Simple (car rand*))])
-         (cond
-           [(memq (car v) '(mem register)) 
-            (list*
-              (cmpl (int tag) (Simple (car rand*)))
-              (cond-branch 'je Lt Lf ac))]
-           [else
-            (list*
-              (movl (Simple (car rand*)) eax)
-              (cmpl (int tag) eax)
-              (cond-branch 'je Lt Lf ac))]))])) 
-  (define (compare-and-branch op rand* Lt Lf ac)
-    (define (opposite x)
-      (cadr (assq x '([je je] [jl jg] [jle jge] [jg jl] [jge jle]))))
-    (cond
-      [(and (constant? (car rand*)) (constant? (cadr rand*)))
-       (list* 
-         (movl (Simple (car rand*)) eax)
-         (cmpl (Simple (cadr rand*)) eax)
-         (cond-branch op Lt Lf ac))]
-      [(constant? (cadr rand*))
-       (list* 
-         (cmpl (Simple (cadr rand*)) (Simple (car rand*)))
-         (cond-branch op Lt Lf ac))]
-      [(constant? (car rand*))
-       (list*
-         (cmpl (Simple (car rand*)) (Simple (cadr rand*)))
-         (cond-branch (opposite op) Lt Lf ac))]
-      [else
-       (list* 
-         (movl (Simple (car rand*)) eax)
-         (cmpl (Simple (cadr rand*)) eax)
-         (cond-branch op Lt Lf ac))]))
-  (define (do-pred-prim op rand* Lt Lf ac)
-    (case op
-     [(fixnum?)    (type-pred fx-mask fx-tag rand* Lt Lf ac)]
-     [(pair?)      (type-pred pair-mask pair-tag rand* Lt Lf ac)]
-     [(char?)      (type-pred char-mask char-tag rand* Lt Lf ac)]
-     [(string?)    (type-pred string-mask string-tag rand* Lt Lf ac)]
-     [(symbol?)    (type-pred symbol-mask symbol-tag rand* Lt Lf ac)]
-     [(procedure?) (type-pred closure-mask closure-tag rand* Lt Lf ac)]
-     [(boolean?)   (type-pred bool-mask bool-tag rand* Lt Lf ac)]
-     [(null?)      (type-pred #f nil rand* Lt Lf ac)]
-     [($unbound-object?) (type-pred #f unbound rand* Lt Lf ac)]
-     [($forward-ptr?) (type-pred #f -1 rand* Lt Lf ac)]
-     [(not)        (Pred (car rand*) Lf Lt ac)]
-     ;[(not)        (type-pred #f bool-f rand* Lt Lf ac)]
-     [(eof-object?) (type-pred #f eof rand* Lt Lf ac)]
-     [(bwp-object?) (type-pred #f bwp-object rand* Lt Lf ac)]
-     [($code?) 
-      (indirect-type-pred vector-mask vector-tag #f code-tag 
-         rand* Lt Lf ac)]
-     [($fxzero?)   (type-pred #f 0 rand* Lt Lf ac)]
-     [($fx= $char= eq?) (compare-and-branch 'je rand* Lt Lf ac)]
-     [($fx< $char<)     (compare-and-branch 'jl rand* Lt Lf ac)]
-     [($fx<= $char<=)   (compare-and-branch 'jle rand* Lt Lf ac)]
-     [($fx> $char>)     (compare-and-branch 'jg rand* Lt Lf ac)]
-     [($fx>= $char>=)   (compare-and-branch 'jge rand* Lt Lf ac)]
-     [(vector?) 
-      (indirect-type-pred vector-mask vector-tag fx-mask fx-tag 
-         rand* Lt Lf ac)]
-     [($record?) 
-      (indirect-type-pred record-pmask record-ptag record-pmask record-ptag
-         rand* Lt Lf ac)]
-     [(output-port?)
-      (indirect-type-pred 
-        vector-mask vector-tag #f output-port-tag rand* Lt Lf ac)] 
-     [(input-port?)
-      (indirect-type-pred 
-        vector-mask vector-tag #f input-port-tag rand* Lt Lf ac)] 
-     [(port?)
-      (indirect-type-pred 
-        vector-mask vector-tag port-mask port-tag rand* Lt Lf ac)] 
-     [($record/rtd?)
-      (cond
-        [Lf
-         (list* (movl (Simple (car rand*)) eax)
-                (movl eax ebx)
-                (andl (int vector-mask) eax)
-                (cmpl (int vector-tag) eax)
-                (jne Lf)
-                (movl (Simple (cadr rand*)) eax)
-                (cmpl (mem (fx- disp-record-rtd vector-tag) ebx) eax)
-                (jne Lf)
-                (if Lt
-                    (cons (jmp Lt) ac)
-                    ac))]
-        [Lt
-         (let ([Ljoin (unique-label)])
-           (list* (movl (Simple (car rand*)) eax)
-                  (movl eax ebx)
-                  (andl (int vector-mask) eax)
-                  (cmpl (int vector-tag) eax)
-                  (jne Ljoin)
-                  (movl (Simple (cadr rand*)) eax)
-                  (cmpl (mem (fx- disp-record-rtd vector-tag) ebx) eax)
-                  (je Lt)
-                  Ljoin
-                  ac))]
-        [else ac])]
-     [(immediate?)
-      (cond
-        [(and Lt Lf)
-         (list* (movl (Simple (car rand*)) eax)
-             (movl eax ebx)
-             (andl (int fx-mask) ebx)
-             (cmpl (int 0) ebx)
-             (je Lt)
-             (andl (int 7) eax)
-             (cmpl (int 7) eax)
-             (je Lt)
-             (jmp Lf)
-             ac)]
-        [Lt
-         (list* (movl (Simple (car rand*)) eax)
-             (movl eax ebx)
-             (andl (int fx-mask) ebx)
-             (cmpl (int 0) ebx)
-             (je Lt)
-             (andl (int 7) eax)
-             (cmpl (int 7) eax)
-             (je Lt)
-             ac)]
-        [Lf
-         (let ([Ljoin (unique-label)])
-           (list* 
-             (movl (Simple (car rand*)) eax)
-             (movl eax ebx)
-             (andl (int fx-mask) ebx)
-             (cmpl (int 0) ebx)
-             (je Ljoin)
-             (andl (int 7) eax)
-             (cmpl (int 7) eax)
-             (jne Lf)
-             Ljoin
-             ac))]
-        [else ac])]
-     [($ap-check-words)
-      (record-case (car rand*)
-        [(constant i)
-         (list* (movl (pcb-ref 'allocation-redline) eax)
-                (subl (Simple (cadr rand*)) eax)
-                (subl (int i) eax)
-                (cmpl eax apr)
-                (cond-branch 'jge Lt Lf ac))]
-        [else (error who "ap-check-words")])]
-     [($ap-check-bytes)
-      (record-case (car rand*)
-        [(constant i)
-         (list* (movl (Simple (cadr rand*)) eax)
-                (negl eax)
-                (addl (pcb-ref 'allocation-redline) eax)
-                (subl (int i) eax)
-                (cmpl eax apr)
-                (cond-branch 'jge Lt Lf ac))]
-        [else (error who "ap-check-bytes")])]
-     [($ap-check-const) 
-      (record-case (car rand*)
-        [(constant i) 
-         (if (fx<= i pagesize)
-             (list* 
-               (cmpl (pcb-ref 'allocation-redline) apr)
-               (cond-branch 'jge Lt Lf ac))
-             (list* 
-               (movl (pcb-ref 'allocation-redline) eax)
-               (subl (int i) eax)
-               (cmpl eax apr)
-               (cond-branch 'jge Lt Lf ac)))]
-        [else (error who "ap-check-const")])]
-     [($fp-at-base) 
-      (list* 
-        (movl (pcb-ref 'frame-base) eax)
-        (subl (int wordsize) eax)
-        (cmpl eax fpr)
-        (cond-branch 'je Lt Lf ac))]
-     [($fp-overflow) 
-      (list* (cmpl (pcb-ref 'frame-redline) fpr)
-             (cond-branch 'jle Lt Lf ac))]
-     [($vector-ref top-level-value car cdr $record-ref) 
-      (do-value-prim op rand*
-        (do-simple-test eax Lt Lf ac))]
-     [(cons void $fxadd1 $fxsub1)
-      ;;; always true
-      (do-effect-prim op rand*
-        (cond
-          [(not Lt) ac]
-          [else (cons (jmp Lt) ac)]))]
-     [else 
-      (error 'pred-prim "HERE unhandled ~s" op)]))
-  (define (do-pred->value-prim op rand* ac)
-    (case op
-      [else
-       (let ([Lf (unique-label)] [Lj (unique-label)])
-         (do-pred-prim op rand* #f Lf
-           (list* (movl (constant-val #t) eax)
-                  (jmp Lj)
-                  Lf
-                  (movl (constant-val #f) eax)
-                  Lj
-                  ac)))]))
-  (define (indirect-ref arg* off ac)
-    (list*
-      (movl (Simple (car arg*)) eax)
-      (movl (mem off eax) eax)
-      ac))
-  (define (do-make-port tag args ac)
-    (let f ([args args] [idx disp-vector-data])
-      (cond
-        [(null? args)
-         (if (fx= idx port-size)
-             (list*
-               (movl (int tag) (mem 0 apr))
-               (movl apr eax)
-               (addl (int port-size) apr)
-               (addl (int vector-tag) eax)
-               ac)
-             (error 'do-make-port "BUG"))]
-         [else
-          (list* 
-            (movl (Simple (car args)) eax)
-            (movl eax (mem idx apr))
-            (f (cdr args) (fx+ idx wordsize)))])))
-  (define (do-value-prim op arg* ac)
-    (case op
-      [(eof-object) (cons (movl (int eof) eax) ac)]
-      [(void)       (cons (movl (int void-object) eax) ac)]
-      [($fxadd1) 
-       (list* (movl (Simple (car arg*)) eax)
-              (addl (constant-val 1) eax)
-              ac)]
-      [($fxsub1) 
-       (list* (movl (Simple (car arg*)) eax)
-              (addl (constant-val -1) eax)
-              ac)]
-      [($fx+) 
-       (list* (movl (Simple (car arg*)) eax)
-              (addl (Simple (cadr arg*)) eax)
-              ac)]
-      [($fx-) 
-       (list* (movl (Simple (car arg*)) eax)
-              (subl (Simple (cadr arg*)) eax)
-              ac)]
-      [($fx*)
-       (cond
-         [(constant? (car arg*))
-          (record-case (car arg*)
-            [(constant c)
-             (unless (fixnum? c)
-               (error who "invalid arg ~s to fx*" c))
-             (list* (movl (Simple (cadr arg*)) eax)
-                    (imull (int c) eax)
-                    ac)])]
-         [(constant? (cadr arg*))
-          (record-case (cadr arg*)
-            [(constant c)
-             (unless (fixnum? c)
-               (error who "invalid arg ~s to fx*" c))
-             (list* (movl (Simple (car arg*)) eax)
-                    (imull (int c) eax)
-                    ac)])]
-         [else
-          (list* (movl (Simple (car arg*)) eax)
-                 (sarl (int fx-shift) eax)
-                 (imull (Simple (cadr arg*)) eax)
-                 ac)])]
-      [($fxquotient)
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ecx)
-              (cltd)
-              (idivl ecx)
-              (sall (int fx-shift) eax)
-              ac)]
-      [($fxmodulo)
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ebx)
-              (movl eax ecx)
-              (xorl ebx ecx)
-              (sarl (int (fxsub1 (fx* wordsize 8))) ecx)
-              (andl ebx ecx)
-              (cltd)
-              (idivl ebx)
-              (movl edx eax)
-              (addl ecx eax)
-              ac)]
-      [($fxlogor) 
-       (list* (movl (Simple (car arg*)) eax)
-              (orl (Simple (cadr arg*)) eax)
-              ac)]
-      [($fxlogand) 
-       (list* (movl (Simple (car arg*)) eax)
-              (andl (Simple (cadr arg*)) eax)
-              ac)]
-      [($fxlogxor) 
-       (list* (movl (Simple (car arg*)) eax)
-              (xorl (Simple (cadr arg*)) eax)
-              ac)]
-      [($fxsra)
-       (record-case (cadr arg*)
-         [(constant i)
-          (unless (fixnum? i) (error who "invalid arg to fxsra"))
-          (list* (movl (Simple (car arg*)) eax)
-                 (sarl (int (fx+ i fx-shift)) eax)
-                 (sall (int fx-shift) eax)
-                 ac)]
-         [else
-          (list* (movl (Simple (car arg*)) eax)
-                 (movl (Simple (cadr arg*)) ecx)
-                 (sarl (int fx-shift) ecx)
-                 (sarl (int fx-shift) eax)
-                 (sarl cl eax)
-                 (sall (int fx-shift) eax)
-                 ac)])]
-      [($fxsll)
-       (record-case (cadr arg*)
-         [(constant i)
-          (unless (fixnum? i) (error who "invalid arg to fxsll"))
-          (list* (movl (Simple (car arg*)) eax)
-                 (sall (int i) eax)
-                 ac)]
-         [else
-          (list* (movl (Simple (car arg*)) eax)
-                 (movl (Simple (cadr arg*)) ecx)
-                 (sarl (int fx-shift) ecx)
-                 (sall cl eax)
-                 ac)])]
-      [($fixnum->char)  
-       (list* (movl (Simple (car arg*)) eax)
-              (sall (int (fx- char-shift fx-shift)) eax)
-              (orl (int char-tag) eax)
-              ac)]
-      [($char->fixnum) 
-       (list* (movl (Simple (car arg*)) eax)
-              (sarl (int (fx- char-shift fx-shift)) eax)
-              ac)]
-      [($fxlognot) 
-       (list* (movl (Simple (car arg*)) eax)
-              (orl (int fx-mask) eax)
-              (notl eax)
-              ac)]
-      [($car) (indirect-ref arg* (fx- disp-car pair-tag) ac)]
-      [($cdr) (indirect-ref arg* (fx- disp-cdr pair-tag) ac)]
-      [($vector-length) 
-       (indirect-ref arg* (fx- disp-vector-length vector-tag) ac)]
-      [($string-length) 
-       (indirect-ref arg* (fx- disp-string-length string-tag) ac)]
-      [($symbol-string) 
-       (indirect-ref arg* (fx- disp-symbol-string symbol-tag) ac)]
-      [($symbol-unique-string) 
-       (indirect-ref arg* (fx- disp-symbol-unique-string symbol-tag) ac)]
-      [($symbol-value) 
-       (indirect-ref arg* (fx- disp-symbol-value symbol-tag) ac)]
-      [(primitive-ref) 
-       (indirect-ref arg* (fx- disp-symbol-system-value symbol-tag) ac)]
-      [($tcbucket-key) 
-       (indirect-ref arg* (fx- disp-tcbucket-key vector-tag) ac)]
-      [($tcbucket-val) 
-       (indirect-ref arg* (fx- disp-tcbucket-val vector-tag) ac)]
-      [($tcbucket-next) 
-       (indirect-ref arg* (fx- disp-tcbucket-next vector-tag) ac)]
-      [($port-handler) 
-       (indirect-ref arg* (fx- disp-port-handler vector-tag) ac)]
-      [($port-input-buffer) 
-       (indirect-ref arg* (fx- disp-port-input-buffer vector-tag) ac)]
-      [($port-input-index) 
-       (indirect-ref arg* (fx- disp-port-input-index vector-tag) ac)]
-      [($port-input-size) 
-       (indirect-ref arg* (fx- disp-port-input-size vector-tag) ac)]
-      [($port-output-buffer) 
-       (indirect-ref arg* (fx- disp-port-output-buffer vector-tag) ac)]
-      [($port-output-index) 
-       (indirect-ref arg* (fx- disp-port-output-index vector-tag) ac)]
-      [($port-output-size) 
-       (indirect-ref arg* (fx- disp-port-output-size vector-tag) ac)]
-      [(pointer-value)
-       (list*
-         (movl (Simple (car arg*)) eax)
-         (sarl (int fx-shift) eax)
-         (sall (int fx-shift) eax)
-         ac)]
-      [($symbol-plist) 
-       (indirect-ref arg* (fx- disp-symbol-plist symbol-tag) ac)]
-      [($record-rtd) 
-       (indirect-ref arg* (fx- disp-record-rtd record-ptag) ac)]
-      [($constant-ref)
-       (list* (movl (Simple (car arg*)) eax) ac)]
-      [(car cdr)
-       (let ([x (car arg*)])
-         (NonTail x
-           (list* 
-             (movl eax ebx)
-             (andl (int pair-mask) eax)
-             (cmpl (int pair-tag) eax)
-             (if (eq? op 'car)
-                 (list* 
-                   (jne (label SL_car_error))
-                   (movl (mem (fx- disp-car pair-tag) ebx) eax)
-                   ac)
-                 (list* 
-                   (jne (label SL_cdr_error))
-                   (movl (mem (fx- disp-cdr pair-tag) ebx) eax)
-                   ac)))))]
-      [(top-level-value)
-       (let ([x (car arg*)])
-         (cond
-           [(constant? x)
-            (let ([v (constant-value x)])
-              (cond
-                [(symbol? v)
-                 (list* 
-                   (movl (mem (fx- disp-symbol-value symbol-tag) (obj v)) eax)
-                   (movl (obj v) ebx)
-                   (cmpl (int unbound) eax)
-                   (je (label SL_top_level_value_error))
-                   ac)]
-                [else
-                 (list* 
-                   (movl (obj v) ebx)
-                   (jmp (label SL_top_level_value_error))
-                   ac)]))]
-           [else
-            (NonTail x
-              (list* 
-                (movl eax ebx)
-                (andl (int symbol-mask) eax)
-                (cmpl (int symbol-tag) eax)
-                (jne (label SL_top_level_value_error))
-                (movl (mem (fx- disp-symbol-value symbol-tag) ebx) eax)
-                (cmpl (int unbound) eax)
-                (je (label SL_top_level_value_error))
-                ac))]))]
-      [($vector-ref) 
-       (list* (movl (Simple (car arg*)) ebx)
-              (addl (Simple (cadr arg*)) ebx)
-              (movl (mem (fx- disp-vector-data vector-tag) ebx) eax)
-              ac)]
-      [($record-ref) 
-       (list* (movl (Simple (car arg*)) ebx)
-              (addl (Simple (cadr arg*)) ebx)
-              (movl (mem (fx- disp-record-data record-ptag) ebx) eax)
-              ac)]
-      [($code-ref) 
-       (list* (movl (Simple (cadr arg*)) ebx)
-              (sarl (int fx-shift) ebx)
-              (addl (Simple (car arg*)) ebx)
-              (movl (int 0) eax)
-              (movb (mem (fx- disp-code-data vector-tag) ebx) ah)
-              (sarl (int (fx- 8 fx-shift)) eax)
-              ac)]
-      [($string-ref) 
-       (list* (movl (Simple (cadr arg*)) ebx)
-              (sarl (int fx-shift) ebx)
-              (addl (Simple (car arg*)) ebx)
-              (movl (int char-tag) eax)
-              (movb (mem (fx- disp-string-data string-tag) ebx) ah)
-              ac)]
-      [($make-string) 
-       (list* (movl (Simple (car arg*)) ebx)
-              (movl ebx (mem disp-string-length apr))
-              (movl apr eax)
-              (addl (int string-tag) eax)
-              (sarl (int fx-shift) ebx)
-              (addl ebx apr)
-              (movb (int 0) (mem disp-string-data apr))
-              (addl (int (fx+ disp-string-data object-alignment)) apr)
-              (sarl (int align-shift) apr)
-              (sall (int align-shift) apr)
-              ac)]
-      [($make-vector) 
-       (list* (movl (Simple (car arg*)) ebx)
-              (movl ebx (mem disp-vector-length apr))
-              (movl apr eax)
-              (addl (int vector-tag) eax)
-              (addl ebx apr)
-              (addl (int (fx+ disp-vector-data (fxsub1 object-alignment))) apr)
-              (sarl (int align-shift) apr)
-              (sall (int align-shift) apr)
-              ac)]
-      [($make-record) 
-       (list* (movl (Simple (car arg*)) eax)
-              (movl eax (mem disp-record-rtd apr))
-              (movl apr eax)
-              (addl (int record-ptag) eax)
-              (addl (Simple (cadr arg*)) apr)
-              (addl (int (fx+ disp-record-data (fxsub1 object-alignment))) apr)
-              (sarl (int align-shift) apr)
-              (sall (int align-shift) apr)
-              ac)]
-      [(cons)
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ebx)
-              (movl eax (mem disp-car apr))
-              (movl apr eax)
-              (movl ebx (mem disp-cdr apr))
-              (addl (int pair-tag) eax)
-              (addl (int (align pair-size)) apr)
-              ac)]
-      [(list)
-       (cond
-         [(null? arg*) (NonTail (make-constant '()) ac)]
-         [else
-          (list*
-            (addl (int pair-tag) apr)
-            (movl apr eax)
-            (let f ([a (car arg*)] [d (cdr arg*)])
-              (list*
-                (movl (Simple a) ebx)
-                (movl ebx (mem (fx- disp-car pair-tag) apr))
-                (if (null? d)
-                    (list*
-                      (movl (int nil) (mem (fx- disp-cdr pair-tag) apr))
-                      (addl (int (fx- pair-size pair-tag)) apr)
-                      ac)
-                    (list*
-                      (addl (int pair-size) apr)
-                      (movl apr 
-                          (mem (fx- disp-cdr (fx+ pair-tag pair-size)) apr))
-                      (f (car d) (cdr d)))))))])]
-      [(list*)
-       (cond
-         [(fx= (length arg*) 1) (NonTail (car arg*) ac)]
-         [(fx= (length arg*) 2) (NonTail (make-primcall 'cons arg*) ac)]
-         [else
-          (list*
-            (addl (int pair-tag) apr)
-            (movl apr eax)
-            (let f ([a (car arg*)] [b (cadr arg*)] [d (cddr arg*)])
-              (list*
-                (movl (Simple a) ebx)
-                (movl ebx (mem (fx- disp-car pair-tag) apr))
-                (if (null? d)
-                    (list*
-                      (movl (Simple b) ebx)
-                      (movl ebx (mem (fx- disp-cdr pair-tag) apr))
-                      (addl (int (fx- pair-size pair-tag)) apr)
-                      ac)
-                    (list*
-                      (addl (int pair-size) apr)
-                      (movl apr 
-                          (mem (fx- disp-cdr (fx+ pair-tag pair-size)) apr))
-                      (f b (car d) (cdr d)))))))])]
-      [($make-symbol)
-       (list* (movl (Simple (car arg*)) eax)
-              (movl eax (mem disp-symbol-string apr))
-              (movl (int 0) (mem disp-symbol-unique-string apr))
-              (movl (int unbound) (mem disp-symbol-value apr))
-              (movl (int nil) (mem disp-symbol-plist apr))
-              (movl (int unbound) (mem disp-symbol-system-value apr))
-              (movl (int nil) (mem disp-symbol-system-plist apr))
-              (movl apr eax)
-              (addl (int symbol-tag) eax)
-              (addl (int (align symbol-size)) apr)
-              ac)]
-      [($make-port/input)  (do-make-port input-port-tag arg* ac)]
-      [($make-port/output) (do-make-port output-port-tag arg* ac)]
-      [($make-port/both)   (do-make-port input/output-port-tag arg* ac)]
-      [($make-tcbucket)
-       (list* (movl (Simple (car arg*)) eax)
-              (movl eax (mem disp-tcbucket-tconc apr))
-              (movl (Simple (cadr arg*)) eax)
-              (movl eax (mem disp-tcbucket-key apr))
-              (movl (Simple (caddr arg*)) eax)
-              (movl eax (mem disp-tcbucket-val apr))
-              (movl (Simple (cadddr arg*)) eax)
-              (movl eax (mem disp-tcbucket-next apr))
-              (movl apr eax)
-              (addl (int vector-tag) eax)
-              (addl (int (align tcbucket-size)) apr)
-              ac)] 
-      [($record) 
-       (let ([rtd (car arg*)]
-             [ac 
-              (let f ([arg* (cdr arg*)] [idx disp-record-data])
-                (cond
-                  [(null? arg*) 
-                   (list* (movl apr eax)
-                          (addl (int vector-tag) eax)
-                          (addl (int (align idx)) apr)
-                          ac)]
-                  [else 
-                   (list* (movl (Simple (car arg*)) eax)
-                          (movl eax (mem idx apr))
-                          (f (cdr arg*) (fx+ idx wordsize)))]))])
-         (cond
-           [(constant? rtd)
-            (list* (movl (Simple rtd) (mem 0 apr)) ac)]
-           [else
-            (list* (movl (Simple rtd) eax) (movl eax (mem 0 apr)) ac)]))]
-      [(vector) 
-       (let f ([arg* arg*] [idx disp-vector-data])
-         (cond
-           [(null? arg*) 
-            (list* (movl apr eax)
-                   (addl (int vector-tag) eax)
-                   (movl (int (fx- idx disp-vector-data))
-                         (mem disp-vector-length apr))
-                   (addl (int (align idx)) apr)
-                   ac)]
-           [else 
-            (list* (movl (Simple (car arg*)) eax)
-                   (movl eax (mem idx apr))
-                   (f (cdr arg*) (fx+ idx wordsize)))]))]
-     [($string)
-      (let f ([arg* arg*] [idx disp-string-data])
-        (cond
-          [(null? arg*) 
-           (list* (movb (int 0) (mem idx apr))
-                  (movl apr eax)
-                  (addl (int string-tag) eax)
-                  (movl (int (fx* (fx- idx disp-string-data) wordsize))
-                        (mem disp-string-length apr))
-                  (addl (int (align (fxadd1 idx))) apr)
-                  ac)]
-          [else
-           (record-case (car arg*)
-             [(constant c) 
-              (unless (char? c) (error who  "invalid arg to string ~s" x))
-              (list* (movb (int (char->integer c)) (mem idx apr))
-                     (f (cdr arg*) (fxadd1 idx)))]
-             [else
-              (list* (movl (Simple (car arg*)) ebx)
-                     (movb bh (mem idx apr))
-                     (f (cdr arg*) (fxadd1 idx)))])]))]
-     [($current-frame)
-      (list* (movl (pcb-ref 'next-continuation) eax)
-             ac)]
-     [($seal-frame-and-call) 
-      (list* (movl (Simple (car arg*)) cpr) ; proc
-             (movl (pcb-ref 'frame-base) eax)
-             ; eax=baseofstack
-             (movl (mem (fx- 0 wordsize) eax) ebx) ; underflow handler
-             (movl ebx (mem (fx- 0 wordsize) fpr)) ; set
-             ; create a new cont record
-             (movl (int continuation-tag) (mem 0 apr))
-             (movl fpr (mem disp-continuation-top apr))
-             ; compute the size of the captured frame
-             (movl eax ebx) 
-             (subl fpr ebx) 
-             (subl (int wordsize) ebx)
-             ; and store it
-             (movl ebx (mem disp-continuation-size apr))
-             ; load next cont
-             (movl (pcb-ref 'next-continuation) ebx)
-             ; and store it
-             (movl ebx (mem disp-continuation-next apr))
-             ; adjust ap
-             (movl apr eax)
-             (addl (int vector-tag) eax)
-             (addl (int continuation-size) apr)
-             ; store new cont in current-cont
-             (movl eax (pcb-ref 'next-continuation))
-             ; adjust fp
-             (movl fpr (pcb-ref 'frame-base))
-             (subl (int wordsize) fpr)
-             ; tail-call f
-             (movl eax (mem (fx- 0 wordsize) fpr))
-             (movl (int (argc-convention 1)) eax)
-             (tail-indirect-cpr-call)
-             ac)]
-     [($code-size) 
-      (indirect-ref arg* (fx- disp-code-instrsize vector-tag)  ac)]
-     [($code-reloc-vector) 
-       (indirect-ref arg* (fx- disp-code-relocsize vector-tag) ac)]
-     [($code-freevars) 
-       (indirect-ref arg* (fx- disp-code-freevars vector-tag) ac)]
-     [($set-car! $set-cdr! $vector-set! $string-set! $exit
-       $set-symbol-value! $set-symbol-plist! 
-       $code-set!  primitive-set! 
-       $set-code-object! $set-code-object+offset! $set-code-object+offset/rel!
-       $record-set!
-       $set-port-input-index! $set-port-input-size!
-       $set-port-output-index! $set-port-output-size!) 
-      (do-effect-prim op arg*
-        (cons (movl (int void-object) eax) ac))]
-     [(fixnum? immediate? $fxzero? boolean? char? pair? vector? string? symbol?
-       procedure? null? not eof-object? $fx= $fx< $fx<= $fx> $fx>= eq?
-       $char= $char< $char<= $char> $char>= $unbound-object? $code? 
-       $record? $record/rtd? bwp-object? port? input-port? output-port?) 
-      (do-pred->value-prim op arg* ac)]
-     [($code->closure)
-      (list* 
-        (movl (Simple (car arg*)) eax)
-        (addl (int (fx- disp-code-data vector-tag)) eax)
-        (movl eax (mem 0 apr))
-        (movl apr eax)
-        (addl (int closure-tag) eax)
-        (addl (int (align disp-closure-data)) apr)
-        ac)]
-     [($frame->continuation)
-      (NonTail 
-        (make-closure (make-code-loc SL_continuation_code) arg*)
-        ac)]
-     [($make-call-with-values-procedure)
-      (NonTail 
-        (make-closure (make-code-loc SL_call_with_values) arg*)
-        ac)]
-     [($make-values-procedure)
-      (NonTail 
-        (make-closure (make-code-loc SL_values) arg*)
-        ac)]
-     [else
-      (error 'value-prim "unhandled ~s" op)]))
-  (define (indirect-assignment arg* offset ac)
-    (list*
-      (movl (Simple (car arg*)) eax)
-      (movl (Simple (cadr arg*)) ebx)
-      (movl ebx (mem offset eax))
-       ;;; record side effect
-      (addl (int offset) eax)
-      (shrl (int pageshift) eax)
-      (sall (int wordshift) eax)
-      (addl (pcb-ref 'dirty-vector) eax)
-      (movl (int dirty-word) (mem 0 eax))
-      ac))
-  (define (do-effect-prim op arg* ac)
-    (case op
-      [($vector-set!) 
-       (list* (movl (Simple (car arg*)) ebx)
-              (addl (Simple (cadr arg*)) ebx)
-              (addl (int (fx- disp-vector-data vector-tag)) ebx)
-              (movl (Simple (caddr arg*)) eax)
-              (movl eax (mem 0 ebx))
-              ;;; record side effect
-              (shrl (int pageshift) ebx)
-              (sall (int wordshift) ebx)
-              (addl (pcb-ref 'dirty-vector) ebx)
-              (movl (int dirty-word) (mem 0 ebx))
-              ac)]
-      [($code-set!) 
-       (list* (movl (Simple (cadr arg*)) eax)
-              (sarl (int fx-shift) eax)
-              (addl (Simple (car arg*)) eax)
-              (movl (Simple (caddr arg*)) ebx)
-              (sall (int (fx- 8 fx-shift)) ebx)
-              (movb bh (mem (fx- disp-code-data vector-tag) eax))
-              ac)]
-      [($string-set!) 
-       (list* (movl (Simple (cadr arg*)) eax)
-              (sarl (int fx-shift) eax)
-              (addl (Simple (car arg*)) eax)
-              (movl (Simple (caddr arg*)) ebx)
-              (movb bh (mem (fx- disp-string-data string-tag) eax))
-              ac)]
-      [($set-car!) 
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ebx)
-              (movl ebx (mem (fx- disp-car pair-tag) eax))
-               ;;; record side effect
-               (shrl (int pageshift) eax)
-               (sall (int wordshift) eax)
-               (addl (pcb-ref 'dirty-vector) eax)
-               (movl (int dirty-word) (mem 0 eax))
-              ac)]
-      [($set-cdr!) 
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ebx)
-              (movl ebx (mem (fx- disp-cdr pair-tag) eax))
-               ;;; record side effect
-               (shrl (int pageshift) eax)
-               (sall (int wordshift) eax)
-               (addl (pcb-ref 'dirty-vector) eax)
-               (movl (int dirty-word) (mem 0 eax))
-              ac)]
-      [($set-tcbucket-key!)
-       (indirect-assignment arg* (fx- disp-tcbucket-key vector-tag) ac)]
-      [($set-tcbucket-val!)
-       (indirect-assignment arg* (fx- disp-tcbucket-val vector-tag) ac)]
-      [($set-tcbucket-next!)
-       (indirect-assignment arg* (fx- disp-tcbucket-next vector-tag) ac)]
-      [($set-tcbucket-tconc!)
-       (indirect-assignment arg* (fx- disp-tcbucket-tconc vector-tag) ac)]
-      [($set-port-input-index!)
-       (list*
-         (movl (Simple (car arg*)) eax)
-         (movl (Simple (cadr arg*)) ebx)
-         (movl ebx (mem (fx- disp-port-input-index vector-tag) eax))
-         ac)]
-      [($set-port-input-size!)
-       (list*
-         (movl (Simple (car arg*)) eax)
-         (movl (Simple (cadr arg*)) ebx)
-         (movl (int 0) (mem (fx- disp-port-input-index vector-tag) eax))
-         (movl ebx (mem (fx- disp-port-input-size vector-tag) eax))
-         ac)]
-      [($set-port-output-index!)
-       (list*
-         (movl (Simple (car arg*)) eax)
-         (movl (Simple (cadr arg*)) ebx)
-         (movl ebx (mem (fx- disp-port-output-index vector-tag) eax))
-         ac)]
-      [($set-port-output-size!)
-       (list*
-         (movl (Simple (car arg*)) eax)
-         (movl (Simple (cadr arg*)) ebx)
-         (movl (int 0) (mem (fx- disp-port-output-index vector-tag) eax))
-         (movl ebx (mem (fx- disp-port-output-size vector-tag) eax))
-         ac)]
-      [($set-symbol-value!) 
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ebx)
-              (movl ebx (mem (fx- disp-symbol-value symbol-tag) eax))
-               ;;; record side effect
-               (addl (int (fx- disp-symbol-value symbol-tag)) eax)
-               (shrl (int pageshift) eax)
-               (sall (int wordshift) eax)
-               (addl (pcb-ref 'dirty-vector) eax)
-               (movl (int dirty-word) (mem 0 eax))
-              ac)]
-      [(primitive-set!) 
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ebx)
-              (movl ebx (mem (fx- disp-symbol-system-value symbol-tag) eax))
-               ;;; record side effect
-               (addl (int (fx- disp-symbol-system-value symbol-tag)) eax)
-               (shrl (int pageshift) eax)
-               (sall (int wordshift) eax)
-               (addl (pcb-ref 'dirty-vector) eax)
-               (movl (int dirty-word) (mem 0 eax))
-              ac)]
-      [($set-symbol-plist!) 
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ebx)
-              (movl ebx (mem (fx- disp-symbol-plist symbol-tag) eax))
-               ;;; record side effect
-               (addl (int (fx- disp-symbol-plist symbol-tag)) eax)
-               (shrl (int pageshift) eax)
-               (sall (int wordshift) eax)
-               (addl (pcb-ref 'dirty-vector) eax)
-               (movl (int dirty-word) (mem 0 eax))
-              ac)]
-      [($set-symbol-unique-string!) 
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ebx)
-              (movl ebx (mem (fx- disp-symbol-unique-string symbol-tag) eax))
-               ;;; record side effect
-               (addl (int (fx- disp-symbol-unique-string symbol-tag)) eax)
-               (shrl (int pageshift) eax)
-               (sall (int wordshift) eax)
-               (addl (pcb-ref 'dirty-vector) eax)
-               (movl (int dirty-word) (mem 0 eax))
-              ac)]
-      [($set-symbol-string!) 
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ebx)
-              (movl ebx (mem (fx- disp-symbol-string symbol-tag) eax))
-               ;;; record side effect
-               (addl (int (fx- disp-symbol-string symbol-tag)) eax)
-               (shrl (int pageshift) eax)
-               (sall (int wordshift) eax)
-               (addl (pcb-ref 'dirty-vector) eax)
-               (movl (int dirty-word) (mem 0 eax))
-              ac)] 
-      [($record-set!) 
-       (list* (movl (Simple (car arg*)) ebx)
-              (addl (Simple (cadr arg*)) ebx)
-              (movl (Simple (caddr arg*)) eax)
-              (addl (int (fx- disp-record-data record-ptag)) ebx)
-              (movl eax (mem 0 ebx))
-               ;;; record side effect
-               (shrl (int pageshift) ebx)
-               (sall (int wordshift) ebx)
-               (addl (pcb-ref 'dirty-vector) ebx)
-               (movl (int dirty-word) (mem 0 ebx))
-              ac)]
-      [(cons void $fxadd1 $fxsub1 $record-ref)
-       (let f ([arg* arg*])
-         (cond
-           [(null? arg*) ac]
-           [else 
-            (Effect (car arg*) (f (cdr arg*)))]))]
-      [else 
-       (error 'do-effect-prim "unhandled op ~s" op)]))
- (define (do-simple-test x Lt Lf ac)
-    (unless (or Lt Lf)
-      (error 'Pred "no labels"))
-    (cond
-      [(not Lt)
-       (list* (cmpl (int bool-f) x) (je Lf) ac)]
-      [(not Lf)
-       (list* (cmpl (int bool-f) x) (jne Lt) ac)]
-      [else
-       (list* (cmpl (int bool-f) x) (je Lf) (jmp Lt) ac)]))
-  (define (Simple x)
-    (record-case x
-      [(cp-var i) 
-       (mem (fx+ (fx* i wordsize) (fx- disp-closure-data closure-tag)) cpr)]
-      [(frame-var i) (mem (fx* i (fx- 0 wordsize)) fpr)]
-      [(constant c) (constant-val c)]
-      [(code-loc label) (label-address label)]
-      [(primref op) (primref-loc op)]
-      [else (error 'Simple "what ~s" x)]))
-  (define (closure-size x)
-    (align (fx+ disp-closure-data
-                (fx* wordsize (length (closure-free* x))))))
-  (define (assign-codes rhs* n* i ac)
-    (cond
-      [(null? rhs*) ac]
-      [else
-       (record-case (car rhs*)
-         [(closure label free*)
-          (cons (movl (Simple label) (mem i apr))
-                (assign-codes 
-                  (cdr rhs*) (cdr n*) (fx+ i (car n*)) ac))])]))
-  (define (whack-free x i n* rhs* ac)
-    (cond
-      [(null? rhs*) ac]
-      [else
-       (let ([free (closure-free* (car rhs*))])
-         (let f ([free free] [j (fx+ i disp-closure-data)])
-           (cond
-             [(null? free) 
-              (whack-free x (fx+ i (car n*)) (cdr n*) (cdr rhs*) ac)]
-             [(eq? (car free) x)
-              (cons
-                (movl eax (mem j apr))
-                (f (cdr free) (fx+ j wordsize)))]
-             [else (f (cdr free) (fx+ j wordsize))])))]))
-  (define (assign-nonrec-free* rhs* all-rhs* n* seen ac)
-    (cond
-      [(null? rhs*) ac]
-      [else
-       (let f ([ls (closure-free* (car rhs*))] [seen seen])
-         (cond
-           [(null? ls) 
-            (assign-nonrec-free* (cdr rhs*) all-rhs* n* seen ac)]
-           [(memq (car ls) seen) (f (cdr ls) seen)]
-           [else
-            (cons
-              (movl (Simple (car ls)) eax)
-              (whack-free (car ls) 0 n* all-rhs*
-                (f (cdr ls) (cons (car ls) seen))))]))]))
-  (define (assign-rec-free* lhs* rhs* all-n* ac)
-    (list* (movl apr eax)
-           (addl (int closure-tag) eax)
-           (let f ([lhs* lhs*] [n* all-n*])
-             (cond
-               [(null? (cdr lhs*)) 
-                (cons
-                  (movl eax (Simple (car lhs*)))
-                  (whack-free (car lhs*) 0 all-n* rhs* ac))]
-               [else
-                (cons
-                  (movl eax (Simple (car lhs*)))
-                  (whack-free (car lhs*) 0 all-n* rhs*
-                    (cons
-                      (addl (int (car n*)) eax)
-                      (f (cdr lhs*) (cdr n*)))))]))))
-  (define (sum ac ls)
-    (cond
-      [(null? ls) ac]
-      [else (sum (fx+ ac (car ls)) (cdr ls))]))
-  (define (do-fix lhs* rhs* ac)
-    ;;; 1. first, set the code pointers in the right places
-    ;;; 2. next, for every variable appearing in the rhs* but is not in
-    ;;;    the lhs*, load it once and set it everywhere it occurs.
-    ;;; 3. next, compute the values of the lhs*, and for every computed
-    ;;;    value, store it on the stack, and set it everywhere it occurs
-    ;;;    in the rhs*
-    ;;; 4. that's it.
-    (let* ([n* (map closure-size rhs*)])
-      (assign-codes rhs* n* 0
-        (assign-nonrec-free* rhs* rhs* n* lhs*
-          (assign-rec-free* lhs* rhs* n*
-            (cons (addl (int (sum 0 n*)) apr) ac))))))
-  (define (frame-adjustment offset)
-    (fx* (fxsub1 offset) (fx- 0 wordsize)))
-  (define (NonTail x ac) 
-    (record-case x
-      [(constant c)
-       (cons (movl (constant-val c) eax) ac)]
-      [(frame-var)
-       (cons (movl (Simple x) eax) ac)]
-      [(cp-var)
-       (cons (movl (Simple x) eax) ac)]
-      [(foreign-label L) 
-       (cons (movl (list 'foreign-label L) eax) ac)]
-      [(primref c)
-       (cons (movl (primref-loc c) eax) ac)]
-      [(closure label arg*)
-       (let f ([arg* arg*] [off disp-closure-data])
-         (cond
-           [(null? arg*)
-            (list* (movl (Simple label) (mem 0 apr))
-                   (movl apr eax)
-                   (addl (int (align off)) apr)
-                   (addl (int closure-tag) eax)
-                   ac)]
-           [else
-            (list* (movl (Simple (car arg*)) eax)
-                   (movl eax (mem off apr))
-                   (f (cdr arg*) (fx+ off wordsize)))]))]
-      [(conditional test conseq altern)
-       (let ([Lj (unique-label)] [Lf (unique-label)])
-         (Pred test #f Lf
-           (NonTail conseq
-             (list* (jmp Lj) Lf (NonTail altern (cons Lj ac))))))]
-      [(seq e0 e1)
-       (Effect e0 (NonTail e1 ac))]
-      [(fix lhs* rhs* body)
-       (do-fix lhs* rhs* (NonTail body ac))]
-      [(primcall op rand*)
-       (do-value-prim op rand* ac)]
-      [(new-frame base-idx size body)
-       (NonTail body ac)]
-      [(call-cp call-convention rp-convention offset size mask)
-       (let ([L_CALL (unique-label)])
-         (case call-convention
-           [(normal)
-            (list* (addl (int (frame-adjustment offset)) fpr)
-                   (movl (int (argc-convention size)) eax)
-                   (jmp L_CALL)
-                   ; NEW FRAME
-                   `(byte-vector ,mask)
-                   `(int ,(fx* offset wordsize))
-                   `(current-frame-offset)
-                   (rp-label rp-convention)
-                   `(byte 0) ; padding for indirect calls only
-                   `(byte 0) ; direct calls are ok
-                   L_CALL
-                   (indirect-cpr-call)
-                   (movl (mem 0 fpr) cpr)
-                   (subl (int (frame-adjustment offset)) fpr)
-                   ac)]
-           [(foreign) 
-            (list* (addl (int (frame-adjustment offset)) fpr)
-                   (movl (int (argc-convention size)) eax)
-                   (movl '(foreign-label "ik_foreign_call") ebx)
-                   (jmp L_CALL)
-                   ; NEW FRAME
-                   (byte-vector mask)
-                   `(int ,(fx* offset wordsize))
-                   `(current-frame-offset)
-                   (rp-label rp-convention) ; should be 0, since C has 1 rv
-                   '(byte 0)
-                   '(byte 0)
-                   '(byte 0)
-                   L_CALL
-                   (call ebx)
-                   (movl (mem 0 fpr) cpr)
-                   (subl (int (frame-adjustment offset)) fpr)
-                   ac)]
-           [else
-            (error who "invalid convention ~s for call-cp" call-convention)]))]
-      [else (error 'NonTail "invalid expression ~s" x)]))
-  (define (Pred x Lt Lf ac)
-    (record-case x
-      [(frame-var i) 
-       (do-simple-test (idx->frame-loc i) Lt Lf ac)]
-      [(cp-var i) 
-       (do-simple-test (Simple x) Lt Lf ac)]
-      [(constant c) 
-       (if c
-           (if Lt (cons (jmp Lt) ac) ac)
-           (if Lf (cons (jmp Lf) ac) ac))]
-     [(fix lhs* rhs* body)
-      (do-fix lhs* rhs* (Pred body Lt Lf ac))]
-      [(primcall op rand*)
-       (do-pred-prim op rand* Lt Lf ac)]
-      [(conditional test conseq altern)
-       (cond
-         [(not Lt) 
-          (let ([Lj^ (unique-label)] [Lf^ (unique-label)])
-            (Pred test #f Lf^
-              (Pred conseq Lj^ Lf
-                (cons Lf^
-                  (Pred altern #f Lf 
-                    (cons Lj^ ac))))))]
-         [(not Lf) 
-          (let ([Lj^ (unique-label)] [Lf^ (unique-label)])
-            (Pred test #f Lf^
-              (Pred conseq Lt Lj^
-                (cons Lf^
-                  (Pred altern Lt #f 
-                    (cons Lj^ ac))))))]
-         [else 
-          (let ([Lf^ (unique-label)])
-            (Pred test #f Lf^
-              (Pred conseq Lt Lf
-                (cons Lf^
-                  (Pred altern Lt Lf ac)))))])] 
-      [(seq e0 e1)
-       (Effect e0 (Pred e1 Lt Lf ac))]
-      [(new-frame)
-       (NonTail x (do-simple-test eax Lt Lf ac))]
-      [else (error 'Pred "invalid expression ~s" x)]))
-  (define (idx->frame-loc i)
-    (mem (fx* i (fx- 0 wordsize)) fpr))
-  (define (Effect x ac)
-   (record-case x
-     [(constant) ac]
-     [(primcall op rand*)
-      (do-effect-prim op rand* ac)]
-     [(conditional test conseq altern)
-      (let* ([Ljoin (unique-label)]
-             [ac (cons Ljoin ac)]
-             [altern-ac (Effect altern ac)])
-        (cond
-          [(eq? altern-ac ac) ;; altern is nop
-           (let* ([conseq-ac (Effect conseq ac)])
-             (cond
-               [(eq? conseq-ac ac) ;; conseq is nop too!
-                (Effect test ac)]
-               [else  ; "when" pattern
-                (Pred test #f Ljoin conseq-ac)]))]
-          [else 
-           (let* ([Lf (unique-label)]
-                  [nac (list* (jmp Ljoin) Lf altern-ac)]
-                  [conseq-ac (Effect conseq nac)])
-             (cond
-               [(eq? conseq-ac nac) ;; "unless" pattern"
-                (Pred test Ljoin #f altern-ac)]
-               [else
-                (Pred test #f Lf conseq-ac)]))]))]
-;;;  [(conditional test conseq altern)
-;;;   (let ([Lf (unique-label)] [Ljoin (unique-label)])
-;;;     (Pred test #f Lf
-;;;       (Effect conseq
-;;;         (list* (jmp Ljoin) Lf (Effect altern (cons Ljoin ac))))))]
-     [(seq e0 e1)
-      (Effect e0 (Effect e1 ac))]
-     [(fix lhs* rhs* body)
-      (do-fix lhs* rhs* (Effect body ac))]
-     [(assign loc val)
-      (record-case loc
-        [(frame-var i)
-         (record-case val
-           [(constant c) 
-            (cons (movl (constant-val c) (idx->frame-loc i)) ac)]
-           [else
-            (NonTail val
-              (cons (movl eax (idx->frame-loc i)) ac))])]
-        [else (error who "invalid assign loc ~s" loc)])]
-     [(eval-cp check body)
-      (cond
-        [check
-         (NonTail body
-           (list* 
-             (movl eax cpr)
-             (andl (int closure-mask) eax)
-             (cmpl (int closure-tag) eax)
-             (jne (label SL_nonprocedure))
-             ac))]
-        [(primref? body)
-         (list* (movl (primref-loc (primref-name body)) cpr) ac)]
-        [else
-         (NonTail body (list* (movl eax cpr) ac))])]
-     [(save-cp loc)
-      (record-case loc
-        [(frame-var i)
-         (cons (movl cpr (idx->frame-loc i)) ac)]
-        [else (error who "invalid cpr loc ~s" x)])]
-     [(new-frame) (NonTail x ac)]
-     [(frame-var) ac]
-     [else (error 'Effect "invalid expression ~s" x)]))
-  (define (Tail x ac) 
-    (record-case x
-     [(return x) 
-      (NonTail x (cons (ret) ac))]
-     [(conditional test conseq altern)
-      (let ([L (unique-label)])
-        (Pred test #f L
-          (Tail conseq 
-            (cons L (Tail altern ac)))))]
-     [(seq e0 e1)
-      (Effect e0 (Tail e1 ac))]
-     [(fix lhs* rhs* body)
-      (do-fix lhs* rhs* (Tail body ac))]
-     [(new-frame idx size body)
-      (Tail body ac)]
-     [(tailcall-cp call-convention argc)
-      (list* 
-        (movl (int (argc-convention argc)) eax)
-        (case call-convention
-          [(normal) (tail-indirect-cpr-call)]
-          [(apply)  (jmp (label SL_apply))]
-          [else 
-           (error who "invalid tail-call convention ~s" call-convention)])
-        ac)]
-;;;     [(call-cp call-convention rp-convention idx argc mask)
-;;;      (unless (eq? rp-convention 'tail)
-;;;        (error who "nontail rp (~s) in tail context" rp-convention))
-;;;      (let f ([i 0])
-;;;        (cond
-;;;          [(fx= i argc)
-;;;           (case call-convention
-;;;             [(normal) 
-;;;              (list* 
-;;;                (movl (int (argc-convention argc)) eax)
-;;;                (tail-indirect-cpr-call)
-;;;                ac)]
-;;;             [(apply)
-;;;              (list* 
-;;;                (movl (int (argc-convention argc)) eax)
-;;;                (jmp (label SL_apply)) 
-;;;                ac)]
-;;;             [else
-;;;              (error who "invalid conv ~s in tail call-cpr" call-convention)])]
-;;;          [else
-;;;            (list* (movl (mem (fx* (fx+ idx (fxadd1 i))
-;;;                                   (fx- 0 wordsize)) fpr)
-;;;                         eax)
-;;;                   (movl eax (mem (fx* (fx+ i 1) (fx- 0 wordsize)) fpr))
-;;;                   (f (fxadd1 i)))]))]
-     [else (error 'Tail "invalid expression ~s" x)]))
-  (define (handle-vararg fml-count ac)
-    (define CONTINUE_LABEL (unique-label))
-    (define DONE_LABEL (unique-label))
-    (define CONS_LABEL (unique-label))
-    (define LOOP_HEAD (unique-label))
-    (define L_CALL (unique-label))
-    (list* (cmpl (int (argc-convention (fxsub1 fml-count))) eax)
-           (jg (label SL_invalid_args))
-           (jl CONS_LABEL)
-           (movl (int nil) ebx)
-           (jmp DONE_LABEL)
-           CONS_LABEL
-           (movl (pcb-ref 'allocation-redline) ebx)
-           (addl eax ebx)
-           (addl eax ebx)
-           (cmpl ebx apr)
-           (jle LOOP_HEAD)
-           ; overflow
-           (addl eax esp) ; advance esp to cover args
-           (pushl cpr)    ; push current cp
-           (pushl eax)    ; push argc
-           (negl eax)     ; make argc positive
-           (addl (int (fx* 4 wordsize)) eax) ; add 4 words to adjust frame size
-           (pushl eax)    ; push frame size
-           (addl eax eax) ; double the number of args
-           (movl eax (mem (fx* -2 wordsize) fpr)) ; pass it as first arg
-           (movl (int (argc-convention 1)) eax) ; setup argc
-           (movl (primref-loc 'do-vararg-overflow) cpr) ; load handler
-           (jmp L_CALL)   ; go to overflow handler
-           ; NEW FRAME
-           (int 0)        ; if the framesize=0, then the framesize is dynamic
-           '(current-frame-offset)
-           (int 0)        ; multiarg rp
-           (byte 0)
-           (byte 0)
-           L_CALL
-           (indirect-cpr-call)
-           (popl eax)     ; pop framesize and drop it
-           (popl eax)     ; reload argc
-           (popl cpr)     ; reload cp
-           (subl eax fpr) ; readjust fp
-           LOOP_HEAD
-           (movl (int nil) ebx)
-           CONTINUE_LABEL
-           (movl ebx (mem disp-cdr apr))
-           (movl (mem fpr eax) ebx)
-           (movl ebx (mem disp-car apr))
-           (movl apr ebx)
-           (addl (int pair-tag) ebx)
-           (addl (int pair-size) apr)
-           (addl (int (fxsll 1 fx-shift)) eax)
-           (cmpl (int (fx- 0 (fxsll fml-count fx-shift))) eax)
-           (jle CONTINUE_LABEL)
-           DONE_LABEL
-           (movl ebx (mem (fx- 0 (fxsll fml-count fx-shift)) fpr))
-           ac))
-  (define (Entry check? x ac)
-    (record-case x
-      [(clambda-case fml* proper body)
-       (let ([ac (Tail body ac)])
-         (cond
-           [(and proper check?)
-            (list* (cmpl (int (argc-convention (length fml*))) eax)
-                   (jne (label SL_invalid_args))
-                   ac)]
-           [proper ac]
-           [else
-            (handle-vararg (length fml*) ac)]))]))
-  (define make-dispatcher
-    (lambda (j? L L* x x* ac)
-      (cond
-        [(null? L*) (if j? (cons (jmp (label L)) ac) ac)]
-        [else
-         (record-case x
-           [(clambda-case fml* proper _)
-            (cond
-              [proper
-               (list* (cmpl (int (argc-convention (length fml*))) eax)
-                      (je (label L))
-                      (make-dispatcher #t 
-                        (car L*) (cdr L*) (car x*) (cdr x*) ac))]
-              [else
-               (list* (cmpl (int (argc-convention (fxsub1 (length fml*)))) eax)
-                      (jle (label L))
-                      (make-dispatcher #t
-                        (car L*) (cdr L*) (car x*) (cdr x*) ac))])])])))
-  (define (handle-cases x x*)
-    (let ([L* (map (lambda (_) (gensym)) x*)]
-          [L (gensym)])
-      (make-dispatcher #f L L* x x*
-        (let f ([x x] [x* x*] [L L] [L* L*])
-          (cond
-            [(null? x*) 
-             (cons (label L) (Entry 'check x '()))]
-            [else
-             (cons (label L)
-               (Entry #f x
-                 (f (car x*) (cdr x*) (car L*) (cdr L*))))])))))
-  (define (CodeExpr x)
-    (record-case x
-      [(clambda-code L cases free)
-       (list*
-         (length free)
-         (label L)
-         (handle-cases (car cases) (cdr cases)))]))
-  (record-case x
-    [(codes list body)
-     (cons (cons 0 (Tail body '()))
-           (map CodeExpr list))]))
-
-
-(define SL_nonprocedure (gensym "SL_nonprocedure"))
-
-(define SL_top_level_value_error (gensym "SL_top_level_value_error"))
-(define SL_car_error (gensym "SL_car_error"))
-(define SL_cdr_error (gensym "SL_cdr_error"))
-
-(define SL_invalid_args (gensym "SL_invalid_args"))
-(define SL_foreign_call (gensym "SL_foreign_call"))
-(define SL_continuation_code (gensym "SL_continuation_code"))
-(define SL_multiple_values_error_rp (gensym "SL_multiple_values_error_rp"))
-(define SL_multiple_values_ignore_rp (gensym "SL_multiple_ignore_error_rp"))
-(define SL_underflow_multiple_values (gensym "SL_underflow_multiple_values"))
-(define SL_underflow_handler (gensym "SL_underflow_handler"))
-(define SL_scheme_exit (gensym "SL_scheme_exit"))
-(define SL_apply (gensym "SL_apply"))
-(define SL_values (gensym "SL_values"))
-(define SL_call_with_values (gensym "SL_call_with_values"))
-
-(module ()
-(list*->code*
-  (list
-    (list 0
-          (label SL_car_error)
-          (movl ebx (mem (fx- 0 wordsize) fpr))
-          (movl (primref-loc 'car-error) cpr)
-          (movl (int (argc-convention 1)) eax)
-          (tail-indirect-cpr-call))
-
-    (list 0
-          (label SL_cdr_error)
-          (movl ebx (mem (fx- 0 wordsize) fpr))
-          (movl (primref-loc 'cdr-error) cpr)
-          (movl (int (argc-convention 1)) eax)
-          (tail-indirect-cpr-call))
-
-    (list 0
-          (label SL_top_level_value_error)
-          (movl ebx (mem (fx- 0 wordsize) fpr))
-          (movl (primref-loc 'top-level-value-error) cpr)
-          (movl (int (argc-convention 1)) eax)
-          (tail-indirect-cpr-call))
-
-    (let ([L_cwv_done (gensym)]
-          [L_cwv_loop (gensym)]
-          [L_cwv_multi_rp (gensym)]
-          [L_cwv_call (gensym)])
-      (list 
-          0 ; no free vars
-          (label SL_call_with_values)
-          (cmpl (int (argc-convention 2)) eax)
-          (jne (label SL_invalid_args))
-          (movl (mem (fx- 0 wordsize) fpr) ebx) ; producer
-          (movl ebx cpr)
-          (andl (int closure-mask) ebx)
-          (cmpl (int closure-tag) ebx)
-          (jne (label SL_nonprocedure))
-          (movl (int (argc-convention 0)) eax)
-          (subl (int (fx* wordsize 2)) fpr)
-          (jmp (label L_cwv_call))
-          ; MV NEW FRAME
-          (byte-vector '#(#b110))
-          (int (fx* wordsize 3))
-           '(current-frame-offset)
-          (label-address L_cwv_multi_rp)
-          (byte 0)
-          (byte 0)
-          (label L_cwv_call)
-          (indirect-cpr-call)
-          ;;; one value returned
-          (addl (int (fx* wordsize 2)) fpr)
-          (movl (mem (fx* -2 wordsize) fpr) ebx) ; consumer
-          (movl ebx cpr)
-          (movl eax (mem (fx- 0 wordsize) fpr))
-          (movl (int (argc-convention 1)) eax)
-          (andl (int closure-mask) ebx)
-          (cmpl (int closure-tag) ebx)
-          (jne (label SL_nonprocedure))
-          (tail-indirect-cpr-call)
-          ;;; multiple values returned
-          (label L_cwv_multi_rp)
-          ; because values does not pop the return point
-          ; we have to adjust fp one more word here
-          (addl (int (fx* wordsize 3)) fpr) 
-          (movl (mem (fx* -2 wordsize) fpr) cpr) ; consumer
-          (cmpl (int (argc-convention 0)) eax)
-          (je (label L_cwv_done))
-          (movl (int (fx* -4 wordsize)) ebx)
-          (addl fpr ebx)  ; ebx points to first value
-          (movl ebx ecx)
-          (addl eax ecx)  ; ecx points to the last value
-          (label L_cwv_loop)
-          (movl (mem 0 ebx) edx)
-          (movl edx (mem (fx* 3 wordsize) ebx))
-          (subl (int wordsize) ebx)
-          (cmpl ecx ebx)
-          (jge (label L_cwv_loop))
-          (label L_cwv_done)
-          (movl cpr ebx)
-          (andl (int closure-mask) ebx)
-          (cmpl (int closure-tag) ebx)
-          (jne (label SL_nonprocedure))
-          (tail-indirect-cpr-call)))
-
-    (let ([L_values_one_value (gensym)]
-          [L_values_many_values (gensym)])
-      (list 0 ; no freevars
-          (label SL_values)
-          (cmpl (int (argc-convention 1)) eax)
-          (je (label L_values_one_value))
-          (label L_values_many_values)
-          (movl (mem 0 fpr) ebx) ; return point
-          (jmp (mem disp-multivalue-rp ebx))     ; go
-          (label L_values_one_value)
-          (movl (mem (fx- 0 wordsize) fpr) eax)
-          (ret)))
-
-    (let ([L_apply_done (gensym)]
-          [L_apply_loop (gensym)])
-      (list 0 
-          (label SL_apply)
-          (movl (mem fpr eax) ebx)
-          (cmpl (int nil) ebx)
-          (je (label L_apply_done))
-          (label L_apply_loop)
-          (movl (mem (fx- disp-car pair-tag) ebx) ecx)
-          (movl (mem (fx- disp-cdr pair-tag) ebx) ebx)
-          (movl ecx (mem fpr eax))
-          (subl (int wordsize) eax)
-          (cmpl (int nil) ebx)
-          (jne (label L_apply_loop))
-          (label L_apply_done)
-          (addl (int wordsize) eax)
-          (tail-indirect-cpr-call)))
-
-    (list 0
-          (label SL_nonprocedure)
-          (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg
-          (movl (primref-loc '$apply-nonprocedure-error-handler) cpr)
-          (movl (int (argc-convention 1)) eax)
-          (tail-indirect-cpr-call))
-
-    (list 0
-          (label SL_multiple_values_error_rp)
-          (movl (primref-loc '$multiple-values-error) cpr)
-          (tail-indirect-cpr-call))
-
-    (list 0
-          (label SL_multiple_values_ignore_rp)
-          (ret))
-
-    (list 0
-          (label SL_invalid_args)
-          ;;;
-          (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg
-          (negl eax)
-          (movl eax (mem (fx- 0 (fx* 2 wordsize)) fpr))
-          (movl (primref-loc '$incorrect-args-error-handler) cpr)
-          (movl (int (argc-convention 2)) eax)
-          (tail-indirect-cpr-call))
-
-    (let ([Lset (gensym)] [Lloop (gensym)])
-      (list 0
-          (label SL_foreign_call)
-          (movl fpr (pcb-ref 'frame-pointer))
-          (movl apr (pcb-ref 'allocation-pointer))
-          (movl fpr ebx)
-          (movl (pcb-ref 'system-stack) esp)
-          (pushl pcr)
-          (cmpl (int 0) eax)
-          (je (label Lset))
-          (label Lloop)
-          (movl (mem ebx eax) ecx)
-          (pushl ecx)
-          (addl (int 4) eax)
-          (cmpl (int 0) eax)
-          (jne (label Lloop))
-          (label Lset)
-          ; FOREIGN NEW FRAME
-          (call cpr)
-          (movl (pcb-ref 'frame-pointer) fpr)
-          (movl (pcb-ref 'allocation-pointer) apr)
-          (ret)))
-
-    (let ([L_cont_zero_args      (gensym)] 
-          [L_cont_mult_args      (gensym)]
-          [L_cont_one_arg        (gensym)]
-          [L_cont_mult_move_args (gensym)]
-          [L_cont_mult_copy_loop (gensym)])
-      (list  1 ; freevars
-          (label SL_continuation_code)
-          (movl (mem (fx- disp-closure-data closure-tag) cpr) ebx) ; captured-k
-          (movl ebx (pcb-ref 'next-continuation)) ; set
-          (movl (pcb-ref 'frame-base) ebx)
-          (cmpl (int (argc-convention 1)) eax)
-          (jg (label L_cont_zero_args))
-          (jl (label L_cont_mult_args))
-          (label L_cont_one_arg)
-          (movl (mem (fx- 0 wordsize) fpr) eax)
-          (movl ebx fpr)
-          (subl (int wordsize) fpr)
-          (ret)
-          (label L_cont_zero_args)
-          (subl (int wordsize) ebx)
-          (movl ebx fpr)
-          (movl (mem 0 ebx) ebx) ; return point
-          (jmp (mem disp-multivalue-rp ebx))  ; go
-          (label L_cont_mult_args)
-          (subl (int wordsize) ebx)
-          (cmpl ebx fpr)
-          (jne (label L_cont_mult_move_args))
-          (movl (mem 0 ebx) ebx)
-          (jmp (mem disp-multivalue-rp ebx))
-          (label L_cont_mult_move_args)
-          ; move args from fpr to ebx
-          (movl (int 0) ecx)
-          (label L_cont_mult_copy_loop)
-          (subl (int wordsize) ecx)
-          (movl (mem fpr ecx) edx)
-          (movl edx (mem ebx ecx))
-          (cmpl ecx eax)
-          (jne (label L_cont_mult_copy_loop))
-          (movl ebx fpr)
-          (movl (mem 0 ebx) ebx)
-          (jmp (mem disp-multivalue-rp ebx))
-          ))
-    )))
-
-
-
-(define (compile-expr expr)
-  (let* ([p (recordize expr)]
-         [p (optimize-direct-calls p)]
-;;;         [foo (analyze-cwv p)]
-         [p (optimize-letrec p)]
-         ;[p (remove-letrec p)]
-         [p (remove-assignments p)]
-         [p (convert-closures p)]
-         [p (lift-codes p)]
-         [p (introduce-primcalls p)]
-         [p (simplify-operands p)]
-         [p (insert-stack-overflow-checks p)]
-         [p (insert-allocation-checks p)]
-         [p (remove-local-variables p)]
-         [p (optimize-ap-check p)]
-         [ls* (generate-code p)]
-         [f (when (assembler-output)
-              (for-each 
-                (lambda (ls)
-                  (for-each (lambda (x) (printf "    ~s\n" x)) ls))
-                ls*))]
-         [code* (list*->code* ls*)])
-    (car code*)))
-
-(define compile-file
-  (lambda (input-file output-file . rest)
-    (let ([ip (open-input-file input-file)]
-          [op (apply open-output-file output-file rest)])
-      (let f ()
-        (let ([x (read ip)])
-          (unless (eof-object? x)
-            (fasl-write (compile-expr (expand x)) op)
-            (f))))
-      (close-input-port ip)
-      (close-output-port op))))
-
-(primitive-set! 'compile-file compile-file)
-(primitive-set! 'assembler-output (make-parameter #f))
-(primitive-set! 'compile
-  (lambda (x)
-    (let ([code (compile-expr (expand x))])
-      (let ([proc ($code->closure code)])
-        (proc)))))
-
-)
-
diff --git a/src/libcompile-9.0.ss b/src/libcompile-9.0.ss
deleted file mode 100644
index 8e8dc40..0000000
--- a/src/libcompile-9.0.ss
+++ /dev/null
@@ -1,3774 +0,0 @@
-
-;;; 9.0: * calls (gensym <symbol>) instead of 
-;;;        (gensym (symbol->string <symbol>)) in order to avoid incrementing
-;;;        gensym-count.
-;;; 6.7: * open-coded top-level-value, car, cdr
-;;; 6.2: * side-effects now modify the dirty-vector
-;;;      * added bwp-object?
-;;;      * added pointer-value
-;;;      * added tcbuckets
-;;; 6.1: * added case-lambda, dropped lambda
-;;; 6.0: * basic compiler
-
-(let ()
-
-(define-syntax cond-expand
-  (lambda (x)
-    (syntax-case x ()
-      [(_ test conseq altern)
-       (if (eval (syntax-object->datum #'test))
-           #'conseq
-           #'altern)])))
-
-(cond-expand (eq? "" "")
-  (include "record-case.chez.ss")
-  (include "record-case.ss"))
-
-
-(include "set-operations.ss")
-
-
-(define open-coded-primitives
-;;; these primitives, when found in operator position with the correct
-;;; number of arguments, will be open-coded by the generator.  If an 
-;;; incorrect number of args is detected, or if they appear in non-operator
-;;; position, then they cannot be open-coded, and the pcb-primitives table
-;;; is consulted for a reference of the pcb slot containing the primitive.
-;;; If it's not found there, an error is signalled.
-;;;
-;;; prim-name          args
-  '([$constant-ref      1   value]
-    [$constant-set!     2   effect]
-    [$pcb-ref           1   value]
-    [$pcb-set!          2   effect]
-    ;;; type predicates
-    [fixnum?            1   pred]
-    [immediate?         1   pred]
-    [boolean?           1   pred]
-    [char?              1   pred]
-    [pair?              1   pred]
-    [symbol?            1   pred]
-    [vector?            1   pred]
-    [string?            1   pred]
-    [procedure?         1   pred]
-    [null?              1   pred]
-    [eof-object?        1   pred]
-    [bwp-object?        1   pred]
-    [$unbound-object?   1   pred]
-    [$forward-ptr?      1   pred]
-    [not                1   pred]
-    [pointer-value      1  value]
-    [eq?                2   pred]
-    ;;; fixnum primitives
-    [$fxadd1            1   value]
-    [$fxsub1            1   value]
-    [$fx+               2   value]
-    [$fx-               2   value]
-    [$fx*               2   value]
-    [$fxsll             2   value]
-    [$fxsra             2   value]
-    [$fxlogand          2   value]
-    [$fxlogor           2   value]
-    [$fxlogxor          2   value]
-    [$fxlognot          1   value]
-    [$fxquotient        2   value]
-    [$fxmodulo          2   value]
-    ;;; fixnum predicates
-    [$fxzero?           1   pred]
-    [$fx=               2   pred]
-    [$fx<               2   pred]
-    [$fx<=              2   pred]
-    [$fx>               2   pred]
-    [$fx>=              2   pred]
-    ;;; character predicates
-    [$char=             2   pred]
-    [$char<             2   pred]
-    [$char<=            2   pred]
-    [$char>             2   pred]
-    [$char>=            2   pred]
-    ;;; character conversion
-    [$fixnum->char      1   value]
-    [$char->fixnum      1   value]
-    ;;; lists/pairs
-    [cons               2   value]
-    [list*         positive value]
-    [list             any   value]
-    [car                1   value]
-    [cdr                1   value]
-    [$car               1   value]
-    [$cdr               1   value]
-    [$set-car!          2   effect]
-    [$set-cdr!          2   effect]
-    ;;; vectors
-    [$make-vector       1   value]
-    [vector           any   value]
-    [$vector-length     1   value]
-    [$vector-ref        2   value]
-    [$vector-set!       3   effect]
-    [$vector-memq       2   value]
-    ;;; strings
-    [$make-string       1   value]
-    [$string          any   value]
-    [$string-length     1   value]
-    [$string-ref        2   value]
-    [$string-set!       3   effect]
-    ;;; symbols
-    [$make-symbol       1   value]
-    [$symbol-value      1   value]
-    [$symbol-string     1   value]
-    [$symbol-unique-string     1   value]
-    [$set-symbol-value! 2   effect]
-    [$set-symbol-string! 2   effect]
-    [$set-symbol-unique-string! 2   effect]
-    [$symbol-plist      1   value]
-    [$set-symbol-plist! 2   effect]
-    [primitive-ref 1 value]
-    [primitive-set! 2 effect]
-    [top-level-value      1   value]
-    ;;; ports
-    [port?                    1 pred]
-    [input-port?              1 pred]
-    [output-port?             1 pred]
-    [$make-port/input         7 value]
-    [$make-port/output        7 value]
-    [$make-port/both          7 value]
-    [$port-handler            1 value]
-    [$port-input-buffer       1 value]
-    [$port-input-index        1 value]
-    [$port-input-size         1 value]
-    [$port-output-buffer      1 value]
-    [$port-output-index       1 value]
-    [$port-output-size        1 value]
-    [$set-port-input-index!   2 effect]
-    [$set-port-input-size!    2 effect]
-    [$set-port-output-index!  2 effect]
-    [$set-port-output-size!   2 effect]
-    ;;; tcbuckets
-    [$make-tcbucket       4   value]
-    [$tcbucket-key        1   value]
-    [$tcbucket-val        1   value]
-    [$tcbucket-next       1   value]
-    [$set-tcbucket-val!   2  effect]
-    [$set-tcbucket-next!  2  effect]
-    [$set-tcbucket-tconc! 2  effect]
-    ;;; misc
-    [eof-object         0   value]
-    [void               0   value]
-    [$exit              1   effect]
-    [$fp-at-base        0   pred]
-    [$current-frame     0   value]
-    [$seal-frame-and-call 1  tail]
-    [$frame->continuation 1 value]
-    ;;; 
-    ;;; records
-    ;;;
-    [$make-record       2   value]
-    [$record?           1    pred]
-    [$record/rtd?       2    pred]
-    [$record-rtd        1   value]
-    [$record-ref        2   value]
-    [$record-set!       3  effect]
-    [$record          any   value]
-    ;;;
-    ;;; asm
-    ;;;
-    [$code?              1    pred]
-    [$code-size          1    value]
-    [$code-reloc-vector  1    value]
-    [$code-freevars      1    value]
-    [$code-ref           2    value]
-    [$code-set!          3    value]
-    [$code->closure      1    value]
-    ;;;
-    [$make-call-with-values-procedure 0 value]
-    [$make-values-procedure 0 value]
-    [$install-underflow-handler 0 effect]
-   ))
-
-(define (primitive-context x)
-  (cond
-    [(assq x open-coded-primitives) => caddr]
-    [else (error 'primitive-context "unknown prim ~s" x)]))
-
-(define (open-codeable? x)
-  (cond
-    [(assq x open-coded-primitives) #t]
-    [else  #f]))
-
-(define (open-coded-primitive-args x)
-  (cond
-    [(assq x open-coded-primitives) => cadr]
-    [else (error 'open-coded-primitive-args "invalid ~s" x)]))
-
-;;; end of primitives table section
-
-  
-(define-record constant (value))
-(define-record code-loc (label))
-(define-record foreign-label (label))
-(define-record var (name assigned))
-(define-record cp-var (idx))
-(define-record frame-var (idx))
-(define-record new-frame (base-idx size body))
-(define-record save-cp (loc))
-(define-record eval-cp (check body))
-(define-record return (value))
-(define-record call-cp
-  (call-convention rp-convention base-idx arg-count live-mask))
-(define-record tailcall-cp (convention arg-count))
-(define-record primcall (op arg*))
-(define-record primref (name))
-(define-record conditional (test conseq altern))
-(define-record bind (lhs* rhs* body))
-(define-record recbind (lhs* rhs* body))
-(define-record fix (lhs* rhs* body))
-
-(define-record seq (e0 e1))
-(define-record clambda-case (arg* proper body))
-(define-record clambda (cases))
-(define-record clambda-code (label cases free))
-(define-record closure (code free*))
-(define-record funcall (op rand*))
-(define-record appcall (op rand*))
-(define-record forcall (op rand*))
-(define-record code-rec (arg* proper free* body))
-(define-record codes (list body))
-(define-record assign (lhs rhs))
-
-(define (unique-var x)
-  (make-var (gensym x) #f))
-
-
-(define (make-bind^ lhs* rhs* body)
-  (if (null? lhs*)
-      body
-      (make-bind lhs* rhs* body)))
-
-(define (recordize x)
-  (define (gen-fml* fml*)
-    (cond
-      [(pair? fml*)
-       (cons (unique-var (car fml*))
-             (gen-fml* (cdr fml*)))]
-      [(symbol? fml*)
-       (unique-var fml*)]
-      [else '()]))
-  (define (properize fml*)
-    (cond
-      [(pair? fml*)
-       (cons (car fml*) (properize (cdr fml*)))]
-      [(null? fml*) '()]
-      [else (list fml*)]))
-  (define (extend-env fml* nfml* env)
-    (cons (cons fml* nfml*) env))
-  (define (quoted-sym x)
-    (if (and (list? x)
-             (fx= (length x) 2)
-             (eq? 'quote (car x))
-             (symbol? (cadr x)))
-        (cadr x)
-        (error 'quoted-sym "not a quoted symbol ~s" x)))
-   (define (quoted-string x)
-    (if (and (list? x)
-             (fx= (length x) 2)
-             (eq? 'quote (car x))
-             (string? (cadr x)))
-        (cadr x)
-        (error 'quoted-string "not a quoted string ~s" x)))
-  (define (lookup^ x lhs* rhs*)
-    (cond
-      [(pair? lhs*)
-       (if (eq? x (car lhs*))
-           (car rhs*)
-           (lookup^ x (cdr lhs*) (cdr rhs*)))]
-      [(eq? x lhs*) rhs*]
-      [else #f]))
-  (define (lookup x env)
-    (cond
-      [(pair? env)
-       (or (lookup^ x (caar env) (cdar env))
-           (lookup x (cdr env)))]
-      [else #f]))
-  (define (E x env)
-    (cond
-      [(pair? x)
-       (case (car x)
-         [(quote)  (make-constant (cadr x))]
-         [(if) 
-          (make-conditional 
-            (E (cadr x) env)
-            (E (caddr x) env)
-            (E (cadddr x) env))]
-         [(set!)
-          (let ([lhs (cadr x)] [rhs (caddr x)])
-            (make-assign
-              (or (lookup lhs env) 
-                  (error 'recordize "invalid assignment ~s" x))
-              (E rhs env)))]
-         [(begin)
-          (let f ([a (cadr x)] [d (cddr x)])
-            (cond
-              [(null? d) (E a env)]
-              [else
-               (make-seq 
-                 (E a env)
-                 (f (car d) (cdr d)))]))]
-         [(letrec)
-          (unless (fx= (length x) 3) (syntax-error x))
-          (let ([bind* (cadr x)] [body (caddr x)])
-            (let ([lhs* (map car bind*)]
-                  [rhs* (map cadr bind*)])
-              (let ([nlhs* (gen-fml* lhs*)])
-                (let ([env (extend-env lhs* nlhs* env)])
-                  (make-recbind nlhs* 
-                                (map (lambda (rhs) (E rhs env)) rhs*)
-                                (E body env))))))]
-         [(letrec)
-          (unless (fx= (length x) 3) (syntax-error x))
-          (let ([bind* (cadr x)] [body (caddr x)])
-            (let ([lhs* (map car bind*)]
-                  [rhs* (map cadr bind*)]
-                  [v* (map (lambda (x) '(void)) bind*)]
-                  [t* (map (lambda (x) (gensym)) bind*)])
-              (E `((case-lambda 
-                     [,lhs* 
-                       ((case-lambda 
-                          [,t* 
-                           (begin ,@(map (lambda (x v) `(set! ,x ,v)) lhs* t*)
-                                  ,body)])
-                        ,@rhs*)])
-                   ,@v*)
-                 env)))]
-         [(case-lambda)
-          (let ([cls*
-                 (map
-                   (lambda (cls)
-                     (let ([fml* (car cls)] [body (cadr cls)])
-                       (let ([nfml* (gen-fml* fml*)])
-                         (let ([body (E body (extend-env fml* nfml* env))])
-                           (make-clambda-case 
-                             (properize nfml*) 
-                             (list? fml*) 
-                             body)))))
-                   (cdr x))])
-            (make-clambda cls*))]
-         [(foreign-call)
-          (let ([name (quoted-string (cadr x))] [arg* (cddr x)])
-            (make-forcall name
-              (map (lambda (x) (E x env)) arg*)))]
-         [(|#primitive|)
-          (let ([var (cadr x)])
-            (make-primref var))]
-         ;;; [(|#primitive|)
-         ;;;  (let ([var (cadr x)])
-         ;;;    (if (primitive? var)
-         ;;;        (make-primref var)
-         ;;;        (error 'recordize "invalid primitive ~s" var)))]
-         [(top-level-value)
-          (let ([var (quoted-sym (cadr x))])
-            (if (eq? (expand-mode) 'bootstrap)
-                (error 'compile "reference to ~s in bootstrap mode" var)
-                ;(make-primref var)
-                (make-funcall
-                  (make-primref 'top-level-value)
-                  (list (make-constant var)))))]
-         ;;; [(top-level-value)
-         ;;;  (let ([var (quoted-sym (cadr x))])
-         ;;;    (if (eq? (expand-mode) 'bootstrap)
-         ;;;        (if (primitive? var)
-         ;;;            (make-primref var)
-         ;;;            (error 'compile "invalid primitive ~s" var))
-         ;;;        (make-funcall
-         ;;;          (make-primref 'top-level-value)
-         ;;;          (list (make-constant var)))))]
-         [(set-top-level-value!)
-          (make-funcall (make-primref 'set-top-level-value!)
-                        (map (lambda (x) (E x env)) (cdr x)))]
-         [(memv) 
-          (make-funcall
-             (make-primref 'memq)
-             (map (lambda (x) (E x env)) (cdr x)))]
-         [($apply)
-          (let ([proc (cadr x)] [arg* (cddr x)])
-            (make-appcall
-              (E proc env)
-              (map (lambda (x) (E x env)) arg*)))]
-         [(void) 
-          (make-constant (void))]
-         [else
-          (make-funcall 
-            (E (car x) env)
-            (map (lambda (x) (E x env)) (cdr x)))])]
-      [(symbol? x)
-       (or (lookup x env)
-           (error 'recordize "invalid reference in ~s" x))]
-      [else (error 'recordize "invalid expression ~s" x)]))
-  (E x '()))
-
-
-(define (unparse x)
-  (define (E-args proper x)
-    (if proper 
-        (map E x)
-        (let f ([a (car x)] [d (cdr x)])
-          (cond
-            [(null? d) (E a)]
-            [else (cons (E a) (f (car d) (cdr d)))]))))
-  (define (E x)
-    (record-case x
-      [(constant c) `(quote ,c)]
-      [(code-loc x) `(code-loc ,x)]
-      [(var x) (string->symbol (format "v:~a" x))]
-      [(primref x) x]
-      [(conditional test conseq altern) 
-       `(if ,(E test) ,(E conseq) ,(E altern))]
-      [(primcall op arg*) `(,op . ,(map E arg*))]
-      [(bind lhs* rhs* body) 
-       `(let ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
-          ,(E body))]
-      [(recbind lhs* rhs* body) 
-       `(letrec ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
-          ,(E body))]
-      [(fix lhs* rhs* body) 
-       `(fix ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
-          ,(E body))]
-      [(seq e0 e1) `(begin ,(E e0) ,(E e1))]
-      [(clambda-case args proper body)
-       `(clambda-case ,(E-args proper args) ,(E body))]
-      [(clambda cls*)
-       `(case-lambda . ,(map E cls*))]
-      [(clambda-code label clauses free)
-       `(code ,label . ,(map E clauses))]
-      [(closure code free*)
-       `(closure ,(E code) ,(map E free*))]
-      [(code-rec arg* proper free* body) 
-       `(code-rec [arg: ,(E-args proper arg*)]
-              [free: ,(map E free*)]
-          ,(E body))]
-      [(codes list body)
-       `(codes ,(map E list)
-          ,(E body))]
-      [(funcall rator rand*) `(funcall ,(E rator) . ,(map E rand*))]
-      [(appcall rator rand*) `(appcall ,(E rator) . ,(map E rand*))]
-      [(forcall rator rand*) `(foreign-call ,rator . ,(map E rand*))]
-      [(assign lhs rhs) `(set! ,(E lhs) ,(E rhs))]
-      [(return x) `(return ,(E x))]
-      [(new-frame base-idx size body)
-       `(new-frame [base: ,base-idx]
-                   [size: ,size]
-          ,(E body))]
-      [(frame-var idx) 
-       (string->symbol (format "fv.~a" idx))]
-      [(cp-var idx) 
-       (string->symbol (format "cp.~a" idx))]
-      [(save-cp expr)
-       `(save-cp ,(E expr))]
-      [(eval-cp check body)
-       `(eval-cp ,check ,(E body))]
-      [(call-cp call-convention rp-convention base-idx arg-count live-mask)
-       `(call-cp [conv: ,call-convention]
-                 [rpconv: ,rp-convention]
-                 [base-idx: ,base-idx]
-                 [arg-count: ,arg-count]
-                 [live-mask: ,live-mask])]
-      [(foreign-label x) `(foreign-label ,x)]
-      [else (error 'unparse "invalid record ~s" x)]))
-  (E x))
-
-(define (optimize-direct-calls x)
-  (define who 'optimize-direct-calls)
-  (define (make-conses ls)
-    (cond
-      [(null? ls) (make-constant '())]
-      [else 
-       (make-primcall 'cons 
-         (list (car ls) (make-conses (cdr ls))))]))      
-  (define (properize lhs* rhs*)
-    (cond
-      [(null? lhs*) (error who "improper improper")]
-      [(null? (cdr lhs*)) 
-       (list (make-conses rhs*))]
-      [else (cons (car rhs*) (properize (cdr lhs*) (cdr rhs*)))]))
-  (define (inline-case cls rand*)
-    (record-case cls
-      [(clambda-case fml* proper body)
-       (if proper
-           (and (fx= (length fml*) (length rand*))
-                (make-bind fml* rand* body))
-           (and (fx<= (length fml*) (length rand*))
-                (make-bind fml* (properize fml* rand*) body)))]))
-  (define (try-inline cls* rand* default)
-    (cond
-      [(null? cls*) default]
-      [(inline-case (car cls*) rand*)]
-      [else (try-inline (cdr cls*) rand* default)]))
-  (define (inline rator rand*)
-    (record-case rator
-      [(clambda cls*)
-       (try-inline cls* rand*
-           (make-funcall rator rand*))]
-      [else (make-funcall rator rand*)]))
-  (define (Expr x)
-    (record-case x
-      [(constant) x]
-      [(var) x]
-      [(primref) x]
-      [(bind lhs* rhs* body)
-       (make-bind lhs* (map Expr rhs*) (Expr body))]
-      [(recbind lhs* rhs* body)
-       (make-recbind lhs* (map Expr rhs*) (Expr body))]
-      [(conditional test conseq altern)
-       (make-conditional 
-         (Expr test)
-         (Expr conseq)
-         (Expr altern))]
-      [(seq e0 e1) 
-       (make-seq (Expr e0) (Expr e1))]
-      [(clambda cls*)
-       (make-clambda
-         (map (lambda (x)
-                (record-case x
-                  [(clambda-case fml* proper body)
-                   (make-clambda-case fml* proper (Expr body))]))
-              cls*))]
-      [(primcall rator rand*) 
-       (make-primcall rator (map Expr rand*))]
-      [(funcall rator rand*)
-       (inline (Expr rator) (map Expr rand*))]
-      [(appcall rator rand*)
-       (make-appcall (Expr rator) (map Expr rand*))]
-      [(forcall rator rand*) 
-       (make-forcall rator (map Expr rand*))]
-      [(assign lhs rhs)
-       (make-assign lhs (Expr rhs))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (Expr x))
-
-
-
-
-(define lambda-both 0)
-(define lambda-producer 0)
-(define lambda-consumer 0)
-(define lambda-none 0)
-(define branching-producer 0)
-
-
-(define (analyze-cwv x)
-  (define who 'analyze-cwv)
-  (define (lambda? x)
-    (record-case x
-      [(clambda) #t]
-      [else      #f]))
-  (define (branching-producer? x)
-    (define (bt? x)
-      (record-case x
-        [(bind lhs* rhs* body) (bt? body)]
-        [(recbind lhs* rhs* body) (bt? body)]
-        [(conditional test conseq altern) #t]
-        [(seq e0 e1) (bt? e1)]
-        [else #f]))
-    (define (branching-clause? x)
-      (record-case x 
-        [(clambda-case fml* proper body) 
-         (bt? body)]))
-    (record-case x
-      [(clambda cls*)
-       (ormap branching-clause? cls*)]
-      [else #f]))
-  (define (analyze producer consumer)
-    (cond
-      [(and (lambda? producer) (lambda? consumer))
-       (set! lambda-both (fxadd1 lambda-both))]
-      [(lambda? producer) 
-       (set! lambda-producer (fxadd1 lambda-producer))]
-      [(lambda? consumer)
-       (set! lambda-consumer (fxadd1 lambda-consumer))]
-      [else 
-       (set! lambda-none (fxadd1 lambda-none))])
-    (when (branching-producer? producer)
-      (set! branching-producer (fxadd1 branching-producer)))
-    (printf "both=~s p=~s c=~s none=~s branching-prod=~s\n"
-            lambda-both lambda-producer lambda-consumer lambda-none
-            branching-producer))
-  (define (E x)
-    (record-case x
-      [(constant) (void)]
-      [(var) (void)]
-      [(primref) (void)]
-      [(bind lhs* rhs* body)
-       (for-each E rhs*) (E body)]
-      [(recbind lhs* rhs* body)
-       (for-each E rhs*) (E body)]
-      [(conditional test conseq altern)
-       (E test)
-       (E conseq)
-       (E altern)]
-      [(seq e0 e1) (E e0) (E e1)]
-      [(clambda cls*)
-       (for-each 
-         (lambda (x)
-           (record-case x
-             [(clambda-case fml* proper body) (E body)]))
-         cls*)]
-      [(primcall rator rand*) 
-       (for-each E rand*)
-       (when (and (eq? rator 'call-with-values) (fx= (length rand*) 2))
-         (analyze (car rand*) (cadr rand*)))]
-      [(funcall rator rand*)
-       (E rator) (for-each E rand*)
-       (when (and (record-case rator
-                    [(primref op) (eq? op 'call-with-values)]
-                    [else #f])
-                  (fx= (length rand*) 2))
-         (analyze (car rand*) (cadr rand*)))]
-      [(appcall rator rand*)
-       (E rator) (for-each E rand*)]
-      [(forcall rator rand*) 
-       (for-each E rand*)]
-      [(assign lhs rhs)
-       (E rhs)]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (E x))
-
-
-
-
-(define (optimize-letrec x)
-  (define who 'optimize-letrec)
-  (define (extend-hash lhs* h ref)
-    (for-each (lambda (lhs) (put-hash-table! h lhs #t)) lhs*)
-    (lambda (x)
-      (unless (get-hash-table h x #f)
-        (put-hash-table! h x #t)
-        (ref x))))
-  (define (E* x* ref comp)
-    (cond
-      [(null? x*) '()]
-      [else
-       (cons (E (car x*) ref comp)
-             (E* (cdr x*) ref comp))]))  
-  (define (do-rhs* i lhs* rhs* ref comp vref vcomp)
-    (cond
-      [(null? rhs*) '()]
-      [else
-       (let ([h (make-hash-table)])
-         (let ([ref
-                (lambda (x)
-                  (unless (get-hash-table h x #f)
-                    (put-hash-table! h x #t)
-                    (ref x)
-                    (when (memq x lhs*)
-                      (vector-set! vref i #t))))]
-               [comp
-                (lambda ()
-                  (vector-set! vcomp i #t)
-                  (comp))])
-           (cons (E (car rhs*) ref comp)
-                 (do-rhs* (fxadd1 i) lhs* (cdr rhs*) ref comp vref vcomp))))]))
-  (define (partition-rhs* i lhs* rhs* vref vcomp)
-    (cond
-      [(null? lhs*) (values '() '() '() '() '() '())]
-      [else
-       (let-values 
-         ([(slhs* srhs* llhs* lrhs* clhs* crhs*)
-           (partition-rhs* (fxadd1 i) (cdr lhs*) (cdr rhs*) vref vcomp)]
-          [(lhs rhs) (values (car lhs*) (car rhs*))])
-         (cond
-           [(var-assigned lhs) 
-            (values slhs* srhs* llhs* lrhs* (cons lhs clhs*) (cons rhs crhs*))]
-           [(clambda? rhs)
-            (values slhs* srhs* (cons lhs llhs*) (cons rhs lrhs*) clhs* crhs*)]
-           [(or (vector-ref vref i) (vector-ref vcomp i))
-            (values slhs* srhs* llhs* lrhs* (cons lhs clhs*) (cons rhs crhs*))]
-           [else
-            (values (cons lhs slhs*) (cons rhs srhs*) llhs* lrhs* clhs* crhs*)]
-           ))]))
-  (define (do-recbind lhs* rhs* body ref comp)
-    (let ([h (make-hash-table)]
-          [vref (make-vector (length lhs*) #f)]
-          [vcomp (make-vector (length lhs*) #f)])
-      (let* ([ref (extend-hash lhs* h ref)]
-             [body (E body ref comp)])
-        (let ([rhs* (do-rhs* 0 lhs* rhs* ref comp vref vcomp)])
-          (let-values ([(slhs* srhs* llhs* lrhs* clhs* crhs*)
-                        (partition-rhs* 0 lhs* rhs* vref vcomp)])
-            (let ([v* (map (lambda (x) (make-primcall 'void '())) clhs*)]
-                  [t* (map (lambda (x) (unique-var 'tmp)) clhs*)])
-              (make-bind slhs* srhs*
-                (make-bind clhs* v*
-                  (make-fix llhs* lrhs*
-                    (make-bind t* crhs*
-                      (build-assign* clhs* t* body)))))))))))
-  (define (build-assign* lhs* rhs* body)
-    (cond
-      [(null? lhs*)  body]
-      [else
-       (make-seq
-         (make-assign (car lhs*) (car rhs*))
-         (build-assign* (cdr lhs*) (cdr rhs*) body))]))
-  (define (E x ref comp)
-    (record-case x
-      [(constant) x]
-      [(var) (ref x) x]
-      [(assign lhs rhs)
-       (set-var-assigned! lhs #t)
-       (ref lhs)
-       (make-assign lhs (E rhs ref comp))]
-      [(primref) x]
-      [(bind lhs* rhs* body)
-       (let ([rhs* (E* rhs* ref comp)])
-         (let ([h (make-hash-table)])
-           (let ([body (E body (extend-hash lhs* h ref) comp)])
-             (make-bind lhs* rhs* body))))]
-      [(recbind lhs* rhs* body)
-       (if (null? lhs*)
-           (E body ref comp)
-           (do-recbind lhs* rhs* body ref comp))]
-      [(conditional e0 e1 e2)
-       (make-conditional (E e0 ref comp) (E e1 ref comp) (E e2 ref comp))]
-      [(seq e0 e1) (make-seq (E e0 ref comp) (E e1 ref comp))]
-      [(clambda cls*)
-       (make-clambda
-         (map (lambda (x)
-                (record-case x
-                  [(clambda-case fml* proper body)
-                   (let ([h (make-hash-table)])
-                     (let ([body (E body (extend-hash fml* h ref) void)])
-                       (make-clambda-case fml* proper body)))]))
-              cls*))]
-      [(primcall rator rand*) 
-       (when (memq rator '(call/cc call/cf))
-         (comp))
-       (make-primcall rator (E* rand* ref comp))]
-      [(funcall rator rand*)
-       (let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)])
-         (record-case rator
-           [(primref op)
-            (when (memq op '(call/cc call/cf))
-              (comp))]
-           [else
-            (comp)])
-         (make-funcall rator rand*))]
-      [(appcall rator rand*)
-       (let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)])
-         (record-case rator
-           [(primref op)
-            (when (memq op '(call/cc call/cf))
-              (comp))]
-           [else
-            (comp)])
-         (make-appcall rator rand*))]
-      [(forcall rator rand*) 
-       (make-forcall rator (E* rand* ref comp))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (E x (lambda (x) (error who "free var ~s found" x))
-       void))
-
-
-(define (remove-letrec x)
-  (define who 'remove-letrec)
-  (define (Expr x)
-    (record-case x
-      [(constant) x]
-      [(var) x]
-      [(primref) x]
-      [(bind lhs* rhs* body)
-       (make-bind lhs* (map Expr rhs*) (Expr body))]
-      [(recbind lhs* rhs* body)
-       (let ([t* (map (lambda (lhs) (unique-var 'tmp)) lhs*)]
-             [v* (map (lambda (lhs) (make-primcall 'void '())) lhs*)])
-         (make-bind lhs* v*
-           (make-bind t* (map Expr rhs*)
-             (let f ([lhs* lhs*] [t* t*])
-               (cond
-                 [(null? lhs*) (Expr body)]
-                 [else
-                  (make-seq
-                    (make-assign (car lhs*) (car t*))
-                    (f (cdr lhs*) (cdr t*)))])))))]
-      ;[(fix lhs* rhs* body)
-      ; (Expr (make-recbind lhs* rhs* body))]
-      [(fix lhs* rhs* body)
-       (make-fix lhs* (map Expr rhs*) (Expr body))]
-      [(conditional test conseq altern)
-       (make-conditional 
-         (Expr test)
-         (Expr conseq)
-         (Expr altern))]
-      [(seq e0 e1) 
-       (make-seq (Expr e0) (Expr e1))]
-      [(clambda cls*)
-       (make-clambda
-         (map (lambda (x)
-                (record-case x
-                  [(clambda-case fml* proper body)
-                   (make-clambda-case fml* proper (Expr body))]))
-              cls*))]
-      [(primcall rator rand*) 
-       (make-primcall rator (map Expr rand*))]
-      [(funcall rator rand*)
-       (make-funcall (Expr rator) (map Expr rand*))]
-      [(appcall rator rand*)
-       (make-appcall (Expr rator) (map Expr rand*))]
-      [(forcall rator rand*) 
-       (make-forcall rator (map Expr rand*))]
-      [(assign lhs rhs)
-       (make-assign lhs (Expr rhs))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (Expr x))
-
-
-
-(define (uncover-assigned x)
-  (define who 'uncover-assigned)
-  (define (Expr* x*)
-    (for-each Expr x*))
-  (define (Expr x)
-    (record-case x
-      [(constant) (void)]
-      [(var) (void)]
-      [(primref) (void)]
-      [(bind lhs* rhs* body)
-       (begin (Expr body) (Expr* rhs*))]
-      [(recbind lhs* rhs* body)
-       (begin (Expr body) (Expr* rhs*))]
-      [(fix lhs* rhs* body)
-       (Expr* rhs*) 
-       (Expr body)
-       (when (ormap var-assigned lhs*)
-         (error 'uncover-assigned "a fix lhs is assigned"))]
-      [(conditional test conseq altern)
-       (begin (Expr test) (Expr conseq) (Expr altern))]
-      [(seq e0 e1) (begin (Expr e0) (Expr e1))]
-      [(clambda cls*)
-       (for-each
-         (lambda (cls)
-           (Expr (clambda-case-body cls)))
-         cls*)]
-      [(primcall rator rand*) (Expr* rand*)]
-      [(funcall rator rand*)
-       (begin (Expr rator) (Expr* rand*))]
-      [(appcall rator rand*)
-       (begin (Expr rator) (Expr* rand*))]
-      [(forcall rator rand*) (Expr* rand*)]
-      [(assign lhs rhs)
-       (set-var-assigned! lhs #t)
-       (Expr rhs)]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (Expr x))
-
-
-
-(define (rewrite-assignments x)
-  (define who 'rewrite-assignments)
-  (define (fix-lhs* lhs*)
-    (cond
-      [(null? lhs*) (values '() '() '())]
-      [else
-       (let ([x (car lhs*)])
-         (let-values ([(lhs* a-lhs* a-rhs*) (fix-lhs* (cdr lhs*))])
-           (cond
-             [(var-assigned x)
-              (let ([t (unique-var 'assignment-tmp)])
-                (values (cons t lhs*) (cons x a-lhs*) (cons t a-rhs*)))]
-             [else
-              (values (cons x lhs*) a-lhs* a-rhs*)])))]))
-  (define (bind-assigned lhs* rhs* body)
-    (cond
-      [(null? lhs*) body]
-      [else
-       (make-bind lhs*
-         (map (lambda (rhs) (make-primcall 'vector (list rhs))) rhs*)
-         body)]))
-  (define (Expr x)
-    (record-case x
-      [(constant) x]
-      [(var) 
-       (cond
-         [(var-assigned x) 
-          (make-primcall '$vector-ref (list x (make-constant 0)))]
-         [else x])]
-      [(primref) x]
-      [(bind lhs* rhs* body)
-       (let-values ([(lhs* a-lhs* a-rhs*) (fix-lhs* lhs*)]) 
-         (make-bind lhs* (map Expr rhs*) 
-           (bind-assigned a-lhs* a-rhs* (Expr body))))]
-      [(fix lhs* rhs* body)
-       (make-fix lhs* (map Expr rhs*) (Expr body))]
-      [(conditional test conseq altern)
-       (make-conditional (Expr test) (Expr conseq) (Expr altern))]
-      [(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
-      [(clambda cls*) 
-       (make-clambda
-         (map (lambda (cls)
-                (record-case cls
-                  [(clambda-case fml* proper body)
-                   (let-values ([(fml* a-lhs* a-rhs*) (fix-lhs* fml*)])
-                     (make-clambda-case fml* proper 
-                       (bind-assigned a-lhs* a-rhs* (Expr body))))]))
-              cls*))]
-      [(primcall op rand*)
-       (make-primcall op (map Expr rand*))]
-      [(forcall op rand*)
-       (make-forcall op (map Expr rand*))]
-      [(funcall rator rand*)
-       (make-funcall (Expr rator) (map Expr rand*))]
-      [(appcall rator rand*)
-       (make-appcall (Expr rator) (map Expr rand*))]
-      [(assign lhs rhs)
-       (unless (var-assigned lhs)
-         (error 'rewrite-assignments "not assigned ~s in ~s" lhs x))
-       (make-primcall '$vector-set! (list lhs (make-constant 0) (Expr rhs)))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (Expr x))
- 
-
-(define (remove-assignments x)
-    (uncover-assigned x)
-    (rewrite-assignments x))
-  
-
-
-
-
-(define (convert-closures prog)
-  (define who 'convert-closures)
-  (define (Expr* x*)
-    (cond
-      [(null? x*) (values '() '())]
-      [else
-       (let-values ([(a a-free) (Expr (car x*))]
-                    [(d d-free) (Expr* (cdr x*))])
-         (values (cons a d) (union a-free d-free)))]))
-   (define (do-clambda* x*)
-    (cond
-      [(null? x*) (values '() '())]
-      [else
-       (let-values ([(a a-free) (do-clambda (car x*))]
-                    [(d d-free) (do-clambda* (cdr x*))])
-         (values (cons a d) (union a-free d-free)))]))
-  (define (do-clambda x)
-    (record-case x 
-      [(clambda cls*)
-       (let-values ([(cls* free) 
-                     (let f ([cls* cls*])
-                       (cond
-                         [(null? cls*) (values '() '())]
-                         [else
-                          (record-case (car cls*)
-                            [(clambda-case fml* proper body)
-                             (let-values ([(body body-free) (Expr body)]
-                                          [(cls* cls*-free) (f (cdr cls*))])
-                               (values
-                                 (cons (make-clambda-case fml* proper body)
-                                       cls*)
-                                 (union (difference body-free fml*) 
-                                        cls*-free)))])]))])
-          (values (make-closure (make-clambda-code (gensym) cls* free) free)
-                  free))]))
-  (define (Expr ex)
-    (record-case ex
-      [(constant) (values ex '())]
-      [(var) (values ex (singleton ex))]
-      [(primref) (values ex '())]
-      [(bind lhs* rhs* body)
-       (let-values ([(rhs* rhs-free) (Expr* rhs*)] 
-                    [(body body-free) (Expr body)])
-          (values (make-bind lhs* rhs* body)
-                  (union rhs-free (difference body-free lhs*))))]
-      [(fix lhs* rhs* body)
-       (let-values ([(rhs* rfree) (do-clambda* rhs*)]
-                    [(body bfree) (Expr body)])
-          (values (make-fix lhs* rhs* body)
-                  (difference (union bfree rfree) lhs*)))]
-      [(conditional test conseq altern)
-       (let-values ([(test test-free) (Expr test)]
-                    [(conseq conseq-free) (Expr conseq)]
-                    [(altern altern-free) (Expr altern)])
-         (values (make-conditional test conseq altern)
-                 (union test-free (union conseq-free altern-free))))]
-      [(seq e0 e1) 
-       (let-values ([(e0 e0-free) (Expr e0)]
-                    [(e1 e1-free) (Expr e1)])
-         (values (make-seq e0 e1) (union e0-free e1-free)))]
-      [(clambda)
-       (do-clambda ex)]
-      [(primcall op rand*)
-       (let-values ([(rand* rand*-free) (Expr* rand*)])
-         (values (make-primcall op rand*)  rand*-free))]
-      [(forcall op rand*)
-       (let-values ([(rand* rand*-free) (Expr* rand*)])
-         (values (make-forcall op rand*)  rand*-free))]
-      [(funcall rator rand*)
-       (let-values ([(rator rat-free) (Expr rator)]
-                    [(rand* rand*-free) (Expr* rand*)])
-         (values (make-funcall rator rand*) 
-                 (union rat-free rand*-free)))]
-      [(appcall rator rand*)
-       (let-values ([(rator rat-free) (Expr rator)]
-                    [(rand* rand*-free) (Expr* rand*)])
-         (values (make-appcall rator rand*) 
-                 (union rat-free rand*-free)))]
-      [else (error who "invalid expression ~s" (unparse ex))]))
-  (let-values ([(prog free) (Expr prog)])
-    (unless (null? free) 
-      (error 'convert-closures "free vars ~s encountered in ~a"
-          free (unparse prog)))
-   prog))
-
-
-(define (lift-codes x)
-  (define who 'lift-codes)
-  (define all-codes '())
-  (define (do-code x)
-    (record-case x
-      [(clambda-code label cls* free) 
-       (let ([cls* (map 
-                     (lambda (x)
-                       (record-case x
-                         [(clambda-case fml* proper body)
-                          (make-clambda-case fml* proper (E body))]))
-                     cls*)])
-         (let ([g (make-code-loc label)])
-           (set! all-codes
-             (cons (make-clambda-code label cls* free) all-codes))
-           g))]))
-  (define (E x)
-    (record-case x
-      [(constant) x]
-      [(var)      x]
-      [(primref)  x]
-      [(bind lhs* rhs* body)
-       (make-bind lhs* (map E rhs*) (E body))]
-      [(fix lhs* rhs* body)
-       (make-fix lhs* (map E rhs*) (E body))]
-      [(conditional test conseq altern)
-       (make-conditional (E test) (E conseq) (E altern))]
-      [(seq e0 e1)           (make-seq (E e0) (E e1))]
-      [(closure c free)      (make-closure (do-code c) free)]
-      [(primcall op rand*)   (make-primcall op (map E rand*))]
-      [(forcall op rand*)    (make-forcall op (map E rand*))]
-      [(funcall rator rand*) (make-funcall (E rator) (map E rand*))]
-      [(appcall rator rand*) (make-appcall (E rator) (map E rand*))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (let ([x (E x)])
-    (make-codes all-codes x)))
-
-
-
-            
-(define (syntactically-valid? op rand*)
-  (define (valid-arg-count? op rand*)
-    (let ([n (open-coded-primitive-args op)] [m (length rand*)])
-      (cond
-        [(eq? n 'any) #t]
-        [(eq? n 'positive) (fx> m 1)]
-        [(eq? n 'no-code) 
-         (error 'syntactically-valid
-           "should not primcall non codable prim ~s" op)]
-        [(fixnum? n) 
-         (cond
-          [(fx= n m) #t]
-          [else
-           (error 'compile 
-             "Possible incorrect number of args in ~s"
-              (cons op (map unparse rand*)))
-           #f])]
-        [else (error 'do-primcall "BUG: what ~s" n)])))
-  (define (check op pred?)
-    (lambda (arg)
-      (record-case arg
-        [(constant c)
-         (cond
-           [(pred? c) #t]
-           [else
-            (error 'compile "Possible argument error to primitive ~s" op)
-            #f])]
-        [(primref) 
-         (cond
-           [(pred? (lambda (x) x)) #t]
-           [else
-            (error 'compile "Possible argument error to primitive ~s" op)
-            #f])]
-        [else #t])))
-  (define (nonnegative-fixnum? n)
-    (and (fixnum? n) (fx>= n 0)))
-  (define (byte? n)
-    (and (fixnum? n) (fx<= 0 n) (fx<= n 127)))
-  (define (valid-arg-types? op rand*)
-    (case op
-      [(fixnum? immediate? boolean? char? vector? string? procedure?
-        null? pair? not cons eq? vector symbol? error eof-object eof-object? 
-        void $unbound-object? $code? $forward-ptr? bwp-object?
-        pointer-value top-level-value car cdr list* list $record
-        port? input-port? output-port?
-        $make-port/input $make-port/output $make-port/both
-        $port-handler 
-        $port-input-buffer $port-input-index $port-input-size
-        $port-output-buffer $port-output-index $port-output-size 
-        $set-port-input-index! $set-port-input-size! 
-        $set-port-output-index! $set-port-output-size! ) 
-       '#t]
-      [($fxadd1 $fxsub1 $fxzero? $fxlognot $fxlogor $fxlogand $fx+ $fx- $fx* 
-        $fx= $fx< $fx<= $fx> $fx>= $fxquotient $fxmodulo $fxsll $fxsra $fxlogxor $exit) 
-       (andmap (check op fixnum?) rand*)]
-      [($fixnum->char) 
-       (andmap (check op byte?) rand*)]
-      [($char->fixnum $char= $char< $char<= $char> $char>= $string)
-       (andmap (check op char?) rand*)]
-      [($make-vector $make-string)
-       (andmap (check op nonnegative-fixnum?) rand*)]
-      [($car $cdr) 
-       (andmap (check op pair?) rand*)]
-      [($vector-length) 
-       (andmap (check op vector?) rand*)]
-      [($string-length) 
-       (andmap (check op string?) rand*)]
-      [($set-car! $set-cdr!)
-       ((check op pair?) (car rand*))]
-      [($vector-ref $vector-set!)
-       (and ((check op vector?) (car rand*))
-            ((check op nonnegative-fixnum?) (cadr rand*)))]
-      [($string-ref $string-set!
-        $string-ref-16+0 $string-ref-16+1 $string-ref-8+0 $string-ref-8+2)
-       (and ((check op string?) (car rand*))
-            ((check op nonnegative-fixnum?) (cadr rand*)))]
-      [($symbol-string $symbol-unique-string)
-       (andmap (check op symbol?) rand*)]
-      [($constant-ref $set-constant! $intern $pcb-set! $pcb-ref $make-symbol
-        $symbol-value $set-symbol-value! $symbol-plist $set-symbol-plist!
-        $set-symbol-system-value! $set-symbol-system-value!
-        $set-symbol-unique-string!
-        $set-symbol-string!
-        $seal-frame-and-call  $frame->continuation $code->closure
-        $code-size $code-reloc-vector $code-freevars 
-        $code-ref $code-set!
-        $make-record $record? $record/rtd? $record-rtd $record-ref $record-set!
-        primitive-set! primitive-ref
-        $make-tcbucket $tcbucket-key $tcbucket-val $tcbucket-next
-        $set-tcbucket-val! $set-tcbucket-next! $set-tcbucket-tconc!)
-       #t]
-      [else (error 'valid-arg-types? "unhandled op ~s" op)]))
-  (and (valid-arg-count? op rand*)
-       (or (null? rand*)
-           (valid-arg-types? op rand*))))
-
-
-;;; the output of simplify-operands differs from the input in that the 
-;;; operands to primcalls are all simple (variables, primrefs, or constants).
-;;; funcalls to open-codable primrefs whos arguments are "ok" are converted to
-;;; primcalls.  
-
-
-(define uninlined '())
-(define (mark-uninlined x)
-  (cond
-    [(assq x uninlined) =>
-     (lambda (p) (set-cdr! p (fxadd1 (cdr p))))]
-    [else (set! uninlined (cons (cons x 1) uninlined))]))
-
-(module ()
-  (primitive-set! 'uninlined-stats 
-    (lambda () 
-      (let f ([ls uninlined] [ac '()])
-        (cond
-          [(null? ls) ac]
-          [(fx> (cdar ls) 15)
-           (f (cdr ls) (cons (car ls) ac))]
-          [else (f (cdr ls) ac)])))))
-
-(define (introduce-primcalls x)
-  (define who 'introduce-primcalls)
-  (define (simple? x) 
-    (or (constant? x) (var? x) (primref? x)))
-  (define (Expr x)
-    (record-case x
-      [(constant) x]
-      [(var) x]
-      [(primref) x]
-      [(closure) x]
-      [(bind lhs* rhs* body)
-       (make-bind lhs* (map Expr rhs*) (Expr body))]
-      [(fix lhs* rhs* body)
-       (make-fix lhs* (map Expr rhs*) (Expr body))]
-      [(conditional test conseq altern)
-       (make-conditional (Expr test) (Expr conseq) (Expr altern))]
-      [(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
-      [(primcall op arg*)
-       (case op
-         ;[(values) 
-         ; (if (fx= (length arg*) 1)
-         ;     (Expr (car arg*))
-         ;     (begin
-         ;       (warning 'compile "possible incorrect number of values")
-         ;       (make-funcall (make-primref 'values) (map Expr arg*))))]
-         [else 
-          (make-primcall op (map Expr arg*))])]
-      [(forcall op arg*)
-       (make-forcall op (map Expr arg*))]
-      [(funcall rator rand*)
-       (cond
-         [(and (primref? rator) 
-               (open-codeable? (primref-name rator))
-               (syntactically-valid? (primref-name rator) rand*))
-          (Expr (make-primcall (primref-name rator) rand*))]
-         [else
-          (when (primref? rator)
-            (mark-uninlined (primref-name rator)))
-          (make-funcall (Expr rator) (map Expr rand*))])]
-      [(appcall op arg*)
-       (make-appcall (Expr op) (map Expr arg*))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (define (Tail x)
-    (record-case x
-      [(constant) (make-return x)]
-      [(var) (make-return x)]
-      [(primref) (make-return x)]
-      [(closure) (make-return x)]
-      [(bind lhs* rhs* body)
-       (make-bind lhs* (map Expr rhs*) (Tail body))]
-      [(fix lhs* rhs* body)
-       (make-fix lhs* (map Expr rhs*) (Tail body))]
-      [(conditional test conseq altern)
-       (make-conditional (Expr test) (Tail conseq) (Tail altern))]
-      [(seq e0 e1) (make-seq (Expr e0) (Tail e1))]
-      [(primcall op arg*)
-       (case op
-         ;[(values) 
-         ; (if (fx= (length arg*) 1)
-         ;     (make-return (Expr (car arg*)))
-         ;     (make-return* (map Expr arg*)))]
-         [else
-          (make-return (make-primcall op (map Expr arg*)))])]
-      [(forcall op arg*)
-       (make-return (make-forcall op (map Expr arg*)))]
-      [(funcall rator rand*)
-       (cond
-         [(and (primref? rator)
-               (open-codeable? (primref-name rator))
-               (syntactically-valid? (primref-name rator) rand*))
-          (Tail (make-primcall (primref-name rator) rand*))]
-         [else
-          (make-funcall (Expr rator) (map Expr rand*))])]
-      [(appcall op arg*)
-       (make-appcall (Expr op) (map Expr arg*))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (define (CaseExpr x)
-    (record-case x
-      [(clambda-case fml* proper body)
-       (make-clambda-case fml* proper (Tail body))]))
-  (define (CodeExpr x)
-    (record-case x
-      [(clambda-code L cases free) 
-       (make-clambda-code L (map CaseExpr cases) free)]))
-  (define (CodesExpr x)
-    (record-case x 
-      [(codes list body)
-       (make-codes (map CodeExpr list) (Tail body))]))
-  (CodesExpr x))
-
-
-(define (simplify-operands x)
-  (define who 'simplify-operands)
-  (define (simple? x) 
-    (or (constant? x) (var? x) (primref? x)))
-  (define (simplify arg lhs* rhs* k)
-    (if (simple? arg)
-        (k arg lhs* rhs*)
-        (let ([v (unique-var 'tmp)])
-          (k v (cons v lhs*) (cons (Expr arg) rhs*)))))
-  (define (simplify* arg* lhs* rhs* k)
-    (cond
-      [(null? arg*) (k '() lhs* rhs*)]
-      [else 
-       (simplify (car arg*) lhs* rhs*
-         (lambda (a lhs* rhs*)
-           (simplify* (cdr arg*) lhs* rhs*
-             (lambda (d lhs* rhs*)
-               (k (cons a d) lhs* rhs*)))))]))
-  (define (Expr x)
-    (record-case x
-      [(constant) x]
-      [(var) x]
-      [(primref) x]
-      [(closure) x]
-      [(bind lhs* rhs* body)
-       (make-bind lhs* (map Expr rhs*) (Expr body))]
-      [(fix lhs* rhs* body)
-       (make-fix lhs* (map Expr rhs*) (Expr body))]
-      [(conditional test conseq altern)
-       (make-conditional (Expr test) (Expr conseq) (Expr altern))]
-      [(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
-      [(primcall op arg*)
-       (cond
-         [(memq op '(not car cdr))
-          (make-primcall op (map Expr arg*))]
-         [else
-          (simplify* arg* '() '()
-            (lambda (arg* lhs* rhs*)
-              (make-bind^ lhs* rhs* 
-                (make-primcall op arg*))))])]
-      [(forcall op arg*)
-       (make-forcall op (map Expr arg*))]
-      [(funcall rator rand*)
-       (make-funcall (Expr rator) (map Expr rand*))]
-      [(appcall op arg*)
-       (make-appcall (Expr op) (map Expr arg*))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (define (Tail x)
-    (record-case x
-      [(return v) (make-return (Expr v))]
-      [(bind lhs* rhs* body)
-       (make-bind lhs* (map Expr rhs*) (Tail body))]
-      [(fix lhs* rhs* body)
-       (make-fix lhs* (map Expr rhs*) (Tail body))]
-      [(conditional test conseq altern)
-       (make-conditional (Expr test) (Tail conseq) (Tail altern))]
-      [(seq e0 e1) (make-seq (Expr e0) (Tail e1))]
-      [(funcall rator rand*)
-       (make-funcall (Expr rator) (map Expr rand*))]
-      [(appcall op arg*)
-       (make-appcall (Expr op) (map Expr arg*))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (define (CaseExpr x)
-    (record-case x 
-      [(clambda-case fml* proper body)
-       (make-clambda-case fml* proper (Tail body))]))
-  (define (CodeExpr x)
-    (record-case x
-      [(clambda-code L clauses free)
-       (make-clambda-code L (map CaseExpr clauses) free)]))
-  (define (CodesExpr x)
-    (record-case x 
-      [(codes list body)
-       (make-codes (map CodeExpr list) (Tail body))]))
-  (CodesExpr x))
-
-
-(define (insert-stack-overflow-checks x)
-  (define who 'insert-stack-overflow-checks)
-  (define (insert-check body)
-    (make-seq
-      (make-conditional 
-        (make-primcall '$fp-overflow '())
-        (make-funcall (make-primref 'do-stack-overflow) '())
-        (make-primcall 'void '()))
-      body))
-  (define (Expr x)
-    (record-case x
-      [(constant) #f]
-      [(var) #f]
-      [(primref) #f]
-      [(closure code free*) #f]
-      [(bind lhs* rhs* body)
-       (or (ormap Expr rhs*) (Expr body))]
-      [(fix lhs* rhs* body) (Expr body)]
-      [(conditional test conseq altern)
-       (or (Expr test) (Expr conseq) (Expr altern))]
-      [(seq e0 e1) (or (Expr e0) (Expr e1))]
-      [(primcall op arg*) (ormap Expr arg*)]
-      [(forcall op arg*)  (ormap Expr arg*)]
-      [(funcall rator arg*) #t] 
-      [(appcall rator arg*)    #t]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (define (Tail x)
-    (record-case x
-      [(return v) (Expr v)]
-      [(bind lhs* rhs* body)
-       (or (ormap Expr rhs*) (Tail body))]
-      [(fix lhs* rhs* body) (Tail body)]
-      [(conditional test conseq altern)
-       (or (Expr test) (Tail conseq) (Tail altern))]
-      [(seq e0 e1) (or (Expr e0) (Tail e1))]
-      [(funcall rator arg*) (or (Expr rator) (ormap Expr arg*))] 
-      [(appcall rator arg*) (or (Expr rator) (ormap Expr arg*))]
-      [else (error who "invalid tail expression ~s" (unparse x))]))
-  (define (CaseExpr x)
-    (record-case x 
-      [(clambda-case fml* proper body)
-       (if (Tail body)
-           (make-clambda-case fml* proper (insert-check body))
-           x)]))
-  (define (CodeExpr x)
-    (record-case x
-      [(clambda-code L cases free)
-       (make-clambda-code L (map CaseExpr cases) free)]))
-  (define (CodesExpr x)
-    (record-case x 
-      [(codes list body)
-       (make-codes (map CodeExpr list)
-                   (if (Tail body)
-                       (insert-check body)
-                       body))]))
-  (CodesExpr x))
-
-
-(define (insert-allocation-checks x)
-  (define who 'insert-allocation-checks)
-  (define (check-bytes n var body)
-    (make-seq
-      (make-conditional 
-        (make-primcall '$ap-check-bytes
-          (list (make-constant n) var))
-        (make-forcall "ik_collect" ;(make-primref 'do-overflow) 
-                      (list 
-                        (make-primcall '$fx+ 
-                          (list (make-constant (fx+ n 4096)) var))))
-        (make-primcall 'void '()))
-      body))
-  (define (check-words n var body)
-    (make-seq
-      (make-conditional 
-        (make-primcall '$ap-check-words
-          (list (make-constant n) var))
-        (make-forcall "ik_collect" ; (make-primref 'do-overflow-words)
-                      (list
-                        (make-primcall '$fx+ 
-                          (list (make-constant (fx+ n 4096)) var))))
-        (make-primcall 'void '()))
-      body))
-  (define (check-const n body)
-    (make-seq
-      (make-conditional 
-        (make-primcall '$ap-check-const
-          (list (make-constant n)))
-        (make-forcall "ik_collect" ;(make-primref 'do-overflow) 
-                      (list (make-constant (fx+ n 4096))))
-        (make-primcall 'void '()))
-      body))
-  (define (closure-size x)
-    (record-case x 
-      [(closure code free*)
-       (align (fx+ disp-closure-data (fx* (length free*) wordsize)))]
-      [else (error 'closure-size "~s is not a closure" x)]))
-  (define (sum ac ls)
-    (cond
-      [(null? ls) ac]
-      [else (sum (fx+ ac (car ls)) (cdr ls))]))
-  (define (Expr x)
-    (record-case x
-      [(constant) x]
-      [(var) x]
-      [(primref) x]
-      [(closure) 
-       (check-const (closure-size x) x)]
-      [(fix lhs* rhs* body)
-       (if (null? lhs*)
-           (Expr body)
-           (check-const (sum 0 (map closure-size rhs*))
-             (make-fix lhs* rhs* 
-               (Expr body))))]
-      [(bind lhs* rhs* body)
-       (make-bind lhs* (map Expr rhs*) (Expr body))]
-      [(conditional test conseq altern)
-       (make-conditional (Expr test) (Expr conseq) (Expr altern))]
-      [(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
-      [(primcall op arg*)
-       (let ([x (make-primcall op (map Expr arg*))])
-         (case op
-           [(cons) (check-const pair-size x)]
-           [($make-symbol) (check-const symbol-size x)]
-           [($make-tcbucket) (check-const tcbucket-size x)]
-           [($frame->continuation $code->closure) 
-            (check-const (fx+ disp-closure-data (fx* (length arg*) wordsize)) x)]
-           [($make-string) 
-            (record-case (car arg*)
-              [(constant i)
-               (check-const (fx+ i (fx+ disp-string-data 1)) x)]
-              [else
-               (check-bytes (fxadd1 disp-string-data) (car arg*) x)])]
-           [($string)
-            (check-const (fx+ (length arg*) (fx+ disp-string-data 1)) x)]
-           [($make-port/input $make-port/output $make-port/both)
-            (check-const port-size x)]
-           [($make-vector) 
-            (record-case (car arg*)
-              [(constant i)
-               (check-const (fx+ (fx* i wordsize) disp-vector-data) x)]
-              [else
-               (check-words (fxadd1 disp-vector-data) (car arg*) x)])]
-           [($make-record) 
-            (record-case (cadr arg*)
-              [(constant i)
-               (check-const (fx+ (fx* i wordsize) disp-record-data) x)]
-              [else
-               (check-words (fxadd1 disp-record-data) (cadr arg*) x)])]
-           [(list*)
-            (check-const (fx* (fxsub1 (length arg*)) pair-size) x)]
-           [(list)
-            (check-const (fx* (length arg*) pair-size) x)]
-           [(vector $record)
-            (check-const (fx+ (fx* (length arg*) wordsize) disp-vector-data) x)]
-           [else x]))]
-      [(forcall op arg*)
-       (make-forcall op (map Expr arg*))]
-      [(funcall rator rand*)
-       (make-funcall (Expr rator) (map Expr rand*))]
-      [(appcall op arg*)
-       (make-appcall (Expr op) (map Expr arg*))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (define (Tail x)
-    (record-case x
-      [(return v) (make-return (Expr v))]
-      [(bind lhs* rhs* body)
-       (make-bind lhs* (map Expr rhs*) (Tail body))]
-      [(fix lhs* rhs* body)
-       (if (null? lhs*)
-           (Tail body)
-           (check-const (sum 0 (map closure-size rhs*))
-             (make-fix lhs* rhs* 
-               (Tail body))))]
-      [(conditional test conseq altern)
-       (make-conditional (Expr test) (Tail conseq) (Tail altern))]
-      [(seq e0 e1) (make-seq (Expr e0) (Tail e1))]
-      [(funcall rator rand*)
-       (make-funcall (Expr rator) (map Expr rand*))]
-      [(appcall op arg*)
-       (make-appcall (Expr op) (map Expr arg*))]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (define (CaseExpr x)
-    (record-case x 
-      [(clambda-case fml* proper body)
-       (make-clambda-case fml* proper (Tail body))]))
-  (define (CodeExpr x)
-    (record-case x
-      [(clambda-code L cases free)
-       (make-clambda-code L (map CaseExpr cases) free)]))
-  (define (CodesExpr x)
-    (record-case x 
-      [(codes list body)
-       (make-codes (map CodeExpr list) (Tail body))]))
-  (CodesExpr x))
-
-
-              
-(define (remove-local-variables x)
-  (define who 'remove-local-variables)
-  (define (simple* x* r)
-    (map (lambda (x) 
-           (cond
-             [(assq x r) => cdr]
-             [else
-               (when (var? x) (error who "unbound var ~s" x))
-               x]))
-          x*))
-  (define (env->mask r sz)
-    (let ([s (make-vector (fxsra (fx+ sz 7) 3) 0)])
-      (for-each 
-        (lambda (idx) 
-           (let ([q (fxsra idx 3)]
-                 [r (fxlogand idx 7)])
-             (vector-set! s q 
-               (fxlogor (vector-ref s q) (fxsll 1 r)))))
-        r)
-      s))
-  (define (check? x)
-    (cond
-      [(primref? x) #f]  ;;;; PRIMREF CHECK
-      [else         #t]))
-  (define (do-new-frame op rand* si r call-convention rp-convention orig-live)
-    (make-new-frame (fxadd1 si) (fx+ (length rand*) 2)
-      (let f ([r* rand*] [nsi (fx+ si 2)] [live orig-live])
-        (cond
-          [(null? r*) 
-           (make-seq
-             (make-seq 
-               (make-save-cp (make-frame-var si))
-               (case call-convention
-                 [(normal apply)
-                  (make-eval-cp (check? op) (Expr op nsi r (cons si live)))]
-                 [(foreign)
-                  (make-eval-cp #f (make-foreign-label op))]
-                 [else (error who "invalid convention ~s" call-convention)]))
-             (make-call-cp call-convention 
-                rp-convention
-                (fxadd1 si)    ; frame size
-                (length rand*) ; argc
-                (env->mask (cons si orig-live) ; cp and everything before it
-                           (fxadd1 si))))] ; mask-size ~~ frame size
-          [else
-           (make-seq 
-             (make-assign (make-frame-var nsi)
-               (Expr (car r*) nsi r live))
-             (f (cdr r*) (fxadd1 nsi) (cons nsi live)))]))))
-  (define (nop) (make-primcall 'void '()))
-  (define (do-bind lhs* rhs* body si r live k)
-    (let f ([lhs* lhs*] [rhs* rhs*] [si si] [nr r] [live live])
-      (cond
-        [(null? lhs*) (k body si nr live)]
-        [else
-         (let ([v (make-frame-var si)])
-           (make-seq
-             (make-assign v (Expr (car rhs*) si r live))
-             (f (cdr lhs*) (cdr rhs*) (fxadd1 si)
-                (cons (cons (car lhs*) v) nr)
-                (cons si live))))])))
-  (define (do-closure r)
-    (lambda (x)
-      (record-case x
-        [(closure code free*)
-         (make-closure code (simple* free* r))])))
-  (define (do-fix lhs* rhs* body si r live k)
-    (let f ([l* lhs*] [nlhs* '()] [si si] [r r] [live live])
-      (cond
-        [(null? l*) 
-         (make-fix (reverse nlhs*) 
-                   (map (do-closure r) rhs*)
-                   (k body si r live))]
-        [else
-         (let ([v (make-frame-var si)])
-           (f (cdr l*) (cons v nlhs*) (fxadd1 si) 
-              (cons (cons (car l*) v) r)
-              (cons si live)))])))
-  (define (do-tail-frame-old op rand* si r call-conv live)
-    (define (const? x)
-      (record-case x
-        [(constant) #t]
-        [(primref)  #t]
-        [else       #f]))
-    (define (evalrand* rand* i si r live)
-      (cond
-        [(null? rand*) 
-         (make-eval-cp (check? op) (Expr op si r live))]
-        [(const? (car rand*))
-         (evalrand* (cdr rand*) (fxadd1 i) (fxadd1 si) r live)]
-        [else
-         (let ([v (make-frame-var si)]
-               [rhs (Expr (car rand*) si r live)])
-           (cond
-             [(and (frame-var? rhs)
-                   (fx= (frame-var-idx rhs) i))
-              (evalrand* (cdr rand*) (fx+ i 1) (fx+ si 1) r (cons si live))]
-             [else
-              (make-seq
-                (make-assign v rhs)
-                (evalrand* (cdr rand*) (fx+ 1 i) (fx+ 1 si) r
-                           (cons si live)))]))]))
-    (define (moverand* rand* i si ac)
-      (cond
-        [(null? rand*) ac]
-        [(const? (car rand*))
-         (make-seq
-           (make-assign (make-frame-var i) (car rand*))
-           (moverand* (cdr rand*) (fxadd1 i) (fxadd1 si) ac))]
-        [else
-         (make-seq
-           (make-assign (make-frame-var i) (make-frame-var si))
-           (moverand* (cdr rand*) (fxadd1 i) (fxadd1 si) ac))]))
-    (make-seq
-      (evalrand* rand* 1 si r live)
-      (moverand* rand* 1 si
-        (make-tailcall-cp call-conv (length rand*))))) 
-  (define (do-tail-frame op rand* si r call-conv live)
-    (define (const? x)
-      (record-case x
-        [(constant) #t]
-        [(primref)  #t]
-        [else       #f]))
-    (define (evalrand* rand* i si r live ac)
-      (cond
-        [(null? rand*) 
-         (make-seq
-           (make-eval-cp (check? op) (Expr op si r live))
-           ac)]
-        [(const? (car rand*))
-         (evalrand* (cdr rand*) (fxadd1 i) (fxadd1 si) r live
-           (make-seq ac
-             (make-assign (make-frame-var i) (car rand*))))]
-        [else
-         (let ([vsi (make-frame-var si)]
-               [rhs (Expr (car rand*) si r live)])
-           (cond
-             [(and (frame-var? rhs)
-                   (fx= (frame-var-idx rhs) i))
-              (evalrand* (cdr rand*) (fx+ i 1) (fx+ si 1) r (cons si live) ac)]
-             [(fx= i si)
-              (make-seq 
-                (make-assign vsi rhs)
-                (evalrand* (cdr rand*) (fx+ i 1) (fx+ si 1) r
-                           (cons si live) ac))]
-             [else
-              (make-seq
-                (make-assign vsi rhs)
-                (evalrand* (cdr rand*) (fxadd1 i) (fxadd1 si) r (cons si live)
-                  (make-seq ac
-                    (make-assign (make-frame-var i) vsi))))]))]))
-    (make-seq
-      (evalrand* rand* 1 si r live (make-primcall 'void '()))
-      (make-tailcall-cp call-conv (length rand*))))
-  (define (Tail x si r live)
-    (record-case x
-      [(return v) (make-return (Expr v si r live))]
-      [(bind lhs* rhs* body)
-       (do-bind lhs* rhs* body si r live Tail)]
-      [(fix lhs* rhs* body)
-       (do-fix lhs* rhs* body si r live Tail)]
-      [(conditional test conseq altern)
-       (make-conditional 
-         (Expr test si r live)
-         (Tail conseq si r live) 
-         (Tail altern si r live))]
-      [(seq e0 e1) (make-seq (Effect e0 si r live) (Tail e1 si r live))]
-      [(primcall op arg*)
-       (make-return 
-         (make-primcall op 
-           (map (lambda (x) (Expr x si r live)) arg*)))]
-                                  
-      [(funcall op rand*)
-       (do-tail-frame op rand* si r 'normal live)]
-      [(appcall op rand*)
-       (do-tail-frame op rand* si r 'apply live)]
-;;;      [(funcall op rand*)
-;;;       (do-new-frame op rand* si r 'normal 'tail live)]
-;;;      [(appcall op rand*)
-;;;       (do-new-frame op rand* si r 'apply 'tail live)]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (define (Effect x si r live)
-    (record-case x
-      [(constant) (nop)]
-      [(var) (nop)] 
-      [(primref) (nop)]
-      [(closure code free*) (nop)]
-      [(bind lhs* rhs* body)
-       (do-bind lhs* rhs* body si r live Effect)]
-      [(fix lhs* rhs* body)
-       (do-fix lhs* rhs* body si r live Effect)]
-      [(conditional test conseq altern)
-       (make-conditional 
-         (Expr test si r live)
-         (Effect conseq si r live) 
-         (Effect altern si r live))]
-      [(seq e0 e1) (make-seq (Effect e0 si r live) (Effect e1 si r live))]
-      [(primcall op arg*)
-       (make-primcall op 
-         (map (lambda (x) (Expr x si r live)) arg*))]
-      [(forcall op rand*)
-       (do-new-frame op rand* si r 'foreign 'effect live)]
-      [(funcall op rand*)
-       (do-new-frame op rand* si r 'normal 'effect live)]
-      [(appcall op rand*)
-       (do-new-frame op rand* si r 'apply 'effect live)]
-      [else (error who "invalid effect expression ~s" (unparse x))]))
-  (define (Expr x si r live)
-    (record-case x
-      [(constant) x]
-      [(var) 
-       (cond
-         [(assq x r) => cdr]
-         [else (error who "unbound var ~s" x)])]
-      [(primref) x]
-      [(closure code free*) 
-       (make-closure code (simple* free* r))]
-      [(bind lhs* rhs* body)
-       (do-bind lhs* rhs* body si r live Expr)]
-      [(fix lhs* rhs* body)
-       (do-fix lhs* rhs* body si r live Expr)]
-      [(conditional test conseq altern)
-       (make-conditional 
-         (Expr test si r live)
-         (Expr conseq si r live) 
-         (Expr altern si r live))]
-      [(seq e0 e1) (make-seq (Effect e0 si r live) (Expr e1 si r live))]
-      [(primcall op arg*)
-       (make-primcall op 
-         (map (lambda (x) (Expr x si r live)) arg*))]
-      [(forcall op rand*)
-       (do-new-frame op rand* si r 'foreign 'value live)]
-      [(funcall op rand*)
-       (do-new-frame op rand* si r 'normal 'value live)]
-      [(appcall op rand*)
-       (do-new-frame op rand* si r 'apply 'value live)]
-      [else (error who "invalid expression ~s" (unparse x))]))
-  (define (bind-fml* fml* r)
-    (let f ([si 1] [fml* fml*])
-      (cond
-        [(null? fml*) (values '() si r '())]
-        [else
-          (let-values ([(nfml* nsi r live) (f (fxadd1 si) (cdr fml*))])
-            (let ([v (make-frame-var si)])
-              (values (cons v nfml*)
-                      nsi
-                      (cons (cons (car fml*) v) r)
-                      (cons si live))))])))
-  (define (bind-free* free*)
-    (let f ([free* free*] [idx 0] [r '()])
-      (cond
-        [(null? free*) r]
-        [else
-          (f (cdr free*) (fxadd1 idx)
-             (cons (cons (car free*) (make-cp-var idx)) r))])))
-  (define CaseExpr 
-    (lambda (r)
-      (lambda (x)
-        (record-case x 
-          [(clambda-case fml* proper body)
-           (let-values ([(fml* si r live) (bind-fml* fml* r)])
-             (make-clambda-case fml* proper (Tail body si r live)))]))))
-  (define (CodeExpr x)
-    (record-case x
-      [(clambda-code L cases free)
-       (let ([r (bind-free* free)])
-         (make-clambda-code L (map (CaseExpr r) cases) free))]))
-  (define (CodesExpr x)
-    (record-case x 
-      [(codes list body)
-       (make-codes (map CodeExpr list) 
-                   (Tail body 1 '() '()))]))
-  (CodesExpr x))
-
-
-
-(define checks-elim-count 0)
-(define (optimize-ap-check x)
-  (define who 'optimize-ap-check)
-  (define (min x y)
-    (if (fx< x y) x y))
-  (define (Tail x f)
-    (record-case x
-      [(return v)
-       (let-values ([(v f) (NonTail v f)])
-         (make-return v))]
-      [(fix lhs* rhs* body)
-       (make-fix lhs* rhs* (Tail body f))]
-      [(conditional test conseq altern)
-       (let-values ([(test f) (NonTail test f)])
-         (make-conditional 
-           test
-           (Tail conseq f)
-           (Tail altern f)))]
-      [(seq e0 e1) 
-       (let-values ([(e0 f) (NonTail e0 f)])
-         (make-seq e0 (Tail e1 f)))]
-      [(tailcall-cp) x]
-      [else (error who "invalid tail expression ~s" (unparse x))]))
-  (define (do-primcall op arg* f)
-    (case op
-      [($ap-check-const)
-       (let ([n (constant-value (car arg*))])
-         (cond
-           [(fx< n f) 
-            ;(set! checks-elim-count (fxadd1 checks-elim-count))
-            ;(printf "~s checks eliminated\n" checks-elim-count)
-            (values (make-constant #f) (fx- f n))]
-           [(fx<= n 4096)
-            (values (make-primcall '$ap-check-const 
-                                   (list (make-constant 4096)))
-                    (fx- 4096 n))]
-           [else
-            (values (make-primcall '$ap-check-const 
-                                   (list (make-constant (fx+ n 4096))))
-                    4096)]))]
-      [($ap-check-bytes $ap-check-words)
-       (values (make-primcall op 
-                 (list (make-constant (fx+ (constant-value (car arg*)) 
-                                           4096))
-                       (cadr arg*)))
-               4096)]
-      [else (values (make-primcall op arg*) f)]))
-  (define (NonTail x f)
-    (record-case x
-      [(constant)         (values x f)]
-      [(frame-var)        (values x f)]
-      [(cp-var)           (values x f)]
-      [(save-cp)          (values x f)]
-      [(foreign-label)    (values x f)]
-      [(primref)          (values x f)]
-      [(closure)          (values x f)]
-      [(call-cp call-conv) 
-       (if (eq? call-conv 'foreign)
-           (values x f)
-           (values x 0))]
-      [(primcall op arg*) (do-primcall op arg* f)]
-      [(fix lhs* rhs* body)
-       (let-values ([(body f) (NonTail body f)])
-         (values (make-fix lhs* rhs* body) f))]
-      [(conditional test conseq altern)
-       (let-values ([(test f) (NonTail test f)])
-         (if (constant? test)
-             (if (constant-value test)
-                 (NonTail conseq f)
-                 (NonTail altern f))
-             (let-values ([(conseq f0) (NonTail conseq f)]
-                          [(altern f1) (NonTail altern f)])
-               (values (make-conditional test conseq altern)
-                       (min f0 f1)))))]
-      [(seq e0 e1) 
-       (let-values ([(e0 f) (NonTail e0 f)])
-         (let-values ([(e1 f) (NonTail e1 f)])
-           (values (make-seq e0 e1) f)))]
-      [(assign lhs rhs)
-       (let-values ([(rhs f) (NonTail rhs f)])
-         (values (make-assign lhs rhs) f))]
-      [(eval-cp check body)
-       (let-values ([(body f) (NonTail body f)])
-         (values (make-eval-cp check body) f))]
-      [(new-frame base-idx size body)
-       (let-values ([(body f) (NonTail body f)])
-         (values (make-new-frame base-idx size body) f))]
-      [else (error who "invalid nontail expression ~s" (unparse x))]))
-  (define CaseExpr 
-    (lambda (x)
-      (record-case x 
-        [(clambda-case fml* proper body)
-         (make-clambda-case fml* proper (Tail body 0))])))
-  (define (CodeExpr x)
-    (record-case x
-      [(clambda-code L cases free)
-       (make-clambda-code L (map CaseExpr cases) free)]))
-  (define (CodesExpr x)
-    (record-case x 
-      [(codes list body)
-       (make-codes (map CodeExpr list) 
-                   (Tail body 0))]))
-  (CodesExpr x))
-
-(begin
-  (define fx-shift 2)
-  (define fx-mask #x03)
-  (define fx-tag 0)
-  (define bool-f #x2F)
-  (define bool-t #x3F)
-  (define bool-mask #xEF)
-  (define bool-tag #x2F)
-  (define bool-shift 4)
-  (define nil     #x4F)
-  (define eof     #x5F) ; double check
-  (define unbound #x6F) ; double check
-  (define void-object #x7F) ; double check
-  (define bwp-object  #x8F) ; double check
-  (define char-shift 8)
-  (define char-tag #x0F)
-  (define char-mask #xFF)
-  (define pair-mask 7)
-  (define pair-tag  1)
-  (define disp-car  0)
-  (define disp-cdr  4)
-  (define pair-size 8)
-  (define pagesize 4096)
-  (define pageshift 12)
-  (define wordsize  4)
-  (define wordshift 2)
-  
-  (define symbol-mask 7)
-  (define symbol-tag 2)
-  (define disp-symbol-string         0)
-  (define disp-symbol-unique-string  4)
-  (define disp-symbol-value          8)
-  (define disp-symbol-plist         12)
-  (define disp-symbol-system-value  16)
-  (define disp-symbol-system-plist  20)
-  (define symbol-size 24)
-  (define vector-tag 5)
-  (define vector-mask 7)
-  (define disp-vector-length 0)
-  (define disp-vector-data 4)
-  (define string-mask 7)
-  (define string-tag 6)
-  (define disp-string-length 0)
-  (define disp-string-data 4)
-  (define closure-mask 7)
-  (define closure-tag 3)
-  (define disp-closure-data 4)
-  (define disp-closure-code 0)
-  (define continuation-size       16)
-  (define continuation-tag      #x1F)
-  (define disp-continuation-top    4)
-  (define disp-continuation-size   8)
-  (define disp-continuation-next  12)
-  (define code-tag              #x2F)
-  (define disp-code-instrsize      4)
-  (define disp-code-relocsize      8)
-  (define disp-code-freevars      12)
-  (define disp-code-data          16)
-  (define port-tag              #x3F)
-  (define input-port-tag        #x7F)
-  (define output-port-tag       #xBF)
-  (define input/output-port-tag #xFF)
-  (define port-mask             #x3F)
-  (define disp-port-handler        4)
-  (define disp-port-input-buffer   8)
-  (define disp-port-input-index   12)
-  (define disp-port-input-size    16)
-  (define disp-port-output-buffer 20)
-  (define disp-port-output-index  24)
-  (define disp-port-output-size   28)
-  (define port-size               32)
-  (define disp-tcbucket-tconc 0)
-  (define disp-tcbucket-key   4)
-  (define disp-tcbucket-val   8)
-  (define disp-tcbucket-next 12)
-  (define tcbucket-size      24)
-  (define record-ptag  5)
-  (define record-pmask 7)
-  (define disp-record-rtd     0)
-  (define disp-record-data    4)
-  (define disp-frame-size -17)
-  (define disp-frame-offset -13)
-  (define disp-multivalue-rp -9)
-  (define object-alignment 8)
-  (define align-shift 3)
-  (define dirty-word -1))
-
-(define (align n)
-  (fxsll (fxsra (fx+ n (fxsub1 object-alignment)) align-shift) align-shift))
-
-(begin
-  (define (mem off val)
-    (cond
-      [(fixnum? off) (list 'disp (int off) val)]
-      [(register? off) (list 'disp off val)]
-      [else (error 'mem "invalid disp ~s" off)]))
-  (define (int x) (list 'int x))
-  (define (obj x) (list 'obj x))
-  (define (byte x) (list 'byte x))
-  (define (byte-vector x) (list 'byte-vector x))
-  (define (movzbl src targ) (list 'movzbl src targ))
-  (define (sall src targ) (list 'sall src targ))
-  (define (sarl src targ) (list 'sarl src targ))
-  (define (shrl src targ) (list 'shrl src targ))
-  (define (notl src) (list 'notl src))
-  (define (pushl src) (list 'pushl src))
-  (define (popl src) (list 'popl src))
-  (define (orl src targ) (list 'orl src targ))
-  (define (xorl src targ) (list 'xorl src targ))
-  (define (andl src targ) (list 'andl src targ))
-  (define (movl src targ) (list 'movl src targ))
-  (define (movb src targ) (list 'movb src targ))
-  (define (addl src targ) (list 'addl src targ))
-  (define (imull src targ) (list 'imull src targ))
-  (define (idivl src) (list 'idivl src))
-  (define (subl src targ) (list 'subl src targ))
-  (define (push src) (list 'push src))
-  (define (pop targ) (list 'pop targ))
-  (define (sete targ) (list 'sete targ))
-  (define (call targ) (list 'call targ))
-  (define (tail-indirect-cpr-call)
-    (jmp (mem (fx- disp-closure-code closure-tag) cpr)))
-  (define (indirect-cpr-call)
-    (call (mem (fx- disp-closure-code closure-tag) cpr)))
-  (define (negl targ) (list 'negl targ))
-  (define (label x) (list 'label x))
-  (define (label-address x) (list 'label-address x))
-  (define (ret) '(ret))
-  (define (cltd) '(cltd))
-  (define (cmpl arg1 arg2) (list 'cmpl arg1 arg2))
-  (define (je label) (list 'je label))
-  (define (jne label) (list 'jne label))
-  (define (jle label) (list 'jle label))
-  (define (jge label) (list 'jge label))
-  (define (jg label) (list 'jg label))
-  (define (jl label) (list 'jl label))
-  (define (jb label) (list 'jb label))
-  (define (ja label) (list 'ja label))
-  (define (jmp label) (list 'jmp label))
-  (define edi '%edx) ; closure pointer
-  (define esi '%esi) ; pcb
-  (define ebp '%ebp) ; allocation pointer
-  (define esp '%esp) ; stack base pointer 
-  (define al '%al)
-  (define ah '%ah)
-  (define bh '%bh)
-  (define cl '%cl)
-  (define eax '%eax)
-  (define ebx '%ebx)
-  (define ecx '%ecx)
-  (define edx '%edx)
-  (define apr '%ebp)
-  (define fpr '%esp)
-  (define cpr '%edi)
-  (define pcr '%esi)
-  (define register? symbol?)
-  (define (argc-convention n)
-    (fx- 0 (fxsll n fx-shift))))
-
-
-(define pcb-ref
-  (lambda (x)
-    (case x
-      [(allocation-pointer) (mem  0 pcr)]
-      [(allocation-redline) (mem  4 pcr)]
-      [(frame-pointer)      (mem  8 pcr)]
-      [(frame-base)         (mem 12 pcr)]
-      [(frame-redline)      (mem 16 pcr)]
-      [(next-continuation)  (mem 20 pcr)]
-      [(system-stack)       (mem 24 pcr)]
-      [(dirty-vector)       (mem 28 pcr)]
-      [else (error 'pcb-ref "invalid arg ~s" x)])))
-
-(define (primref-loc op)
-  (unless (symbol? op) (error 'primref-loc "not a symbol ~s" op))
-  (mem (fx- disp-symbol-system-value symbol-tag)
-        (obj op)))
-
-
-(define (generate-code x)
-  (define who 'generate-code)
-  (define (rp-label x)
-    (case x
-      [(value) (label-address SL_multiple_values_error_rp)]
-      [(effect) (label-address SL_multiple_values_ignore_rp)]
-      [else (error who "invalid rp-convention ~s" x)]))
-  (define unique-label
-    (lambda ()
-      (label (gensym))))
-  (define (constant-val x)
-    (cond
-      [(fixnum? x) (obj x)]
-      [(boolean? x) (int (if x bool-t bool-f))]
-      [(null? x) (int nil)]
-      [(char? x) (int (fx+ (fxsll (char->integer x) char-shift) char-tag))]
-      [(eq? x (void)) (int void-object)]
-      [else (obj x)]))
-  (define (cond-branch op Lt Lf ac)
-    (define (opposite x)
-      (cadr (assq x '([je jne] [jl jge] [jle jg] [jg jle] [jge jl]))))
-    (unless (or Lt Lf)
-      (error 'cond-branch "no labels"))
-    (cond
-      [(not Lf) (cons (list op Lt) ac)]
-      [(not Lt) (cons (list (opposite op) Lf) ac)] 
-      [else (list* (list op Lt) (jmp Lf) ac)]))
-  (define (indirect-type-pred pri-mask pri-tag sec-mask sec-tag rand* Lt Lf ac)
-    (cond
-      [(and Lt Lf)
-       (list* (movl (Simple (car rand*)) eax)
-              (movl eax ebx)
-              (andl (int pri-mask) ebx)
-              (cmpl (int pri-tag) ebx)
-              (jne Lf)
-              (movl (mem (fx- 0 pri-tag) eax) ebx)
-              (if sec-mask
-                  (andl (int sec-mask) ebx)
-                  '(nop))
-              (cmpl (int sec-tag) ebx)
-              (jne Lf)
-              (jmp Lt)
-              ac)]
-      [Lf
-       (list* (movl (Simple (car rand*)) eax)
-              (movl eax ebx)
-              (andl (int pri-mask) ebx)
-              (cmpl (int pri-tag) ebx)
-              (jne Lf)
-              (movl (mem (fx- 0 pri-tag) eax) ebx)
-              (if sec-mask
-                  (andl (int sec-mask) ebx)
-                  '(nop))
-              (cmpl (int sec-tag) ebx)
-              (jne Lf)
-              ac)]
-      [Lt
-       (let ([L_END (unique-label)])
-         (list* (movl (Simple (car rand*)) eax)
-                (movl eax ebx)
-                (andl (int pri-mask) ebx)
-                (cmpl (int pri-tag) ebx)
-                (jne L_END)
-                (movl (mem (fx- 0 pri-tag) eax) ebx)
-                (if sec-mask
-                    (andl (int sec-mask) ebx)
-                    '(nop))
-                (cmpl (int sec-tag) ebx)
-                (je Lt)
-                L_END
-                ac))]
-      [else ac]))
-  (define (type-pred mask tag rand* Lt Lf ac)
-    (cond
-      [mask
-       (list* 
-         (movl (Simple (car rand*)) eax)
-         (andl (int mask) eax)
-         (cmpl (int tag) eax)
-         (cond-branch 'je Lt Lf ac))]
-      [else 
-       (let ([v (Simple (car rand*))])
-         (cond
-           [(memq (car v) '(mem register)) 
-            (list*
-              (cmpl (int tag) (Simple (car rand*)))
-              (cond-branch 'je Lt Lf ac))]
-           [else
-            (list*
-              (movl (Simple (car rand*)) eax)
-              (cmpl (int tag) eax)
-              (cond-branch 'je Lt Lf ac))]))])) 
-  (define (compare-and-branch op rand* Lt Lf ac)
-    (define (opposite x)
-      (cadr (assq x '([je je] [jl jg] [jle jge] [jg jl] [jge jle]))))
-    (cond
-      [(and (constant? (car rand*)) (constant? (cadr rand*)))
-       (list* 
-         (movl (Simple (car rand*)) eax)
-         (cmpl (Simple (cadr rand*)) eax)
-         (cond-branch op Lt Lf ac))]
-      [(constant? (cadr rand*))
-       (list* 
-         (cmpl (Simple (cadr rand*)) (Simple (car rand*)))
-         (cond-branch op Lt Lf ac))]
-      [(constant? (car rand*))
-       (list*
-         (cmpl (Simple (car rand*)) (Simple (cadr rand*)))
-         (cond-branch (opposite op) Lt Lf ac))]
-      [else
-       (list* 
-         (movl (Simple (car rand*)) eax)
-         (cmpl (Simple (cadr rand*)) eax)
-         (cond-branch op Lt Lf ac))]))
-  (define (do-pred-prim op rand* Lt Lf ac)
-    (case op
-     [(fixnum?)    (type-pred fx-mask fx-tag rand* Lt Lf ac)]
-     [(pair?)      (type-pred pair-mask pair-tag rand* Lt Lf ac)]
-     [(char?)      (type-pred char-mask char-tag rand* Lt Lf ac)]
-     [(string?)    (type-pred string-mask string-tag rand* Lt Lf ac)]
-     [(symbol?)    (type-pred symbol-mask symbol-tag rand* Lt Lf ac)]
-     [(procedure?) (type-pred closure-mask closure-tag rand* Lt Lf ac)]
-     [(boolean?)   (type-pred bool-mask bool-tag rand* Lt Lf ac)]
-     [(null?)      (type-pred #f nil rand* Lt Lf ac)]
-     [($unbound-object?) (type-pred #f unbound rand* Lt Lf ac)]
-     [($forward-ptr?) (type-pred #f -1 rand* Lt Lf ac)]
-     [(not)        (Pred (car rand*) Lf Lt ac)]
-     ;[(not)        (type-pred #f bool-f rand* Lt Lf ac)]
-     [(eof-object?) (type-pred #f eof rand* Lt Lf ac)]
-     [(bwp-object?) (type-pred #f bwp-object rand* Lt Lf ac)]
-     [($code?) 
-      (indirect-type-pred vector-mask vector-tag #f code-tag 
-         rand* Lt Lf ac)]
-     [($fxzero?)   (type-pred #f 0 rand* Lt Lf ac)]
-     [($fx= $char= eq?) (compare-and-branch 'je rand* Lt Lf ac)]
-     [($fx< $char<)     (compare-and-branch 'jl rand* Lt Lf ac)]
-     [($fx<= $char<=)   (compare-and-branch 'jle rand* Lt Lf ac)]
-     [($fx> $char>)     (compare-and-branch 'jg rand* Lt Lf ac)]
-     [($fx>= $char>=)   (compare-and-branch 'jge rand* Lt Lf ac)]
-     [(vector?) 
-      (indirect-type-pred vector-mask vector-tag fx-mask fx-tag 
-         rand* Lt Lf ac)]
-     [($record?) 
-      (indirect-type-pred record-pmask record-ptag record-pmask record-ptag
-         rand* Lt Lf ac)]
-     [(output-port?)
-      (indirect-type-pred 
-        vector-mask vector-tag #f output-port-tag rand* Lt Lf ac)] 
-     [(input-port?)
-      (indirect-type-pred 
-        vector-mask vector-tag #f input-port-tag rand* Lt Lf ac)] 
-     [(port?)
-      (indirect-type-pred 
-        vector-mask vector-tag port-mask port-tag rand* Lt Lf ac)] 
-     [($record/rtd?)
-      (cond
-        [Lf
-         (list* (movl (Simple (car rand*)) eax)
-                (movl eax ebx)
-                (andl (int vector-mask) eax)
-                (cmpl (int vector-tag) eax)
-                (jne Lf)
-                (movl (Simple (cadr rand*)) eax)
-                (cmpl (mem (fx- disp-record-rtd vector-tag) ebx) eax)
-                (jne Lf)
-                (if Lt
-                    (cons (jmp Lt) ac)
-                    ac))]
-        [Lt
-         (let ([Ljoin (unique-label)])
-           (list* (movl (Simple (car rand*)) eax)
-                  (movl eax ebx)
-                  (andl (int vector-mask) eax)
-                  (cmpl (int vector-tag) eax)
-                  (jne Ljoin)
-                  (movl (Simple (cadr rand*)) eax)
-                  (cmpl (mem (fx- disp-record-rtd vector-tag) ebx) eax)
-                  (je Lt)
-                  Ljoin
-                  ac))]
-        [else ac])]
-     [(immediate?)
-      (cond
-        [(and Lt Lf)
-         (list* (movl (Simple (car rand*)) eax)
-             (movl eax ebx)
-             (andl (int fx-mask) ebx)
-             (cmpl (int 0) ebx)
-             (je Lt)
-             (andl (int 7) eax)
-             (cmpl (int 7) eax)
-             (je Lt)
-             (jmp Lf)
-             ac)]
-        [Lt
-         (list* (movl (Simple (car rand*)) eax)
-             (movl eax ebx)
-             (andl (int fx-mask) ebx)
-             (cmpl (int 0) ebx)
-             (je Lt)
-             (andl (int 7) eax)
-             (cmpl (int 7) eax)
-             (je Lt)
-             ac)]
-        [Lf
-         (let ([Ljoin (unique-label)])
-           (list* 
-             (movl (Simple (car rand*)) eax)
-             (movl eax ebx)
-             (andl (int fx-mask) ebx)
-             (cmpl (int 0) ebx)
-             (je Ljoin)
-             (andl (int 7) eax)
-             (cmpl (int 7) eax)
-             (jne Lf)
-             Ljoin
-             ac))]
-        [else ac])]
-     [($ap-check-words)
-      (record-case (car rand*)
-        [(constant i)
-         (list* (movl (pcb-ref 'allocation-redline) eax)
-                (subl (Simple (cadr rand*)) eax)
-                (subl (int i) eax)
-                (cmpl eax apr)
-                (cond-branch 'jge Lt Lf ac))]
-        [else (error who "ap-check-words")])]
-     [($ap-check-bytes)
-      (record-case (car rand*)
-        [(constant i)
-         (list* (movl (Simple (cadr rand*)) eax)
-                (negl eax)
-                (addl (pcb-ref 'allocation-redline) eax)
-                (subl (int i) eax)
-                (cmpl eax apr)
-                (cond-branch 'jge Lt Lf ac))]
-        [else (error who "ap-check-bytes")])]
-     [($ap-check-const) 
-      (record-case (car rand*)
-        [(constant i) 
-         (if (fx<= i pagesize)
-             (list* 
-               (cmpl (pcb-ref 'allocation-redline) apr)
-               (cond-branch 'jge Lt Lf ac))
-             (list* 
-               (movl (pcb-ref 'allocation-redline) eax)
-               (subl (int i) eax)
-               (cmpl eax apr)
-               (cond-branch 'jge Lt Lf ac)))]
-        [else (error who "ap-check-const")])]
-     [($fp-at-base) 
-      (list* 
-        (movl (pcb-ref 'frame-base) eax)
-        (subl (int wordsize) eax)
-        (cmpl eax fpr)
-        (cond-branch 'je Lt Lf ac))]
-     [($fp-overflow) 
-      (list* (cmpl (pcb-ref 'frame-redline) fpr)
-             (cond-branch 'jle Lt Lf ac))]
-     [($vector-ref top-level-value car cdr $record-ref) 
-      (do-value-prim op rand*
-        (do-simple-test eax Lt Lf ac))]
-     [(cons void $fxadd1 $fxsub1)
-      ;;; always true
-      (do-effect-prim op rand*
-        (cond
-          [(not Lt) ac]
-          [else (cons (jmp Lt) ac)]))]
-     [else 
-      (error 'pred-prim "HERE unhandled ~s" op)]))
-  (define (do-pred->value-prim op rand* ac)
-    (case op
-      [else
-       (let ([Lf (unique-label)] [Lj (unique-label)])
-         (do-pred-prim op rand* #f Lf
-           (list* (movl (constant-val #t) eax)
-                  (jmp Lj)
-                  Lf
-                  (movl (constant-val #f) eax)
-                  Lj
-                  ac)))]))
-  (define (indirect-ref arg* off ac)
-    (list*
-      (movl (Simple (car arg*)) eax)
-      (movl (mem off eax) eax)
-      ac))
-  (define (do-make-port tag args ac)
-    (let f ([args args] [idx disp-vector-data])
-      (cond
-        [(null? args)
-         (if (fx= idx port-size)
-             (list*
-               (movl (int tag) (mem 0 apr))
-               (movl apr eax)
-               (addl (int port-size) apr)
-               (addl (int vector-tag) eax)
-               ac)
-             (error 'do-make-port "BUG"))]
-         [else
-          (list* 
-            (movl (Simple (car args)) eax)
-            (movl eax (mem idx apr))
-            (f (cdr args) (fx+ idx wordsize)))])))
-  (define (do-value-prim op arg* ac)
-    (case op
-      [(eof-object) (cons (movl (int eof) eax) ac)]
-      [(void)       (cons (movl (int void-object) eax) ac)]
-      [($fxadd1) 
-       (list* (movl (Simple (car arg*)) eax)
-              (addl (constant-val 1) eax)
-              ac)]
-      [($fxsub1) 
-       (list* (movl (Simple (car arg*)) eax)
-              (addl (constant-val -1) eax)
-              ac)]
-      [($fx+) 
-       (list* (movl (Simple (car arg*)) eax)
-              (addl (Simple (cadr arg*)) eax)
-              ac)]
-      [($fx-) 
-       (list* (movl (Simple (car arg*)) eax)
-              (subl (Simple (cadr arg*)) eax)
-              ac)]
-      [($fx*)
-       (cond
-         [(constant? (car arg*))
-          (record-case (car arg*)
-            [(constant c)
-             (unless (fixnum? c)
-               (error who "invalid arg ~s to fx*" c))
-             (list* (movl (Simple (cadr arg*)) eax)
-                    (imull (int c) eax)
-                    ac)])]
-         [(constant? (cadr arg*))
-          (record-case (cadr arg*)
-            [(constant c)
-             (unless (fixnum? c)
-               (error who "invalid arg ~s to fx*" c))
-             (list* (movl (Simple (car arg*)) eax)
-                    (imull (int c) eax)
-                    ac)])]
-         [else
-          (list* (movl (Simple (car arg*)) eax)
-                 (sarl (int fx-shift) eax)
-                 (imull (Simple (cadr arg*)) eax)
-                 ac)])]
-      [($fxquotient)
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ecx)
-              (cltd)
-              (idivl ecx)
-              (sall (int fx-shift) eax)
-              ac)]
-      [($fxmodulo)
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ebx)
-              (movl eax ecx)
-              (xorl ebx ecx)
-              (sarl (int (fxsub1 (fx* wordsize 8))) ecx)
-              (andl ebx ecx)
-              (cltd)
-              (idivl ebx)
-              (movl edx eax)
-              (addl ecx eax)
-              ac)]
-      [($fxlogor) 
-       (list* (movl (Simple (car arg*)) eax)
-              (orl (Simple (cadr arg*)) eax)
-              ac)]
-      [($fxlogand) 
-       (list* (movl (Simple (car arg*)) eax)
-              (andl (Simple (cadr arg*)) eax)
-              ac)]
-      [($fxlogxor) 
-       (list* (movl (Simple (car arg*)) eax)
-              (xorl (Simple (cadr arg*)) eax)
-              ac)]
-      [($fxsra)
-       (record-case (cadr arg*)
-         [(constant i)
-          (unless (fixnum? i) (error who "invalid arg to fxsra"))
-          (list* (movl (Simple (car arg*)) eax)
-                 (sarl (int (fx+ i fx-shift)) eax)
-                 (sall (int fx-shift) eax)
-                 ac)]
-         [else
-          (list* (movl (Simple (car arg*)) eax)
-                 (movl (Simple (cadr arg*)) ecx)
-                 (sarl (int fx-shift) ecx)
-                 (sarl (int fx-shift) eax)
-                 (sarl cl eax)
-                 (sall (int fx-shift) eax)
-                 ac)])]
-      [($fxsll)
-       (record-case (cadr arg*)
-         [(constant i)
-          (unless (fixnum? i) (error who "invalid arg to fxsll"))
-          (list* (movl (Simple (car arg*)) eax)
-                 (sall (int i) eax)
-                 ac)]
-         [else
-          (list* (movl (Simple (car arg*)) eax)
-                 (movl (Simple (cadr arg*)) ecx)
-                 (sarl (int fx-shift) ecx)
-                 (sall cl eax)
-                 ac)])]
-      [($fixnum->char)  
-       (list* (movl (Simple (car arg*)) eax)
-              (sall (int (fx- char-shift fx-shift)) eax)
-              (orl (int char-tag) eax)
-              ac)]
-      [($char->fixnum) 
-       (list* (movl (Simple (car arg*)) eax)
-              (sarl (int (fx- char-shift fx-shift)) eax)
-              ac)]
-      [($fxlognot) 
-       (list* (movl (Simple (car arg*)) eax)
-              (orl (int fx-mask) eax)
-              (notl eax)
-              ac)]
-      [($car) (indirect-ref arg* (fx- disp-car pair-tag) ac)]
-      [($cdr) (indirect-ref arg* (fx- disp-cdr pair-tag) ac)]
-      [($vector-length) 
-       (indirect-ref arg* (fx- disp-vector-length vector-tag) ac)]
-      [($string-length) 
-       (indirect-ref arg* (fx- disp-string-length string-tag) ac)]
-      [($symbol-string) 
-       (indirect-ref arg* (fx- disp-symbol-string symbol-tag) ac)]
-      [($symbol-unique-string) 
-       (indirect-ref arg* (fx- disp-symbol-unique-string symbol-tag) ac)]
-      [($symbol-value) 
-       (indirect-ref arg* (fx- disp-symbol-value symbol-tag) ac)]
-      [(primitive-ref) 
-       (indirect-ref arg* (fx- disp-symbol-system-value symbol-tag) ac)]
-      [($tcbucket-key) 
-       (indirect-ref arg* (fx- disp-tcbucket-key vector-tag) ac)]
-      [($tcbucket-val) 
-       (indirect-ref arg* (fx- disp-tcbucket-val vector-tag) ac)]
-      [($tcbucket-next) 
-       (indirect-ref arg* (fx- disp-tcbucket-next vector-tag) ac)]
-      [($port-handler) 
-       (indirect-ref arg* (fx- disp-port-handler vector-tag) ac)]
-      [($port-input-buffer) 
-       (indirect-ref arg* (fx- disp-port-input-buffer vector-tag) ac)]
-      [($port-input-index) 
-       (indirect-ref arg* (fx- disp-port-input-index vector-tag) ac)]
-      [($port-input-size) 
-       (indirect-ref arg* (fx- disp-port-input-size vector-tag) ac)]
-      [($port-output-buffer) 
-       (indirect-ref arg* (fx- disp-port-output-buffer vector-tag) ac)]
-      [($port-output-index) 
-       (indirect-ref arg* (fx- disp-port-output-index vector-tag) ac)]
-      [($port-output-size) 
-       (indirect-ref arg* (fx- disp-port-output-size vector-tag) ac)]
-      [(pointer-value)
-       (list*
-         (movl (Simple (car arg*)) eax)
-         (sarl (int fx-shift) eax)
-         (sall (int fx-shift) eax)
-         ac)]
-      [($symbol-plist) 
-       (indirect-ref arg* (fx- disp-symbol-plist symbol-tag) ac)]
-      [($record-rtd) 
-       (indirect-ref arg* (fx- disp-record-rtd record-ptag) ac)]
-      [($constant-ref)
-       (list* (movl (Simple (car arg*)) eax) ac)]
-      [(car cdr)
-       (let ([x (car arg*)])
-         (NonTail x
-           (list* 
-             (movl eax ebx)
-             (andl (int pair-mask) eax)
-             (cmpl (int pair-tag) eax)
-             (if (eq? op 'car)
-                 (list* 
-                   (jne (label SL_car_error))
-                   (movl (mem (fx- disp-car pair-tag) ebx) eax)
-                   ac)
-                 (list* 
-                   (jne (label SL_cdr_error))
-                   (movl (mem (fx- disp-cdr pair-tag) ebx) eax)
-                   ac)))))]
-      [(top-level-value)
-       (let ([x (car arg*)])
-         (cond
-           [(constant? x)
-            (let ([v (constant-value x)])
-              (cond
-                [(symbol? v)
-                 (list* 
-                   (movl (mem (fx- disp-symbol-value symbol-tag) (obj v)) eax)
-                   (movl (obj v) ebx)
-                   (cmpl (int unbound) eax)
-                   (je (label SL_top_level_value_error))
-                   ac)]
-                [else
-                 (list* 
-                   (movl (obj v) ebx)
-                   (jmp (label SL_top_level_value_error))
-                   ac)]))]
-           [else
-            (NonTail x
-              (list* 
-                (movl eax ebx)
-                (andl (int symbol-mask) eax)
-                (cmpl (int symbol-tag) eax)
-                (jne (label SL_top_level_value_error))
-                (movl (mem (fx- disp-symbol-value symbol-tag) ebx) eax)
-                (cmpl (int unbound) eax)
-                (je (label SL_top_level_value_error))
-                ac))]))]
-      [($vector-ref) 
-       (list* (movl (Simple (car arg*)) ebx)
-              (addl (Simple (cadr arg*)) ebx)
-              (movl (mem (fx- disp-vector-data vector-tag) ebx) eax)
-              ac)]
-      [($record-ref) 
-       (list* (movl (Simple (car arg*)) ebx)
-              (addl (Simple (cadr arg*)) ebx)
-              (movl (mem (fx- disp-record-data record-ptag) ebx) eax)
-              ac)]
-      [($code-ref) 
-       (list* (movl (Simple (cadr arg*)) ebx)
-              (sarl (int fx-shift) ebx)
-              (addl (Simple (car arg*)) ebx)
-              (movl (int 0) eax)
-              (movb (mem (fx- disp-code-data vector-tag) ebx) ah)
-              (sarl (int (fx- 8 fx-shift)) eax)
-              ac)]
-      [($string-ref) 
-       (list* (movl (Simple (cadr arg*)) ebx)
-              (sarl (int fx-shift) ebx)
-              (addl (Simple (car arg*)) ebx)
-              (movl (int char-tag) eax)
-              (movb (mem (fx- disp-string-data string-tag) ebx) ah)
-              ac)]
-      [($make-string) 
-       (list* (movl (Simple (car arg*)) ebx)
-              (movl ebx (mem disp-string-length apr))
-              (movl apr eax)
-              (addl (int string-tag) eax)
-              (sarl (int fx-shift) ebx)
-              (addl ebx apr)
-              (movb (int 0) (mem disp-string-data apr))
-              (addl (int (fx+ disp-string-data object-alignment)) apr)
-              (sarl (int align-shift) apr)
-              (sall (int align-shift) apr)
-              ac)]
-      [($make-vector) 
-       (list* (movl (Simple (car arg*)) ebx)
-              (movl ebx (mem disp-vector-length apr))
-              (movl apr eax)
-              (addl (int vector-tag) eax)
-              (addl ebx apr)
-              (addl (int (fx+ disp-vector-data (fxsub1 object-alignment))) apr)
-              (sarl (int align-shift) apr)
-              (sall (int align-shift) apr)
-              ac)]
-      [($make-record) 
-       (list* (movl (Simple (car arg*)) eax)
-              (movl eax (mem disp-record-rtd apr))
-              (movl apr eax)
-              (addl (int record-ptag) eax)
-              (addl (Simple (cadr arg*)) apr)
-              (addl (int (fx+ disp-record-data (fxsub1 object-alignment))) apr)
-              (sarl (int align-shift) apr)
-              (sall (int align-shift) apr)
-              ac)]
-      [(cons)
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ebx)
-              (movl eax (mem disp-car apr))
-              (movl apr eax)
-              (movl ebx (mem disp-cdr apr))
-              (addl (int pair-tag) eax)
-              (addl (int (align pair-size)) apr)
-              ac)]
-      [(list)
-       (cond
-         [(null? arg*) (NonTail (make-constant '()) ac)]
-         [else
-          (list*
-            (addl (int pair-tag) apr)
-            (movl apr eax)
-            (let f ([a (car arg*)] [d (cdr arg*)])
-              (list*
-                (movl (Simple a) ebx)
-                (movl ebx (mem (fx- disp-car pair-tag) apr))
-                (if (null? d)
-                    (list*
-                      (movl (int nil) (mem (fx- disp-cdr pair-tag) apr))
-                      (addl (int (fx- pair-size pair-tag)) apr)
-                      ac)
-                    (list*
-                      (addl (int pair-size) apr)
-                      (movl apr 
-                          (mem (fx- disp-cdr (fx+ pair-tag pair-size)) apr))
-                      (f (car d) (cdr d)))))))])]
-      [(list*)
-       (cond
-         [(fx= (length arg*) 1) (NonTail (car arg*) ac)]
-         [(fx= (length arg*) 2) (NonTail (make-primcall 'cons arg*) ac)]
-         [else
-          (list*
-            (addl (int pair-tag) apr)
-            (movl apr eax)
-            (let f ([a (car arg*)] [b (cadr arg*)] [d (cddr arg*)])
-              (list*
-                (movl (Simple a) ebx)
-                (movl ebx (mem (fx- disp-car pair-tag) apr))
-                (if (null? d)
-                    (list*
-                      (movl (Simple b) ebx)
-                      (movl ebx (mem (fx- disp-cdr pair-tag) apr))
-                      (addl (int (fx- pair-size pair-tag)) apr)
-                      ac)
-                    (list*
-                      (addl (int pair-size) apr)
-                      (movl apr 
-                          (mem (fx- disp-cdr (fx+ pair-tag pair-size)) apr))
-                      (f b (car d) (cdr d)))))))])]
-      [($make-symbol)
-       (list* (movl (Simple (car arg*)) eax)
-              (movl eax (mem disp-symbol-string apr))
-              (movl (int 0) (mem disp-symbol-unique-string apr))
-              (movl (int unbound) (mem disp-symbol-value apr))
-              (movl (int nil) (mem disp-symbol-plist apr))
-              (movl (int unbound) (mem disp-symbol-system-value apr))
-              (movl (int nil) (mem disp-symbol-system-plist apr))
-              (movl apr eax)
-              (addl (int symbol-tag) eax)
-              (addl (int (align symbol-size)) apr)
-              ac)]
-      [($make-port/input)  (do-make-port input-port-tag arg* ac)]
-      [($make-port/output) (do-make-port output-port-tag arg* ac)]
-      [($make-port/both)   (do-make-port input/output-port-tag arg* ac)]
-      [($make-tcbucket)
-       (list* (movl (Simple (car arg*)) eax)
-              (movl eax (mem disp-tcbucket-tconc apr))
-              (movl (Simple (cadr arg*)) eax)
-              (movl eax (mem disp-tcbucket-key apr))
-              (movl (Simple (caddr arg*)) eax)
-              (movl eax (mem disp-tcbucket-val apr))
-              (movl (Simple (cadddr arg*)) eax)
-              (movl eax (mem disp-tcbucket-next apr))
-              (movl apr eax)
-              (addl (int vector-tag) eax)
-              (addl (int (align tcbucket-size)) apr)
-              ac)] 
-      [($record) 
-       (let ([rtd (car arg*)]
-             [ac 
-              (let f ([arg* (cdr arg*)] [idx disp-record-data])
-                (cond
-                  [(null? arg*) 
-                   (list* (movl apr eax)
-                          (addl (int vector-tag) eax)
-                          (addl (int (align idx)) apr)
-                          ac)]
-                  [else 
-                   (list* (movl (Simple (car arg*)) eax)
-                          (movl eax (mem idx apr))
-                          (f (cdr arg*) (fx+ idx wordsize)))]))])
-         (cond
-           [(constant? rtd)
-            (list* (movl (Simple rtd) (mem 0 apr)) ac)]
-           [else
-            (list* (movl (Simple rtd) eax) (movl eax (mem 0 apr)) ac)]))]
-      [(vector) 
-       (let f ([arg* arg*] [idx disp-vector-data])
-         (cond
-           [(null? arg*) 
-            (list* (movl apr eax)
-                   (addl (int vector-tag) eax)
-                   (movl (int (fx- idx disp-vector-data))
-                         (mem disp-vector-length apr))
-                   (addl (int (align idx)) apr)
-                   ac)]
-           [else 
-            (list* (movl (Simple (car arg*)) eax)
-                   (movl eax (mem idx apr))
-                   (f (cdr arg*) (fx+ idx wordsize)))]))]
-     [($string)
-      (let f ([arg* arg*] [idx disp-string-data])
-        (cond
-          [(null? arg*) 
-           (list* (movb (int 0) (mem idx apr))
-                  (movl apr eax)
-                  (addl (int string-tag) eax)
-                  (movl (int (fx* (fx- idx disp-string-data) wordsize))
-                        (mem disp-string-length apr))
-                  (addl (int (align (fxadd1 idx))) apr)
-                  ac)]
-          [else
-           (record-case (car arg*)
-             [(constant c) 
-              (unless (char? c) (error who  "invalid arg to string ~s" x))
-              (list* (movb (int (char->integer c)) (mem idx apr))
-                     (f (cdr arg*) (fxadd1 idx)))]
-             [else
-              (list* (movl (Simple (car arg*)) ebx)
-                     (movb bh (mem idx apr))
-                     (f (cdr arg*) (fxadd1 idx)))])]))]
-     [($current-frame)
-      (list* (movl (pcb-ref 'next-continuation) eax)
-             ac)]
-     [($seal-frame-and-call) 
-      (list* (movl (Simple (car arg*)) cpr) ; proc
-             (movl (pcb-ref 'frame-base) eax)
-             ; eax=baseofstack
-             (movl (mem (fx- 0 wordsize) eax) ebx) ; underflow handler
-             (movl ebx (mem (fx- 0 wordsize) fpr)) ; set
-             ; create a new cont record
-             (movl (int continuation-tag) (mem 0 apr))
-             (movl fpr (mem disp-continuation-top apr))
-             ; compute the size of the captured frame
-             (movl eax ebx) 
-             (subl fpr ebx) 
-             (subl (int wordsize) ebx)
-             ; and store it
-             (movl ebx (mem disp-continuation-size apr))
-             ; load next cont
-             (movl (pcb-ref 'next-continuation) ebx)
-             ; and store it
-             (movl ebx (mem disp-continuation-next apr))
-             ; adjust ap
-             (movl apr eax)
-             (addl (int vector-tag) eax)
-             (addl (int continuation-size) apr)
-             ; store new cont in current-cont
-             (movl eax (pcb-ref 'next-continuation))
-             ; adjust fp
-             (movl fpr (pcb-ref 'frame-base))
-             (subl (int wordsize) fpr)
-             ; tail-call f
-             (movl eax (mem (fx- 0 wordsize) fpr))
-             (movl (int (argc-convention 1)) eax)
-             (tail-indirect-cpr-call)
-             ac)]
-     [($code-size) 
-      (indirect-ref arg* (fx- disp-code-instrsize vector-tag)  ac)]
-     [($code-reloc-vector) 
-       (indirect-ref arg* (fx- disp-code-relocsize vector-tag) ac)]
-     [($code-freevars) 
-       (indirect-ref arg* (fx- disp-code-freevars vector-tag) ac)]
-     [($set-car! $set-cdr! $vector-set! $string-set! $exit
-       $set-symbol-value! $set-symbol-plist! 
-       $code-set!  primitive-set! 
-       $set-code-object! $set-code-object+offset! $set-code-object+offset/rel!
-       $record-set!
-       $set-port-input-index! $set-port-input-size!
-       $set-port-output-index! $set-port-output-size!) 
-      (do-effect-prim op arg*
-        (cons (movl (int void-object) eax) ac))]
-     [(fixnum? immediate? $fxzero? boolean? char? pair? vector? string? symbol?
-       procedure? null? not eof-object? $fx= $fx< $fx<= $fx> $fx>= eq?
-       $char= $char< $char<= $char> $char>= $unbound-object? $code? 
-       $record? $record/rtd? bwp-object? port? input-port? output-port?) 
-      (do-pred->value-prim op arg* ac)]
-     [($code->closure)
-      (list* 
-        (movl (Simple (car arg*)) eax)
-        (addl (int (fx- disp-code-data vector-tag)) eax)
-        (movl eax (mem 0 apr))
-        (movl apr eax)
-        (addl (int closure-tag) eax)
-        (addl (int (align disp-closure-data)) apr)
-        ac)]
-     [($frame->continuation)
-      (NonTail 
-        (make-closure (make-code-loc SL_continuation_code) arg*)
-        ac)]
-     [($make-call-with-values-procedure)
-      (NonTail 
-        (make-closure (make-code-loc SL_call_with_values) arg*)
-        ac)]
-     [($make-values-procedure)
-      (NonTail 
-        (make-closure (make-code-loc SL_values) arg*)
-        ac)]
-     [else
-      (error 'value-prim "unhandled ~s" op)]))
-  (define (indirect-assignment arg* offset ac)
-    (list*
-      (movl (Simple (car arg*)) eax)
-      (movl (Simple (cadr arg*)) ebx)
-      (movl ebx (mem offset eax))
-       ;;; record side effect
-      (addl (int offset) eax)
-      (shrl (int pageshift) eax)
-      (sall (int wordshift) eax)
-      (addl (pcb-ref 'dirty-vector) eax)
-      (movl (int dirty-word) (mem 0 eax))
-      ac))
-  (define (do-effect-prim op arg* ac)
-    (case op
-      [($vector-set!) 
-       (list* (movl (Simple (car arg*)) ebx)
-              (addl (Simple (cadr arg*)) ebx)
-              (addl (int (fx- disp-vector-data vector-tag)) ebx)
-              (movl (Simple (caddr arg*)) eax)
-              (movl eax (mem 0 ebx))
-              ;;; record side effect
-              (shrl (int pageshift) ebx)
-              (sall (int wordshift) ebx)
-              (addl (pcb-ref 'dirty-vector) ebx)
-              (movl (int dirty-word) (mem 0 ebx))
-              ac)]
-      [($code-set!) 
-       (list* (movl (Simple (cadr arg*)) eax)
-              (sarl (int fx-shift) eax)
-              (addl (Simple (car arg*)) eax)
-              (movl (Simple (caddr arg*)) ebx)
-              (sall (int (fx- 8 fx-shift)) ebx)
-              (movb bh (mem (fx- disp-code-data vector-tag) eax))
-              ac)]
-      [($string-set!) 
-       (list* (movl (Simple (cadr arg*)) eax)
-              (sarl (int fx-shift) eax)
-              (addl (Simple (car arg*)) eax)
-              (movl (Simple (caddr arg*)) ebx)
-              (movb bh (mem (fx- disp-string-data string-tag) eax))
-              ac)]
-      [($set-car!) 
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ebx)
-              (movl ebx (mem (fx- disp-car pair-tag) eax))
-               ;;; record side effect
-               (shrl (int pageshift) eax)
-               (sall (int wordshift) eax)
-               (addl (pcb-ref 'dirty-vector) eax)
-               (movl (int dirty-word) (mem 0 eax))
-              ac)]
-      [($set-cdr!) 
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ebx)
-              (movl ebx (mem (fx- disp-cdr pair-tag) eax))
-               ;;; record side effect
-               (shrl (int pageshift) eax)
-               (sall (int wordshift) eax)
-               (addl (pcb-ref 'dirty-vector) eax)
-               (movl (int dirty-word) (mem 0 eax))
-              ac)]
-      [($set-tcbucket-key!)
-       (indirect-assignment arg* (fx- disp-tcbucket-key vector-tag) ac)]
-      [($set-tcbucket-val!)
-       (indirect-assignment arg* (fx- disp-tcbucket-val vector-tag) ac)]
-      [($set-tcbucket-next!)
-       (indirect-assignment arg* (fx- disp-tcbucket-next vector-tag) ac)]
-      [($set-tcbucket-tconc!)
-       (indirect-assignment arg* (fx- disp-tcbucket-tconc vector-tag) ac)]
-      [($set-port-input-index!)
-       (list*
-         (movl (Simple (car arg*)) eax)
-         (movl (Simple (cadr arg*)) ebx)
-         (movl ebx (mem (fx- disp-port-input-index vector-tag) eax))
-         ac)]
-      [($set-port-input-size!)
-       (list*
-         (movl (Simple (car arg*)) eax)
-         (movl (Simple (cadr arg*)) ebx)
-         (movl (int 0) (mem (fx- disp-port-input-index vector-tag) eax))
-         (movl ebx (mem (fx- disp-port-input-size vector-tag) eax))
-         ac)]
-      [($set-port-output-index!)
-       (list*
-         (movl (Simple (car arg*)) eax)
-         (movl (Simple (cadr arg*)) ebx)
-         (movl ebx (mem (fx- disp-port-output-index vector-tag) eax))
-         ac)]
-      [($set-port-output-size!)
-       (list*
-         (movl (Simple (car arg*)) eax)
-         (movl (Simple (cadr arg*)) ebx)
-         (movl (int 0) (mem (fx- disp-port-output-index vector-tag) eax))
-         (movl ebx (mem (fx- disp-port-output-size vector-tag) eax))
-         ac)]
-      [($set-symbol-value!) 
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ebx)
-              (movl ebx (mem (fx- disp-symbol-value symbol-tag) eax))
-               ;;; record side effect
-               (addl (int (fx- disp-symbol-value symbol-tag)) eax)
-               (shrl (int pageshift) eax)
-               (sall (int wordshift) eax)
-               (addl (pcb-ref 'dirty-vector) eax)
-               (movl (int dirty-word) (mem 0 eax))
-              ac)]
-      [(primitive-set!) 
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ebx)
-              (movl ebx (mem (fx- disp-symbol-system-value symbol-tag) eax))
-               ;;; record side effect
-               (addl (int (fx- disp-symbol-system-value symbol-tag)) eax)
-               (shrl (int pageshift) eax)
-               (sall (int wordshift) eax)
-               (addl (pcb-ref 'dirty-vector) eax)
-               (movl (int dirty-word) (mem 0 eax))
-              ac)]
-      [($set-symbol-plist!) 
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ebx)
-              (movl ebx (mem (fx- disp-symbol-plist symbol-tag) eax))
-               ;;; record side effect
-               (addl (int (fx- disp-symbol-plist symbol-tag)) eax)
-               (shrl (int pageshift) eax)
-               (sall (int wordshift) eax)
-               (addl (pcb-ref 'dirty-vector) eax)
-               (movl (int dirty-word) (mem 0 eax))
-              ac)]
-      [($set-symbol-unique-string!) 
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ebx)
-              (movl ebx (mem (fx- disp-symbol-unique-string symbol-tag) eax))
-               ;;; record side effect
-               (addl (int (fx- disp-symbol-unique-string symbol-tag)) eax)
-               (shrl (int pageshift) eax)
-               (sall (int wordshift) eax)
-               (addl (pcb-ref 'dirty-vector) eax)
-               (movl (int dirty-word) (mem 0 eax))
-              ac)]
-      [($set-symbol-string!) 
-       (list* (movl (Simple (car arg*)) eax)
-              (movl (Simple (cadr arg*)) ebx)
-              (movl ebx (mem (fx- disp-symbol-string symbol-tag) eax))
-               ;;; record side effect
-               (addl (int (fx- disp-symbol-string symbol-tag)) eax)
-               (shrl (int pageshift) eax)
-               (sall (int wordshift) eax)
-               (addl (pcb-ref 'dirty-vector) eax)
-               (movl (int dirty-word) (mem 0 eax))
-              ac)] 
-      [($record-set!) 
-       (list* (movl (Simple (car arg*)) ebx)
-              (addl (Simple (cadr arg*)) ebx)
-              (movl (Simple (caddr arg*)) eax)
-              (addl (int (fx- disp-record-data record-ptag)) ebx)
-              (movl eax (mem 0 ebx))
-               ;;; record side effect
-               (shrl (int pageshift) ebx)
-               (sall (int wordshift) ebx)
-               (addl (pcb-ref 'dirty-vector) ebx)
-               (movl (int dirty-word) (mem 0 ebx))
-              ac)]
-      [(cons void $fxadd1 $fxsub1 $record-ref)
-       (let f ([arg* arg*])
-         (cond
-           [(null? arg*) ac]
-           [else 
-            (Effect (car arg*) (f (cdr arg*)))]))]
-      [else 
-       (error 'do-effect-prim "unhandled op ~s" op)]))
- (define (do-simple-test x Lt Lf ac)
-    (unless (or Lt Lf)
-      (error 'Pred "no labels"))
-    (cond
-      [(not Lt)
-       (list* (cmpl (int bool-f) x) (je Lf) ac)]
-      [(not Lf)
-       (list* (cmpl (int bool-f) x) (jne Lt) ac)]
-      [else
-       (list* (cmpl (int bool-f) x) (je Lf) (jmp Lt) ac)]))
-  (define (Simple x)
-    (record-case x
-      [(cp-var i) 
-       (mem (fx+ (fx* i wordsize) (fx- disp-closure-data closure-tag)) cpr)]
-      [(frame-var i) (mem (fx* i (fx- 0 wordsize)) fpr)]
-      [(constant c) (constant-val c)]
-      [(code-loc label) (label-address label)]
-      [(primref op) (primref-loc op)]
-      [else (error 'Simple "what ~s" x)]))
-  (define (closure-size x)
-    (align (fx+ disp-closure-data
-                (fx* wordsize (length (closure-free* x))))))
-  (define (assign-codes rhs* n* i ac)
-    (cond
-      [(null? rhs*) ac]
-      [else
-       (record-case (car rhs*)
-         [(closure label free*)
-          (cons (movl (Simple label) (mem i apr))
-                (assign-codes 
-                  (cdr rhs*) (cdr n*) (fx+ i (car n*)) ac))])]))
-  (define (whack-free x i n* rhs* ac)
-    (cond
-      [(null? rhs*) ac]
-      [else
-       (let ([free (closure-free* (car rhs*))])
-         (let f ([free free] [j (fx+ i disp-closure-data)])
-           (cond
-             [(null? free) 
-              (whack-free x (fx+ i (car n*)) (cdr n*) (cdr rhs*) ac)]
-             [(eq? (car free) x)
-              (cons
-                (movl eax (mem j apr))
-                (f (cdr free) (fx+ j wordsize)))]
-             [else (f (cdr free) (fx+ j wordsize))])))]))
-  (define (assign-nonrec-free* rhs* all-rhs* n* seen ac)
-    (cond
-      [(null? rhs*) ac]
-      [else
-       (let f ([ls (closure-free* (car rhs*))] [seen seen])
-         (cond
-           [(null? ls) 
-            (assign-nonrec-free* (cdr rhs*) all-rhs* n* seen ac)]
-           [(memq (car ls) seen) (f (cdr ls) seen)]
-           [else
-            (cons
-              (movl (Simple (car ls)) eax)
-              (whack-free (car ls) 0 n* all-rhs*
-                (f (cdr ls) (cons (car ls) seen))))]))]))
-  (define (assign-rec-free* lhs* rhs* all-n* ac)
-    (list* (movl apr eax)
-           (addl (int closure-tag) eax)
-           (let f ([lhs* lhs*] [n* all-n*])
-             (cond
-               [(null? (cdr lhs*)) 
-                (cons
-                  (movl eax (Simple (car lhs*)))
-                  (whack-free (car lhs*) 0 all-n* rhs* ac))]
-               [else
-                (cons
-                  (movl eax (Simple (car lhs*)))
-                  (whack-free (car lhs*) 0 all-n* rhs*
-                    (cons
-                      (addl (int (car n*)) eax)
-                      (f (cdr lhs*) (cdr n*)))))]))))
-  (define (sum ac ls)
-    (cond
-      [(null? ls) ac]
-      [else (sum (fx+ ac (car ls)) (cdr ls))]))
-  (define (do-fix lhs* rhs* ac)
-    ;;; 1. first, set the code pointers in the right places
-    ;;; 2. next, for every variable appearing in the rhs* but is not in
-    ;;;    the lhs*, load it once and set it everywhere it occurs.
-    ;;; 3. next, compute the values of the lhs*, and for every computed
-    ;;;    value, store it on the stack, and set it everywhere it occurs
-    ;;;    in the rhs*
-    ;;; 4. that's it.
-    (let* ([n* (map closure-size rhs*)])
-      (assign-codes rhs* n* 0
-        (assign-nonrec-free* rhs* rhs* n* lhs*
-          (assign-rec-free* lhs* rhs* n*
-            (cons (addl (int (sum 0 n*)) apr) ac))))))
-  (define (frame-adjustment offset)
-    (fx* (fxsub1 offset) (fx- 0 wordsize)))
-  (define (NonTail x ac) 
-    (record-case x
-      [(constant c)
-       (cons (movl (constant-val c) eax) ac)]
-      [(frame-var)
-       (cons (movl (Simple x) eax) ac)]
-      [(cp-var)
-       (cons (movl (Simple x) eax) ac)]
-      [(foreign-label L) 
-       (cons (movl (list 'foreign-label L) eax) ac)]
-      [(primref c)
-       (cons (movl (primref-loc c) eax) ac)]
-      [(closure label arg*)
-       (let f ([arg* arg*] [off disp-closure-data])
-         (cond
-           [(null? arg*)
-            (list* (movl (Simple label) (mem 0 apr))
-                   (movl apr eax)
-                   (addl (int (align off)) apr)
-                   (addl (int closure-tag) eax)
-                   ac)]
-           [else
-            (list* (movl (Simple (car arg*)) eax)
-                   (movl eax (mem off apr))
-                   (f (cdr arg*) (fx+ off wordsize)))]))]
-      [(conditional test conseq altern)
-       (let ([Lj (unique-label)] [Lf (unique-label)])
-         (Pred test #f Lf
-           (NonTail conseq
-             (list* (jmp Lj) Lf (NonTail altern (cons Lj ac))))))]
-      [(seq e0 e1)
-       (Effect e0 (NonTail e1 ac))]
-      [(fix lhs* rhs* body)
-       (do-fix lhs* rhs* (NonTail body ac))]
-      [(primcall op rand*)
-       (do-value-prim op rand* ac)]
-      [(new-frame base-idx size body)
-       (NonTail body ac)]
-      [(call-cp call-convention rp-convention offset size mask)
-       (let ([L_CALL (unique-label)])
-         (case call-convention
-           [(normal)
-            (list* (addl (int (frame-adjustment offset)) fpr)
-                   (movl (int (argc-convention size)) eax)
-                   (jmp L_CALL)
-                   ; NEW FRAME
-                   `(byte-vector ,mask)
-                   `(int ,(fx* offset wordsize))
-                   `(current-frame-offset)
-                   (rp-label rp-convention)
-                   `(byte 0) ; padding for indirect calls only
-                   `(byte 0) ; direct calls are ok
-                   L_CALL
-                   (indirect-cpr-call)
-                   (movl (mem 0 fpr) cpr)
-                   (subl (int (frame-adjustment offset)) fpr)
-                   ac)]
-           [(foreign) 
-            (list* (addl (int (frame-adjustment offset)) fpr)
-                   (movl (int (argc-convention size)) eax)
-                   (movl '(foreign-label "ik_foreign_call") ebx)
-                   (jmp L_CALL)
-                   ; NEW FRAME
-                   (byte-vector mask)
-                   `(int ,(fx* offset wordsize))
-                   `(current-frame-offset)
-                   (rp-label rp-convention) ; should be 0, since C has 1 rv
-                   '(byte 0)
-                   '(byte 0)
-                   '(byte 0)
-                   L_CALL
-                   (call ebx)
-                   (movl (mem 0 fpr) cpr)
-                   (subl (int (frame-adjustment offset)) fpr)
-                   ac)]
-           [else
-            (error who "invalid convention ~s for call-cp" call-convention)]))]
-      [else (error 'NonTail "invalid expression ~s" x)]))
-  (define (Pred x Lt Lf ac)
-    (record-case x
-      [(frame-var i) 
-       (do-simple-test (idx->frame-loc i) Lt Lf ac)]
-      [(cp-var i) 
-       (do-simple-test (Simple x) Lt Lf ac)]
-      [(constant c) 
-       (if c
-           (if Lt (cons (jmp Lt) ac) ac)
-           (if Lf (cons (jmp Lf) ac) ac))]
-     [(fix lhs* rhs* body)
-      (do-fix lhs* rhs* (Pred body Lt Lf ac))]
-      [(primcall op rand*)
-       (do-pred-prim op rand* Lt Lf ac)]
-      [(conditional test conseq altern)
-       (cond
-         [(not Lt) 
-          (let ([Lj^ (unique-label)] [Lf^ (unique-label)])
-            (Pred test #f Lf^
-              (Pred conseq Lj^ Lf
-                (cons Lf^
-                  (Pred altern #f Lf 
-                    (cons Lj^ ac))))))]
-         [(not Lf) 
-          (let ([Lj^ (unique-label)] [Lf^ (unique-label)])
-            (Pred test #f Lf^
-              (Pred conseq Lt Lj^
-                (cons Lf^
-                  (Pred altern Lt #f 
-                    (cons Lj^ ac))))))]
-         [else 
-          (let ([Lf^ (unique-label)])
-            (Pred test #f Lf^
-              (Pred conseq Lt Lf
-                (cons Lf^
-                  (Pred altern Lt Lf ac)))))])] 
-      [(seq e0 e1)
-       (Effect e0 (Pred e1 Lt Lf ac))]
-      [(new-frame)
-       (NonTail x (do-simple-test eax Lt Lf ac))]
-      [else (error 'Pred "invalid expression ~s" x)]))
-  (define (idx->frame-loc i)
-    (mem (fx* i (fx- 0 wordsize)) fpr))
-  (define (Effect x ac)
-   (record-case x
-     [(constant) ac]
-     [(primcall op rand*)
-      (do-effect-prim op rand* ac)]
-     [(conditional test conseq altern)
-      (let* ([Ljoin (unique-label)]
-             [ac (cons Ljoin ac)]
-             [altern-ac (Effect altern ac)])
-        (cond
-          [(eq? altern-ac ac) ;; altern is nop
-           (let* ([conseq-ac (Effect conseq ac)])
-             (cond
-               [(eq? conseq-ac ac) ;; conseq is nop too!
-                (Effect test ac)]
-               [else  ; "when" pattern
-                (Pred test #f Ljoin conseq-ac)]))]
-          [else 
-           (let* ([Lf (unique-label)]
-                  [nac (list* (jmp Ljoin) Lf altern-ac)]
-                  [conseq-ac (Effect conseq nac)])
-             (cond
-               [(eq? conseq-ac nac) ;; "unless" pattern"
-                (Pred test Ljoin #f altern-ac)]
-               [else
-                (Pred test #f Lf conseq-ac)]))]))]
-;;;  [(conditional test conseq altern)
-;;;   (let ([Lf (unique-label)] [Ljoin (unique-label)])
-;;;     (Pred test #f Lf
-;;;       (Effect conseq
-;;;         (list* (jmp Ljoin) Lf (Effect altern (cons Ljoin ac))))))]
-     [(seq e0 e1)
-      (Effect e0 (Effect e1 ac))]
-     [(fix lhs* rhs* body)
-      (do-fix lhs* rhs* (Effect body ac))]
-     [(assign loc val)
-      (record-case loc
-        [(frame-var i)
-         (record-case val
-           [(constant c) 
-            (cons (movl (constant-val c) (idx->frame-loc i)) ac)]
-           [else
-            (NonTail val
-              (cons (movl eax (idx->frame-loc i)) ac))])]
-        [else (error who "invalid assign loc ~s" loc)])]
-     [(eval-cp check body)
-      (cond
-        [check
-         (NonTail body
-           (list* 
-             (movl eax cpr)
-             (andl (int closure-mask) eax)
-             (cmpl (int closure-tag) eax)
-             (jne (label SL_nonprocedure))
-             ac))]
-        [(primref? body)
-         (list* (movl (primref-loc (primref-name body)) cpr) ac)]
-        [else
-         (NonTail body (list* (movl eax cpr) ac))])]
-     [(save-cp loc)
-      (record-case loc
-        [(frame-var i)
-         (cons (movl cpr (idx->frame-loc i)) ac)]
-        [else (error who "invalid cpr loc ~s" x)])]
-     [(new-frame) (NonTail x ac)]
-     [(frame-var) ac]
-     [else (error 'Effect "invalid expression ~s" x)]))
-  (define (Tail x ac) 
-    (record-case x
-     [(return x) 
-      (NonTail x (cons (ret) ac))]
-     [(conditional test conseq altern)
-      (let ([L (unique-label)])
-        (Pred test #f L
-          (Tail conseq 
-            (cons L (Tail altern ac)))))]
-     [(seq e0 e1)
-      (Effect e0 (Tail e1 ac))]
-     [(fix lhs* rhs* body)
-      (do-fix lhs* rhs* (Tail body ac))]
-     [(new-frame idx size body)
-      (Tail body ac)]
-     [(tailcall-cp call-convention argc)
-      (list* 
-        (movl (int (argc-convention argc)) eax)
-        (case call-convention
-          [(normal) (tail-indirect-cpr-call)]
-          [(apply)  (jmp (label SL_apply))]
-          [else 
-           (error who "invalid tail-call convention ~s" call-convention)])
-        ac)]
-;;;     [(call-cp call-convention rp-convention idx argc mask)
-;;;      (unless (eq? rp-convention 'tail)
-;;;        (error who "nontail rp (~s) in tail context" rp-convention))
-;;;      (let f ([i 0])
-;;;        (cond
-;;;          [(fx= i argc)
-;;;           (case call-convention
-;;;             [(normal) 
-;;;              (list* 
-;;;                (movl (int (argc-convention argc)) eax)
-;;;                (tail-indirect-cpr-call)
-;;;                ac)]
-;;;             [(apply)
-;;;              (list* 
-;;;                (movl (int (argc-convention argc)) eax)
-;;;                (jmp (label SL_apply)) 
-;;;                ac)]
-;;;             [else
-;;;              (error who "invalid conv ~s in tail call-cpr" call-convention)])]
-;;;          [else
-;;;            (list* (movl (mem (fx* (fx+ idx (fxadd1 i))
-;;;                                   (fx- 0 wordsize)) fpr)
-;;;                         eax)
-;;;                   (movl eax (mem (fx* (fx+ i 1) (fx- 0 wordsize)) fpr))
-;;;                   (f (fxadd1 i)))]))]
-     [else (error 'Tail "invalid expression ~s" x)]))
-  (define (handle-vararg fml-count ac)
-    (define CONTINUE_LABEL (unique-label))
-    (define DONE_LABEL (unique-label))
-    (define CONS_LABEL (unique-label))
-    (define LOOP_HEAD (unique-label))
-    (define L_CALL (unique-label))
-    (list* (cmpl (int (argc-convention (fxsub1 fml-count))) eax)
-           (jg (label SL_invalid_args))
-           (jl CONS_LABEL)
-           (movl (int nil) ebx)
-           (jmp DONE_LABEL)
-           CONS_LABEL
-           (movl (pcb-ref 'allocation-redline) ebx)
-           (addl eax ebx)
-           (addl eax ebx)
-           (cmpl ebx apr)
-           (jle LOOP_HEAD)
-           ; overflow
-           (addl eax esp) ; advance esp to cover args
-           (pushl cpr)    ; push current cp
-           (pushl eax)    ; push argc
-           (negl eax)     ; make argc positive
-           (addl (int (fx* 4 wordsize)) eax) ; add 4 words to adjust frame size
-           (pushl eax)    ; push frame size
-           (addl eax eax) ; double the number of args
-           (movl eax (mem (fx* -2 wordsize) fpr)) ; pass it as first arg
-           (movl (int (argc-convention 1)) eax) ; setup argc
-           (movl (primref-loc 'do-vararg-overflow) cpr) ; load handler
-           (jmp L_CALL)   ; go to overflow handler
-           ; NEW FRAME
-           (int 0)        ; if the framesize=0, then the framesize is dynamic
-           '(current-frame-offset)
-           (int 0)        ; multiarg rp
-           (byte 0)
-           (byte 0)
-           L_CALL
-           (indirect-cpr-call)
-           (popl eax)     ; pop framesize and drop it
-           (popl eax)     ; reload argc
-           (popl cpr)     ; reload cp
-           (subl eax fpr) ; readjust fp
-           LOOP_HEAD
-           (movl (int nil) ebx)
-           CONTINUE_LABEL
-           (movl ebx (mem disp-cdr apr))
-           (movl (mem fpr eax) ebx)
-           (movl ebx (mem disp-car apr))
-           (movl apr ebx)
-           (addl (int pair-tag) ebx)
-           (addl (int pair-size) apr)
-           (addl (int (fxsll 1 fx-shift)) eax)
-           (cmpl (int (fx- 0 (fxsll fml-count fx-shift))) eax)
-           (jle CONTINUE_LABEL)
-           DONE_LABEL
-           (movl ebx (mem (fx- 0 (fxsll fml-count fx-shift)) fpr))
-           ac))
-  (define (Entry check? x ac)
-    (record-case x
-      [(clambda-case fml* proper body)
-       (let ([ac (Tail body ac)])
-         (cond
-           [(and proper check?)
-            (list* (cmpl (int (argc-convention (length fml*))) eax)
-                   (jne (label SL_invalid_args))
-                   ac)]
-           [proper ac]
-           [else
-            (handle-vararg (length fml*) ac)]))]))
-  (define make-dispatcher
-    (lambda (j? L L* x x* ac)
-      (cond
-        [(null? L*) (if j? (cons (jmp (label L)) ac) ac)]
-        [else
-         (record-case x
-           [(clambda-case fml* proper _)
-            (cond
-              [proper
-               (list* (cmpl (int (argc-convention (length fml*))) eax)
-                      (je (label L))
-                      (make-dispatcher #t 
-                        (car L*) (cdr L*) (car x*) (cdr x*) ac))]
-              [else
-               (list* (cmpl (int (argc-convention (fxsub1 (length fml*)))) eax)
-                      (jle (label L))
-                      (make-dispatcher #t
-                        (car L*) (cdr L*) (car x*) (cdr x*) ac))])])])))
-  (define (handle-cases x x*)
-    (let ([L* (map (lambda (_) (gensym)) x*)]
-          [L (gensym)])
-      (make-dispatcher #f L L* x x*
-        (let f ([x x] [x* x*] [L L] [L* L*])
-          (cond
-            [(null? x*) 
-             (cons (label L) (Entry 'check x '()))]
-            [else
-             (cons (label L)
-               (Entry #f x
-                 (f (car x*) (cdr x*) (car L*) (cdr L*))))])))))
-  (define (CodeExpr x)
-    (record-case x
-      [(clambda-code L cases free)
-       (list*
-         (length free)
-         (label L)
-         (handle-cases (car cases) (cdr cases)))]))
-  (record-case x
-    [(codes list body)
-     (cons (cons 0 (Tail body '()))
-           (map CodeExpr list))]))
-
-
-(define SL_nonprocedure (gensym "SL_nonprocedure"))
-
-(define SL_top_level_value_error (gensym "SL_top_level_value_error"))
-(define SL_car_error (gensym "SL_car_error"))
-(define SL_cdr_error (gensym "SL_cdr_error"))
-
-(define SL_invalid_args (gensym "SL_invalid_args"))
-(define SL_foreign_call (gensym "SL_foreign_call"))
-(define SL_continuation_code (gensym "SL_continuation_code"))
-(define SL_multiple_values_error_rp (gensym "SL_multiple_values_error_rp"))
-(define SL_multiple_values_ignore_rp (gensym "SL_multiple_ignore_error_rp"))
-(define SL_underflow_multiple_values (gensym "SL_underflow_multiple_values"))
-(define SL_underflow_handler (gensym "SL_underflow_handler"))
-(define SL_scheme_exit (gensym "SL_scheme_exit"))
-(define SL_apply (gensym "SL_apply"))
-(define SL_values (gensym "SL_values"))
-(define SL_call_with_values (gensym "SL_call_with_values"))
-
-(module ()
-(list*->code*
-  (list
-    (list 0
-          (label SL_car_error)
-          (movl ebx (mem (fx- 0 wordsize) fpr))
-          (movl (primref-loc 'car-error) cpr)
-          (movl (int (argc-convention 1)) eax)
-          (tail-indirect-cpr-call))
-
-    (list 0
-          (label SL_cdr_error)
-          (movl ebx (mem (fx- 0 wordsize) fpr))
-          (movl (primref-loc 'cdr-error) cpr)
-          (movl (int (argc-convention 1)) eax)
-          (tail-indirect-cpr-call))
-
-    (list 0
-          (label SL_top_level_value_error)
-          (movl ebx (mem (fx- 0 wordsize) fpr))
-          (movl (primref-loc 'top-level-value-error) cpr)
-          (movl (int (argc-convention 1)) eax)
-          (tail-indirect-cpr-call))
-
-    (let ([L_cwv_done (gensym)]
-          [L_cwv_loop (gensym)]
-          [L_cwv_multi_rp (gensym)]
-          [L_cwv_call (gensym)])
-      (list 
-          0 ; no free vars
-          (label SL_call_with_values)
-          (cmpl (int (argc-convention 2)) eax)
-          (jne (label SL_invalid_args))
-          (movl (mem (fx- 0 wordsize) fpr) ebx) ; producer
-          (movl ebx cpr)
-          (andl (int closure-mask) ebx)
-          (cmpl (int closure-tag) ebx)
-          (jne (label SL_nonprocedure))
-          (movl (int (argc-convention 0)) eax)
-          (subl (int (fx* wordsize 2)) fpr)
-          (jmp (label L_cwv_call))
-          ; MV NEW FRAME
-          (byte-vector '#(#b110))
-          (int (fx* wordsize 3))
-           '(current-frame-offset)
-          (label-address L_cwv_multi_rp)
-          (byte 0)
-          (byte 0)
-          (label L_cwv_call)
-          (indirect-cpr-call)
-          ;;; one value returned
-          (addl (int (fx* wordsize 2)) fpr)
-          (movl (mem (fx* -2 wordsize) fpr) ebx) ; consumer
-          (movl ebx cpr)
-          (movl eax (mem (fx- 0 wordsize) fpr))
-          (movl (int (argc-convention 1)) eax)
-          (andl (int closure-mask) ebx)
-          (cmpl (int closure-tag) ebx)
-          (jne (label SL_nonprocedure))
-          (tail-indirect-cpr-call)
-          ;;; multiple values returned
-          (label L_cwv_multi_rp)
-          ; because values does not pop the return point
-          ; we have to adjust fp one more word here
-          (addl (int (fx* wordsize 3)) fpr) 
-          (movl (mem (fx* -2 wordsize) fpr) cpr) ; consumer
-          (cmpl (int (argc-convention 0)) eax)
-          (je (label L_cwv_done))
-          (movl (int (fx* -4 wordsize)) ebx)
-          (addl fpr ebx)  ; ebx points to first value
-          (movl ebx ecx)
-          (addl eax ecx)  ; ecx points to the last value
-          (label L_cwv_loop)
-          (movl (mem 0 ebx) edx)
-          (movl edx (mem (fx* 3 wordsize) ebx))
-          (subl (int wordsize) ebx)
-          (cmpl ecx ebx)
-          (jge (label L_cwv_loop))
-          (label L_cwv_done)
-          (movl cpr ebx)
-          (andl (int closure-mask) ebx)
-          (cmpl (int closure-tag) ebx)
-          (jne (label SL_nonprocedure))
-          (tail-indirect-cpr-call)))
-
-    (let ([L_values_one_value (gensym)]
-          [L_values_many_values (gensym)])
-      (list 0 ; no freevars
-          (label SL_values)
-          (cmpl (int (argc-convention 1)) eax)
-          (je (label L_values_one_value))
-          (label L_values_many_values)
-          (movl (mem 0 fpr) ebx) ; return point
-          (jmp (mem disp-multivalue-rp ebx))     ; go
-          (label L_values_one_value)
-          (movl (mem (fx- 0 wordsize) fpr) eax)
-          (ret)))
-
-    (let ([L_apply_done (gensym)]
-          [L_apply_loop (gensym)])
-      (list 0 
-          (label SL_apply)
-          (movl (mem fpr eax) ebx)
-          (cmpl (int nil) ebx)
-          (je (label L_apply_done))
-          (label L_apply_loop)
-          (movl (mem (fx- disp-car pair-tag) ebx) ecx)
-          (movl (mem (fx- disp-cdr pair-tag) ebx) ebx)
-          (movl ecx (mem fpr eax))
-          (subl (int wordsize) eax)
-          (cmpl (int nil) ebx)
-          (jne (label L_apply_loop))
-          (label L_apply_done)
-          (addl (int wordsize) eax)
-          (tail-indirect-cpr-call)))
-
-    (list 0
-          (label SL_nonprocedure)
-          (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg
-          (movl (primref-loc '$apply-nonprocedure-error-handler) cpr)
-          (movl (int (argc-convention 1)) eax)
-          (tail-indirect-cpr-call))
-
-    (list 0
-          (label SL_multiple_values_error_rp)
-          (movl (primref-loc '$multiple-values-error) cpr)
-          (tail-indirect-cpr-call))
-
-    (list 0
-          (label SL_multiple_values_ignore_rp)
-          (ret))
-
-    (list 0
-          (label SL_invalid_args)
-          ;;;
-          (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg
-          (negl eax)
-          (movl eax (mem (fx- 0 (fx* 2 wordsize)) fpr))
-          (movl (primref-loc '$incorrect-args-error-handler) cpr)
-          (movl (int (argc-convention 2)) eax)
-          (tail-indirect-cpr-call))
-
-    (let ([Lset (gensym)] [Lloop (gensym)])
-      (list 0
-          (label SL_foreign_call)
-          (movl fpr (pcb-ref 'frame-pointer))
-          (movl apr (pcb-ref 'allocation-pointer))
-          (movl fpr ebx)
-          (movl (pcb-ref 'system-stack) esp)
-          (pushl pcr)
-          (cmpl (int 0) eax)
-          (je (label Lset))
-          (label Lloop)
-          (movl (mem ebx eax) ecx)
-          (pushl ecx)
-          (addl (int 4) eax)
-          (cmpl (int 0) eax)
-          (jne (label Lloop))
-          (label Lset)
-          ; FOREIGN NEW FRAME
-          (call cpr)
-          (movl (pcb-ref 'frame-pointer) fpr)
-          (movl (pcb-ref 'allocation-pointer) apr)
-          (ret)))
-
-    (let ([L_cont_zero_args      (gensym)] 
-          [L_cont_mult_args      (gensym)]
-          [L_cont_one_arg        (gensym)]
-          [L_cont_mult_move_args (gensym)]
-          [L_cont_mult_copy_loop (gensym)])
-      (list  1 ; freevars
-          (label SL_continuation_code)
-          (movl (mem (fx- disp-closure-data closure-tag) cpr) ebx) ; captured-k
-          (movl ebx (pcb-ref 'next-continuation)) ; set
-          (movl (pcb-ref 'frame-base) ebx)
-          (cmpl (int (argc-convention 1)) eax)
-          (jg (label L_cont_zero_args))
-          (jl (label L_cont_mult_args))
-          (label L_cont_one_arg)
-          (movl (mem (fx- 0 wordsize) fpr) eax)
-          (movl ebx fpr)
-          (subl (int wordsize) fpr)
-          (ret)
-          (label L_cont_zero_args)
-          (subl (int wordsize) ebx)
-          (movl ebx fpr)
-          (movl (mem 0 ebx) ebx) ; return point
-          (jmp (mem disp-multivalue-rp ebx))  ; go
-          (label L_cont_mult_args)
-          (subl (int wordsize) ebx)
-          (cmpl ebx fpr)
-          (jne (label L_cont_mult_move_args))
-          (movl (mem 0 ebx) ebx)
-          (jmp (mem disp-multivalue-rp ebx))
-          (label L_cont_mult_move_args)
-          ; move args from fpr to ebx
-          (movl (int 0) ecx)
-          (label L_cont_mult_copy_loop)
-          (subl (int wordsize) ecx)
-          (movl (mem fpr ecx) edx)
-          (movl edx (mem ebx ecx))
-          (cmpl ecx eax)
-          (jne (label L_cont_mult_copy_loop))
-          (movl ebx fpr)
-          (movl (mem 0 ebx) ebx)
-          (jmp (mem disp-multivalue-rp ebx))
-          ))
-    )))
-
-
-
-(define (compile-expr expr)
-  (let* ([p (recordize expr)]
-         [p (optimize-direct-calls p)]
-;;;         [foo (analyze-cwv p)]
-         [p (optimize-letrec p)]
-         ;[p (remove-letrec p)]
-         [p (remove-assignments p)]
-         [p (convert-closures p)]
-         [p (lift-codes p)]
-         [p (introduce-primcalls p)]
-         [p (simplify-operands p)]
-         [p (insert-stack-overflow-checks p)]
-         [p (insert-allocation-checks p)]
-         [p (remove-local-variables p)]
-         [p (optimize-ap-check p)]
-         [ls* (generate-code p)]
-         [f (when (assembler-output)
-              (for-each 
-                (lambda (ls)
-                  (for-each (lambda (x) (printf "    ~s\n" x)) ls))
-                ls*))]
-         [code* (list*->code* ls*)])
-    (car code*)))
-
-(define compile-file
-  (lambda (input-file output-file . rest)
-    (let ([ip (open-input-file input-file)]
-          [op (apply open-output-file output-file rest)])
-      (let f ()
-        (let ([x (read ip)])
-          (unless (eof-object? x)
-            (fasl-write (compile-expr (expand x)) op)
-            (f))))
-      (close-input-port ip)
-      (close-output-port op))))
-
-(primitive-set! 'compile-file compile-file)
-(primitive-set! 'assembler-output (make-parameter #f))
-(primitive-set! 'compile
-  (lambda (x)
-    (let ([code (compile-expr (expand x))])
-      (let ([proc ($code->closure code)])
-        (proc)))))
-
-)
-
diff --git a/src/libcompile-9.1.ss b/src/libcompile.ss
similarity index 100%
rename from src/libcompile-9.1.ss
rename to src/libcompile.ss
diff --git a/src/libcontrol-6.1.ss b/src/libcontrol.ss
similarity index 100%
rename from src/libcontrol-6.1.ss
rename to src/libcontrol.ss
diff --git a/src/libcore-6.9.ss b/src/libcore.ss
similarity index 100%
rename from src/libcore-6.9.ss
rename to src/libcore.ss
diff --git a/src/libcxr-6.0.ss b/src/libcxr.ss
similarity index 100%
rename from src/libcxr-6.0.ss
rename to src/libcxr.ss
diff --git a/src/libfasl-6.7.ss b/src/libfasl.ss
similarity index 100%
rename from src/libfasl-6.7.ss
rename to src/libfasl.ss
diff --git a/src/libhandlers-6.9.ss b/src/libhandlers.ss
similarity index 100%
rename from src/libhandlers-6.9.ss
rename to src/libhandlers.ss
diff --git a/src/libhash-6.2.ss b/src/libhash-6.2.ss
deleted file mode 100644
index 3692620..0000000
--- a/src/libhash-6.2.ss
+++ /dev/null
@@ -1,207 +0,0 @@
-
-(let ([hash-rtd (make-record-type '"hash-table" '(hash-vec count tc))])
-  ;;; accessors
-  (define get-vec (record-field-accessor hash-rtd 0))
-  (define set-vec! (record-field-mutator hash-rtd 0))
-  (define get-count (record-field-accessor hash-rtd 1))
-  (define set-count! (record-field-mutator hash-rtd 1))
-  (define get-tc (record-field-accessor hash-rtd 2))
-  ;;; implementation
-
-  ;;; directly from Dybvig's paper
-  (define tc-pop
-    (lambda (tc)
-      (let ([x ($car tc)])
-        (if (eq? x ($cdr tc))
-            #f
-            (let ([v ($car x)])
-              ($set-car! tc ($cdr x))
-              ($set-car! x #f)
-              ($set-cdr! x #f)
-              v)))))
-
-  (define inthash
-    (lambda (key)
-      ;static int inthash(int key) { /* from Bob Jenkin's */
-      ;  key += ~(key << 15);
-      ;  key ^=  (key >> 10);
-      ;  key +=  (key << 3);
-      ;  key ^=  (key >> 6);
-      ;  key += ~(key << 11);
-      ;  key ^=  (key >> 16);
-      ;  return key;
-      ;}
-      (let* ([key ($fx+ key ($fxlognot ($fxsll key 15)))]
-             [key ($fxlogxor key ($fxsra key 10))]
-             [key ($fx+ key ($fxsll key 3))]
-             [key ($fxlogxor key ($fxsra key 6))]
-             [key ($fx+ key ($fxlognot ($fxsll key 11)))]
-             [key ($fxlogxor key ($fxsra key 16))])
-        key)))
-
-  ;;; assq-like lookup
-  (define direct-lookup 
-    (lambda (x b)
-      (if (fixnum? b)
-          #f
-          (if (eq? x ($tcbucket-key b))
-              b
-              (direct-lookup x ($tcbucket-next b))))))
-
-  (define rehash-lookup
-    (lambda (h tc x)
-      (cond
-        [(tc-pop tc) =>
-         (lambda (b)
-           (re-add! h b)
-           (if (eq? x ($tcbucket-key b))
-               b
-               (rehash-lookup h tc x)))]
-        [else #f])))
-
-  (define get-bucket-index
-    (lambda (b)
-      (let ([next ($tcbucket-next b)])
-        (if (fixnum? next)
-            next
-            (get-bucket-index next)))))
-
-  (define replace!
-    (lambda (lb x y)
-      (let ([n ($tcbucket-next lb)])
-        (cond
-          [(eq? n x) 
-           ($set-tcbucket-next! lb y)
-           (void)]
-          [else
-           (replace! n x y)]))))
-
-  (define re-add! 
-    (lambda (h b)
-      (let ([vec (get-vec h)]
-            [next ($tcbucket-next b)])
-        ;;; first remove it from its old place
-        (let ([idx 
-               (if (fixnum? next)
-                   next
-                   (get-bucket-index next))])
-          (let ([fst ($vector-ref vec idx)])
-            (cond
-              [(eq? fst b) 
-               ($vector-set! vec idx next)]
-              [else 
-               (replace! fst b next)])))
-        ;;; reset the tcbucket-tconc FIRST
-        ($set-tcbucket-tconc! b (get-tc h))
-        ;;; then add it to the new place
-        (let ([k ($tcbucket-key b)])
-          (let ([ih (inthash (pointer-value k))])
-            (let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
-              (let ([n ($vector-ref vec idx)])
-                ($set-tcbucket-next! b n)
-                ($vector-set! vec idx b)
-                (void))))))))
-
-  (define get-hash
-    (lambda (h x v)
-      (let ([pv (pointer-value x)]
-            [vec (get-vec h)])
-        (let ([ih (inthash pv)])
-          (let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
-            (let ([b ($vector-ref vec idx)])
-              (cond
-                [(or (direct-lookup x b) (rehash-lookup h (get-tc h) x))
-                 =>
-                 (lambda (b) 
-                   ($tcbucket-val b))]
-                [else v])))))))
-  
-  (define put-hash!
-    (lambda (h x v)
-      (let ([pv (pointer-value x)]
-            [vec (get-vec h)])
-        (let ([ih (inthash pv)])
-          (let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
-            (let ([b ($vector-ref vec idx)])
-              (cond
-                [(or (direct-lookup x b) (rehash-lookup h (get-tc h) x))
-                 =>
-                 (lambda (b) 
-                   ($set-tcbucket-val! b v)
-                   (void))]
-                [else 
-                 (let ([bucket
-                        ($make-tcbucket (get-tc h) x v ($vector-ref vec idx))])
-                   (if ($fx= (pointer-value x) pv)
-                       ($vector-set! vec idx bucket)
-                       (let* ([ih (inthash (pointer-value x))]
-                              [idx 
-                               ($fxlogand ih ($fx- ($vector-length vec) 1))])
-                         ($set-tcbucket-next! bucket ($vector-ref vec idx))
-                         ($vector-set! vec idx bucket))))
-                 (let ([ct (get-count h)])
-                   (set-count! h ($fxadd1 ct))
-                   (when ($fx> ct ($vector-length vec))
-                     (enlarge-table h)))])))))))
-
-  (define insert-b
-    (lambda (b vec mask)
-      (let* ([x ($tcbucket-key b)]
-             [pv (pointer-value x)]
-             [ih (inthash pv)]
-             [idx ($fxlogand ih mask)]
-             [next ($tcbucket-next b)])
-        ($set-tcbucket-next! b ($vector-ref vec idx))
-        ($vector-set! vec idx b)
-        (unless (fixnum? next)
-          (insert-b next vec mask)))))
-
-  (define move-all
-    (lambda (vec1 i n vec2 mask)
-      (unless ($fx= i n)
-        (let ([b ($vector-ref vec1 i)])
-          (unless (fixnum? b)
-            (insert-b b vec2 mask))
-          (move-all vec1 ($fxadd1 i) n vec2 mask)))))
-
-  (define enlarge-table
-    (lambda (h)
-      (let* ([vec1 (get-vec h)]
-             [n1 ($vector-length vec1)]
-             [n2 ($fxsll n1 1)]
-             [vec2 (make-base-vec n2)])
-        (move-all vec1 0 n1 vec2 ($fx- n2 1))
-        (set-vec! h vec2))))
-
-
-
-  (define init-vec
-    (lambda (v i n)
-      (if ($fx= i n)
-          v
-          (begin
-            ($vector-set! v i i)
-            (init-vec v ($fxadd1 i) n)))))
-
-  (define make-base-vec
-    (lambda (n)
-      (init-vec (make-vector n) 0 n)))
-
-  ;;; public interface
-  (primitive-set! 'hash-table? (record-predicate hash-rtd))
-  (primitive-set! 'make-hash-table
-    (let ([make (record-constructor hash-rtd)])
-      (lambda ()
-        (let ([x (cons #f #f)])
-          (let ([tc (cons x x)])
-            (make (make-base-vec 32) 0 tc))))))
-  (primitive-set! 'get-hash-table
-    (lambda (h x v)
-      (if (hash-table? h)
-          (get-hash h x v)
-          (error 'get-hash-table "~s is not a hash table" h))))
-  (primitive-set! 'put-hash-table!
-    (lambda (h x v)
-      (if (hash-table? h)
-          (put-hash! h x v)
-          (error 'put-hash-table! "~s is not a hash table" h)))))
diff --git a/src/libhash-9.2.ss b/src/libhash.ss
similarity index 100%
rename from src/libhash-9.2.ss
rename to src/libhash.ss
diff --git a/src/libintelasm-6.9.ss b/src/libintelasm.ss
similarity index 100%
rename from src/libintelasm-6.9.ss
rename to src/libintelasm.ss
diff --git a/src/libinterpret-6.5.ss b/src/libinterpret.ss
similarity index 100%
rename from src/libinterpret-6.5.ss
rename to src/libinterpret.ss
diff --git a/src/libnumerics-9.1.ss b/src/libnumerics.ss
similarity index 100%
rename from src/libnumerics-9.1.ss
rename to src/libnumerics.ss
diff --git a/src/libposix-6.0.ss b/src/libposix.ss
similarity index 100%
rename from src/libposix-6.0.ss
rename to src/libposix.ss
diff --git a/src/librecord-6.4.ss b/src/librecord.ss
similarity index 100%
rename from src/librecord-6.4.ss
rename to src/librecord.ss
diff --git a/src/libtokenizer-6.1.ss b/src/libtokenizer-6.1.ss
deleted file mode 100644
index dfb66e8..0000000
--- a/src/libtokenizer-6.1.ss
+++ /dev/null
@@ -1,513 +0,0 @@
-(let ()
-  (define char-whitespace?
-    (lambda (c)
-      (or ($char= #\space c)
-          (memq ($char->fixnum c) '(9 10 11 12 13))))) 
-  (define delimiter?
-    (lambda (c)
-      (or (char-whitespace? c)
-          (memq c '(#\( #\) #\[ #\] #\' #\` #\, #\")))))
-  (define digit?
-    (lambda (c)
-      (and ($char<= #\0 c) ($char<= c #\9))))
-  (define char->num
-    (lambda (c)
-      (fx- ($char->fixnum c) ($char->fixnum #\0))))
-  (define initial?
-    (lambda (c)
-      (or (letter? c) (special-initial? c))))
-  (define letter? 
-    (lambda (c)
-      (or (and ($char<= #\a c) ($char<= c #\z))
-          (and ($char<= #\A c) ($char<= c #\Z)))))
-  (define af? 
-    (lambda (c)
-      (or (and ($char<= #\a c) ($char<= c #\f))
-          (and ($char<= #\A c) ($char<= c #\F)))))
-  (define af->num
-    (lambda (c)
-      (if (and ($char<= #\a c) ($char<= c #\f))
-          (fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\a)))
-          (fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\A))))))
-  (define special-initial?
-    (lambda (c)
-      (memq c '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~))))
-  (define subsequent?
-    (lambda (c)
-      (or (initial? c) (digit? c) (special-subsequent? c))))
-  (define special-subsequent?
-    (lambda (c)
-      (memq c '(#\+ #\- #\. #\@))))
-  (define tokenize-number
-    (lambda (n p)
-      (let ([c (read-char p)])
-        (cond
-         [(eof-object? c) n]
-         [(digit? c)
-          (tokenize-number (fx+ (fx* n 10) (char->num c)) p)]
-         [(delimiter? c)
-          (unread-char c p)
-          n]
-         [else
-          (unread-char c p)
-          (error 'tokenize "invalid number syntax: ~a~a" n c)]))))
-  (define tokenize-hex
-    (lambda (n p)
-      (let ([c (read-char p)])
-        (cond
-         [(eof-object? c) n]
-         [(digit? c)
-          (tokenize-hex (fx+ (fx* n 16) (char->num c)) p)]
-         [(af? c)
-          (tokenize-hex (fx+ (fx* n 16) (af->num c)) p)]
-         [(delimiter? c)
-          (unread-char c p)
-          n]
-         [else
-          (unread-char c p)
-          (error 'tokenize "invalid hex number sequence: ~a~a" n c)]))))
-  (define tokenize-hex-init
-    (lambda (p)
-      (let ([c (read-char p)])
-        (cond
-         [(eof-object? c) 
-          (unread-char c p) 
-          (error 'tokenize "invalid #x near end of file")]
-         [(digit? c)
-          (cons 'datum (tokenize-hex (char->num c) p))]
-         [(af? c)
-          (cons 'datum (tokenize-hex (af->num c) p))]
-         [($char= c #\-)
-          (cons 'datum (fx- 0 (tokenize-hex 0 p)))]
-         [($char= c #\+)
-          (cons 'datum (tokenize-hex 0 p))]
-         [else
-          (unread-char c p)
-          (error 'tokenize "invalid number syntax: #x~a" c)]))))
-  (define tokenize-identifier
-    (lambda (ls p)
-      (let ([c (read-char p)])
-        (cond
-         [(eof-object? c) ls]
-         [(subsequent? c)
-          (tokenize-identifier (cons c ls) p)]
-         [(delimiter? c)
-          (unread-char c p)
-          ls]
-         [else
-          (unread-char c p)
-          (error 'tokenize "invalid identifier syntax: ~a" 
-                 (list->string (reverse (cons c ls))))]))))
-  (define tokenize-string
-    (lambda (ls p)
-      (let ([c (read-char p)])
-        (cond
-         [(eof-object? c) 
-          (error 'tokenize "end-of-file while inside a string")]
-         [($char= #\" c)  ls]
-         [($char= #\\ c) 
-          (let ([c (read-char p)])
-            (cond
-              [($char= #\" c) (tokenize-string (cons #\" ls) p)]
-              [($char= #\\ c) (tokenize-string (cons #\\ ls) p)]
-              [($char= #\n c) (tokenize-string (cons #\newline ls) p)]
-              [($char= #\t c) (tokenize-string (cons #\tab ls) p)]
-              [else (error 'tokenize "invalid string escape \\~a" c)]))]
-         [else
-          (tokenize-string (cons c ls) p)]))))
-  (define skip-comment
-    (lambda (p)
-      (let ([c (read-char p)])
-        (unless (eof-object? c)
-          (let ([i ($char->fixnum c)])
-            (unless (or (fx= i 10) (fx= i 13))
-              (skip-comment p)))))))
-  (define tokenize-plus
-    (lambda (p)
-      (let ([c (peek-char p)])
-        (cond
-          [(eof-object? c) '(datum . +)]
-          [(delimiter? c)  '(datum . +)]
-          [(digit? c) 
-           (read-char p)
-           (cons 'datum (tokenize-number (char->num c) p))]
-          [else (error 'tokenize "invalid sequence +~a" c)]))))
-  (define tokenize-minus
-    (lambda (p)
-      (let ([c (peek-char p)])
-        (cond
-          [(eof-object? c) '(datum . -)]
-          [(delimiter? c)  '(datum . -)]
-          [(digit? c) 
-           (read-char p)
-           (cons 'datum (fx- 0 (tokenize-number (char->num c) p)))]
-          [else (error 'tokenize "invalid sequence -~a" c)]))))
-  (define tokenize-dot
-    (lambda (p)
-      (let ([c (peek-char p)])
-        (cond
-          [(eof-object? c) 'dot]
-          [(delimiter? c)  'dot]
-          [($char= c #\.)  ; this is second dot
-           (read-char p)
-           (let ([c (read-char p)])
-             (cond
-               [(eof-object? c) 
-                (error 'tokenize "invalid syntax .. near end of file")]
-               [($char= c #\.) ; this is the third
-                (let ([c (peek-char p)])
-                  (cond
-                   [(eof-object? c) '(datum . ...)]
-                   [(delimiter? c)  '(datum . ...)]
-                   [else 
-                    (error 'tokenize "invalid syntax ...~a" c)]))]
-               [else
-                (unread-char c)
-                (error 'tokenize "invalid syntax ..~a" c)]))]
-          [else
-           (error 'tokenize "invalid syntax .~a" c)]))))
-  (define tokenize-char* 
-    (lambda (i str p d)
-      (cond
-       [(fx= i (string-length str))
-        (let ([c (peek-char p)])
-          (cond
-           [(eof-object? c) d]
-           [(delimiter? c)  d]
-           [else (error 'tokenize "invalid character after #\\~a" str)]))]
-       [else
-        (let ([c (read-char p)])
-          (cond
-            [(eof-object? c) 
-             (error 'tokenize "invalid eof in the middle of #\\~a" str)]
-            [($char= c (string-ref str i))
-             (tokenize-char* (fxadd1 i) str p d)]
-            [else 
-             (error 'tokenize
-                    "invalid char ~a while scanning #\\~a" c str)]))])))
-  (define tokenize-char-seq
-    (lambda (p str d)
-      (let ([c (peek-char p)])
-        (cond
-          [(eof-object? c) (cons 'datum (string-ref str 0))]
-          [(delimiter? c)  (cons 'datum (string-ref str 0))]
-          [($char= (string-ref str 1) c) 
-           (read-char p)
-           (tokenize-char*  2 str p d)]
-          [else (error 'tokenize "invalid syntax near #\\~a~a" 
-                       (string-ref str 0) c)]))))
-  (define tokenize-char
-    (lambda (p)
-      (let ([c (read-char p)])
-        (cond
-          [(eof-object? c)
-           (error 'tokenize "invalid #\\ near end of file")]
-          [($char= #\s c) 
-           (tokenize-char-seq p "space" '(datum . #\space))]
-          [($char= #\n c) 
-           (tokenize-char-seq p "newline" '(datum . #\newline))]
-          [($char= #\t c) 
-           (tokenize-char-seq p "tab" '(datum . #\tab))]
-          [($char= #\r c) 
-           (tokenize-char-seq p "return" '(datum . #\return))]
-          [else
-           (let ([n (peek-char p)])
-             (cond
-               [(eof-object? n) (cons 'datum c)]
-               [(delimiter? n)  (cons 'datum c)]
-               [else 
-                (error 'tokenize "invalid syntax #\\~a~a" c n)]))]))))
-  (define multiline-error
-    (lambda ()
-      (error 'tokenize
-             "end of file encountered while inside a #|-style comment")))
-  (define multiline-comment
-    (lambda (p)
-      (let ([c (read-char p)])
-        (cond
-          [(eof-object? c) (multiline-error)]
-          [($char= #\| c) 
-           (let ([c (read-char p)])
-             (cond
-               [(eof-object? c) (multiline-error)]
-               [($char= #\# c)   (void)]
-               [else (multiline-comment p)]))]
-          [($char= #\# c)
-           (let ([c (read-char p)])
-             (cond
-               [(eof-object? c) (multiline-error)]
-               [($char= #\| c) 
-                (multiline-comment p)
-                (multiline-comment p)]
-               [else 
-                (multiline-comment p)]))]
-          [else (multiline-comment p)]))))
-  (define read-binary
-    (lambda (ac chars p)
-      (let ([c (read-char p)])
-        (cond
-          [(eof-object? c) ac]
-          [($char= #\0 c) (read-binary (fxsll ac 1) (cons c chars) p)]
-          [($char= #\1 c) (read-binary (fx+ (fxsll ac 1) 1) (cons c chars) p)]
-          [(delimiter? c) (unread-char c p) ac]
-          [else 
-           (unread-char c)
-           (error 'tokenize "invalid syntax #b~a"
-                  (list->string (reverse (cons c chars))))]))))
-  (define tokenize-hash
-    (lambda (p)
-      (let ([c (read-char p)])
-        (cond
-          [(eof-object? c) (error 'tokenize "invalid # near end of file")]
-          [($char= c #\t) 
-           (let ([c (peek-char p)])
-             (cond
-               [(eof-object? c) '(datum . #t)]
-               [(delimiter? c)  '(datum . #t)]
-               [else (error 'tokenize "invalid syntax near #t")]))]
-          [($char= c #\f) 
-           (let ([c (peek-char p)])
-             (cond
-               [(eof-object? c) '(datum . #f)]
-               [(delimiter? c)  '(datum . #f)]
-               [else (error 'tokenize "invalid syntax near #f")]))]
-          [($char= #\\ c) (tokenize-char p)]
-          [($char= #\( c) 'vparen]
-          [($char= #\x c) (tokenize-hex-init p)]
-          [($char= #\' c) '(macro . syntax)]
-          [($char= #\; c) 'hash-semi]
-          [($char= #\% c) '(macro . |#primitive|)]
-          [($char= #\| c) (multiline-comment p) (tokenize p)]
-          [($char= #\b c) 
-           (let ([c (read-char p)])
-             (cond
-               [(eof-object? c) 
-                (error 'tokenize "invalid eof while reading #b")]
-               [($char= #\- c)
-                (let ([c (read-char p)])
-                  (cond
-                    [(eof-object? c)
-                     (error 'tokenize "invalid eof while reading #b-")]
-                    [($char= #\0 c)
-                     (cons 'datum
-                       (fx- 0 (read-binary 0 '(#\0 #\-) p)))]
-                    [($char= #\1 c)
-                     (cons 'datum
-                       (fx- 0 (read-binary 1 '(#\1 #\-) p)))]
-                    [else 
-                     (unread-char c p)
-                     (error 'tokenize "invalid binary syntax #b-~a" c)]))]
-               [($char= #\0 c)
-                (cons 'datum (read-binary 0 '(#\0) p))]
-               [($char= #\1 c)
-                (cons 'datum (read-binary 1 '(#\1) p))]
-               [else 
-                (unread-char c p)
-                (error 'tokenize "invalid syntax #b~a" c)]
-               ))]
-          [($char= #\! c) 
-           (let ([e (read-char p)])
-             (when (eof-object? e)
-               (error 'tokenize "invalid eof near #!"))
-             (unless ($char= #\e e)
-               (error 'tokenize "invalid syntax near #!~a" e))
-             (let ([o (read-char p)])
-               (when (eof-object? o)
-                 (error 'tokenize "invalid eof near #!e"))
-               (unless ($char= #\o o)
-                 (error 'tokenize "invalid syntax near #!e~a" o))
-               (let ([f (read-char p)])
-                 (when (eof-object? f)
-                   (error 'tokenize "invalid syntax near #!eo"))
-                 (unless ($char= #\f f)
-                   (error 'tokenize "invalid syntax near #!eo~a" f))
-                 (cons 'datum (eof-object)))))]
-          [else 
-           (unread-char c p)
-           (error 'tokenize "invalid syntax #~a" c)]))))
-  (define tokenize-bar
-    (lambda (p ac)
-      (let ([c (read-char p)])
-        (cond
-          [(eof-object? c) 
-           (error 'tokenize "unexpected eof while reading symbol")]
-          [($char= #\\ c)
-           (let ([c (read-char p)])
-             (cond
-               [(eof-object? c) 
-                (error 'tokenize "unexpected eof while reading symbol")]
-               [else (tokenize-bar p (cons c ac))]))]
-          [($char= #\| c) ac]
-          [else (tokenize-bar p (cons c ac))]))))
-  (define tokenize
-    (lambda (p)
-      (let ([c (read-char p)])
-        (cond
-          [(eof-object? c) (eof-object)]
-          [(char-whitespace? c) (tokenize p)]
-          [($char= #\( c)   'lparen]
-          [($char= #\) c)   'rparen]
-          [($char= #\[ c)   'lbrack]
-          [($char= #\] c)   'rbrack]
-          [($char= #\' c)   '(macro . quote)]
-          [($char= #\` c)   '(macro . quasiquote)]
-          [($char= #\, c) 
-           (let ([c (peek-char p)])
-             (cond
-              [(eof-object? c) '(macro . unquote)]
-              [($char= c #\@) 
-               (read-char p)
-               '(macro . unquote-splicing)]
-              [else '(macro . unquote)]))]
-          [($char= #\# c) (tokenize-hash p)]
-          [(digit? c) 
-           (cons 'datum (tokenize-number (char->num c) p))]
-          [(initial? c) 
-           (let ([ls (reverse (tokenize-identifier (cons c '()) p))])
-             (cons 'datum (string->symbol (list->string ls))))]
-          [($char= #\" c) 
-           (let ([ls (tokenize-string '() p)])
-             (cons 'datum (list->string (reverse ls))))]
-          [($char= #\; c)
-           (skip-comment p)
-           (tokenize p)]
-          [($char= #\+ c)
-           (tokenize-plus p)]
-          [($char= #\- c)
-           (tokenize-minus p)]
-          [($char= #\. c)
-           (tokenize-dot p)]
-          [($char= #\| c)
-           (let ([ls (reverse (tokenize-bar p '()))])
-             (cons 'datum (string->symbol (list->string ls))))]
-          [else
-           (unread-char c p) 
-           (error 'tokenize "invalid syntax ~a" c)]))))
-
-  ;;;
-  ;;;--------------------------------------------------------------* READ *---
-  ;;;
-  (define read-list-rest
-    (lambda (p end mis)
-      (let ([t (read-token p)])
-        (cond
-         [(eof-object? t)
-          (error 'read "end of file encountered while reading list")]
-         [(eq? t end) '()]
-         [(eq? t mis) 
-          (error 'read "paren mismatch")]
-         [(eq? t 'dot)
-          (let ([d (read p)])
-            (let ([t (read-token p)])
-              (cond
-               [(eq? t end) d]
-               [(eq? t mis) 
-                (error 'read "paren mismatch")]
-               [(eq? t 'dot)
-                (error 'read "cannot have two dots in a list")]
-               [else
-                (error 'read "expecting ~a, got ~a" end t)])))]
-         [(eq? t 'hash-semi)
-          (read p)
-          (read-list-rest p end mis)]
-         [else
-          (let ([a (parse-token p t)])
-            (let ([d (read-list-rest p end mis)])
-              (cons a d)))]))))
-  (define read-list-init
-    (lambda (p end mis)
-      (let ([t (read-token p)])
-       (cond
-         [(eof-object? t)
-          (error 'read "end of file encountered while reading list")]
-         [(eq? t end) '()]
-         [(eq? t mis) 
-          (error 'read "paren mismatch")]
-         [(eq? t 'dot)
-          (error 'read "invalid dot while reading list")]
-         [(eq? t 'hash-semi)
-          (read p)
-          (read-list-init p end mis)]
-         [else
-          (let ([a (parse-token p t)])
-            (cons a (read-list-rest p end mis)))]))))
-  (define vector-put!
-    (lambda (v i ls)
-      (cond
-        [(null? ls) v]
-        [else
-         (vector-set! v i (car ls))
-         (vector-put! v (fxsub1 i) (cdr ls))])))
-  (define read-vector
-    (lambda (p count ls)
-      (let ([t (read-token p)])
-        (cond
-         [(eof-object? t) 
-          (error 'read "end of file encountered while reading a vector")]
-         [(eq? t 'rparen) 
-          (let ([v (make-vector count)])
-            (vector-put! v (fxsub1 count) ls))]
-         [(eq? t 'rbrack)
-          (error 'read "unexpected ] while reading a vector")]
-         [(eq? t 'dot)
-          (error 'read "unexpected . while reading a vector")]
-         [(eq? t 'hash-semi)
-          (read p)
-          (read-vector p count ls)]
-         [else
-          (let ([a (parse-token p t)])
-            (read-vector p (fxadd1 count) (cons a ls)))]))))
-  (define parse-token
-    (lambda (p t)
-      (cond
-        [(eof-object? t) (eof-object)]
-        [(eq? t 'lparen) (read-list-init p 'rparen 'rbrack)]
-        [(eq? t 'lbrack) (read-list-init p 'rbrack 'rparen)]
-        [(eq? t 'vparen) (read-vector p 0 '())]
-        [(eq? t 'hash-semi) 
-         (read p) ; ignored expression
-         (read p)]
-        [(pair? t)
-         (cond
-           [(eq? (car t) 'datum) (cdr t)]
-           [(eq? (car t) 'macro)
-            (cons (cdr t) (cons (read p) '()))]
-           [else (error 'read "invalid token! ~s" t)])]
-        [else
-         (error 'read "unexpected ~s found" t)])))
-  (define read
-    (lambda (p) (parse-token p (read-token p))))
-          
-  ;;;      
-  ;;;--------------------------------------------------------------* INIT *---
-  ;;; 
-  (primitive-set! 'read-token
-    (case-lambda
-      [() (tokenize (current-input-port))]
-      [(p)
-       (if (input-port? p)
-           (tokenize p)
-           (error 'read-token "~s is not an input port" p))]))
-  (primitive-set! 'read
-    (case-lambda
-      [() (read (current-input-port))]
-      [(p)
-       (if (input-port? p)
-           (read p)
-           (error 'read "~s is not an input port" p))]))
-  (let ()
-    (define read-and-eval
-      (lambda (p)
-        (let ([x (read p)])
-          (unless (eof-object? x)
-            (eval x)
-            (read-and-eval p)))))
-    (primitive-set! 'load
-      (lambda (x)
-        (unless (string? x)
-          (error 'load "~s is not a string" x))
-        (let ([p (open-input-file x)])
-          (read-and-eval p)
-          (close-input-port p)))))
-  )
-
diff --git a/src/libtokenizer-9.0.ss b/src/libtokenizer-9.0.ss
deleted file mode 100644
index b4da506..0000000
--- a/src/libtokenizer-9.0.ss
+++ /dev/null
@@ -1,626 +0,0 @@
-(let ()
-  (define char-whitespace?
-    (lambda (c)
-      (or ($char= #\space c)
-          (memq ($char->fixnum c) '(9 10 11 12 13))))) 
-  (define delimiter?
-    (lambda (c)
-      (or (char-whitespace? c)
-          (memq c '(#\( #\) #\[ #\] #\' #\` #\, #\")))))
-  (define digit?
-    (lambda (c)
-      (and ($char<= #\0 c) ($char<= c #\9))))
-  (define char->num
-    (lambda (c)
-      (fx- ($char->fixnum c) ($char->fixnum #\0))))
-  (define initial?
-    (lambda (c)
-      (or (letter? c) (special-initial? c))))
-  (define letter? 
-    (lambda (c)
-      (or (and ($char<= #\a c) ($char<= c #\z))
-          (and ($char<= #\A c) ($char<= c #\Z)))))
-  (define af? 
-    (lambda (c)
-      (or (and ($char<= #\a c) ($char<= c #\f))
-          (and ($char<= #\A c) ($char<= c #\F)))))
-  (define af->num
-    (lambda (c)
-      (if (and ($char<= #\a c) ($char<= c #\f))
-          (fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\a)))
-          (fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\A))))))
-  (define special-initial?
-    (lambda (c)
-      (memq c '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~))))
-  (define subsequent?
-    (lambda (c)
-      (or (initial? c) (digit? c) (special-subsequent? c))))
-  (define special-subsequent?
-    (lambda (c)
-      (memq c '(#\+ #\- #\. #\@))))
-  (define tokenize-number
-    (lambda (n p)
-      (let ([c (read-char p)])
-        (cond
-         [(eof-object? c) n]
-         [(digit? c)
-          (tokenize-number (fx+ (fx* n 10) (char->num c)) p)]
-         [(delimiter? c)
-          (unread-char c p)
-          n]
-         [else
-          (unread-char c p)
-          (error 'tokenize "invalid number syntax: ~a~a" n c)]))))
-  (define tokenize-hex
-    (lambda (n p)
-      (let ([c (read-char p)])
-        (cond
-         [(eof-object? c) n]
-         [(digit? c)
-          (tokenize-hex (fx+ (fx* n 16) (char->num c)) p)]
-         [(af? c)
-          (tokenize-hex (fx+ (fx* n 16) (af->num c)) p)]
-         [(delimiter? c)
-          (unread-char c p)
-          n]
-         [else
-          (unread-char c p)
-          (error 'tokenize "invalid hex number sequence: ~a~a" n c)]))))
-  (define tokenize-hex-init
-    (lambda (p)
-      (let ([c (read-char p)])
-        (cond
-         [(eof-object? c) 
-          (unread-char c p) 
-          (error 'tokenize "invalid #x near end of file")]
-         [(digit? c)
-          (cons 'datum (tokenize-hex (char->num c) p))]
-         [(af? c)
-          (cons 'datum (tokenize-hex (af->num c) p))]
-         [($char= c #\-)
-          (cons 'datum (fx- 0 (tokenize-hex 0 p)))]
-         [($char= c #\+)
-          (cons 'datum (tokenize-hex 0 p))]
-         [else
-          (unread-char c p)
-          (error 'tokenize "invalid number syntax: #x~a" c)]))))
-  (define tokenize-identifier
-    (lambda (ls p)
-      (let ([c (read-char p)])
-        (cond
-         [(eof-object? c) ls]
-         [(subsequent? c)
-          (tokenize-identifier (cons c ls) p)]
-         [(delimiter? c)
-          (unread-char c p)
-          ls]
-         [else
-          (unread-char c p)
-          (error 'tokenize "invalid identifier syntax: ~a" 
-                 (list->string (reverse (cons c ls))))]))))
-  (define tokenize-string
-    (lambda (ls p)
-      (let ([c (read-char p)])
-        (cond
-         [(eof-object? c) 
-          (error 'tokenize "end-of-file while inside a string")]
-         [($char= #\" c)  ls]
-         [($char= #\\ c) 
-          (let ([c (read-char p)])
-            (cond
-              [($char= #\" c) (tokenize-string (cons #\" ls) p)]
-              [($char= #\\ c) (tokenize-string (cons #\\ ls) p)]
-              [($char= #\n c) (tokenize-string (cons #\newline ls) p)]
-              [($char= #\t c) (tokenize-string (cons #\tab ls) p)]
-              [else (error 'tokenize "invalid string escape \\~a" c)]))]
-         [else
-          (tokenize-string (cons c ls) p)]))))
-  (define skip-comment
-    (lambda (p)
-      (let ([c (read-char p)])
-        (unless (eof-object? c)
-          (let ([i ($char->fixnum c)])
-            (unless (or (fx= i 10) (fx= i 13))
-              (skip-comment p)))))))
-  (define tokenize-plus
-    (lambda (p)
-      (let ([c (peek-char p)])
-        (cond
-          [(eof-object? c) '(datum . +)]
-          [(delimiter? c)  '(datum . +)]
-          [(digit? c) 
-           (read-char p)
-           (cons 'datum (tokenize-number (char->num c) p))]
-          [else (error 'tokenize "invalid sequence +~a" c)]))))
-  (define tokenize-minus
-    (lambda (p)
-      (let ([c (peek-char p)])
-        (cond
-          [(eof-object? c) '(datum . -)]
-          [(delimiter? c)  '(datum . -)]
-          [(digit? c) 
-           (read-char p)
-           (cons 'datum (fx- 0 (tokenize-number (char->num c) p)))]
-          [else (error 'tokenize "invalid sequence -~a" c)]))))
-  (define tokenize-dot
-    (lambda (p)
-      (let ([c (peek-char p)])
-        (cond
-          [(eof-object? c) 'dot]
-          [(delimiter? c)  'dot]
-          [($char= c #\.)  ; this is second dot
-           (read-char p)
-           (let ([c (read-char p)])
-             (cond
-               [(eof-object? c) 
-                (error 'tokenize "invalid syntax .. near end of file")]
-               [($char= c #\.) ; this is the third
-                (let ([c (peek-char p)])
-                  (cond
-                   [(eof-object? c) '(datum . ...)]
-                   [(delimiter? c)  '(datum . ...)]
-                   [else 
-                    (error 'tokenize "invalid syntax ...~a" c)]))]
-               [else
-                (unread-char c)
-                (error 'tokenize "invalid syntax ..~a" c)]))]
-          [else
-           (error 'tokenize "invalid syntax .~a" c)]))))
-  (define tokenize-char* 
-    (lambda (i str p d)
-      (cond
-       [(fx= i (string-length str))
-        (let ([c (peek-char p)])
-          (cond
-           [(eof-object? c) d]
-           [(delimiter? c)  d]
-           [else (error 'tokenize "invalid character after #\\~a" str)]))]
-       [else
-        (let ([c (read-char p)])
-          (cond
-            [(eof-object? c) 
-             (error 'tokenize "invalid eof in the middle of #\\~a" str)]
-            [($char= c (string-ref str i))
-             (tokenize-char* (fxadd1 i) str p d)]
-            [else 
-             (error 'tokenize
-                    "invalid char ~a while scanning #\\~a" c str)]))])))
-  (define tokenize-char-seq
-    (lambda (p str d)
-      (let ([c (peek-char p)])
-        (cond
-          [(eof-object? c) (cons 'datum (string-ref str 0))]
-          [(delimiter? c)  (cons 'datum (string-ref str 0))]
-          [($char= (string-ref str 1) c) 
-           (read-char p)
-           (tokenize-char*  2 str p d)]
-          [else (error 'tokenize "invalid syntax near #\\~a~a" 
-                       (string-ref str 0) c)]))))
-  (define tokenize-char
-    (lambda (p)
-      (let ([c (read-char p)])
-        (cond
-          [(eof-object? c)
-           (error 'tokenize "invalid #\\ near end of file")]
-          [($char= #\s c) 
-           (tokenize-char-seq p "space" '(datum . #\space))]
-          [($char= #\n c) 
-           (tokenize-char-seq p "newline" '(datum . #\newline))]
-          [($char= #\t c) 
-           (tokenize-char-seq p "tab" '(datum . #\tab))]
-          [($char= #\r c) 
-           (tokenize-char-seq p "return" '(datum . #\return))]
-          [else
-           (let ([n (peek-char p)])
-             (cond
-               [(eof-object? n) (cons 'datum c)]
-               [(delimiter? n)  (cons 'datum c)]
-               [else 
-                (error 'tokenize "invalid syntax #\\~a~a" c n)]))]))))
-  (define multiline-error
-    (lambda ()
-      (error 'tokenize
-             "end of file encountered while inside a #|-style comment")))
-  (define multiline-comment
-    (lambda (p)
-      (let ([c (read-char p)])
-        (cond
-          [(eof-object? c) (multiline-error)]
-          [($char= #\| c) 
-           (let ([c (read-char p)])
-             (cond
-               [(eof-object? c) (multiline-error)]
-               [($char= #\# c)   (void)]
-               [else (multiline-comment p)]))]
-          [($char= #\# c)
-           (let ([c (read-char p)])
-             (cond
-               [(eof-object? c) (multiline-error)]
-               [($char= #\| c) 
-                (multiline-comment p)
-                (multiline-comment p)]
-               [else 
-                (multiline-comment p)]))]
-          [else (multiline-comment p)]))))
-  (define read-binary
-    (lambda (ac chars p)
-      (let ([c (read-char p)])
-        (cond
-          [(eof-object? c) ac]
-          [($char= #\0 c) (read-binary (fxsll ac 1) (cons c chars) p)]
-          [($char= #\1 c) (read-binary (fx+ (fxsll ac 1) 1) (cons c chars) p)]
-          [(delimiter? c) (unread-char c p) ac]
-          [else 
-           (unread-char c)
-           (error 'tokenize "invalid syntax #b~a"
-                  (list->string (reverse (cons c chars))))]))))
-  (define tokenize-hash
-    (lambda (p)
-      (let ([c (read-char p)])
-        (cond
-          [(eof-object? c) (error 'tokenize "invalid # near end of file")]
-          [($char= c #\t) 
-           (let ([c (peek-char p)])
-             (cond
-               [(eof-object? c) '(datum . #t)]
-               [(delimiter? c)  '(datum . #t)]
-               [else (error 'tokenize "invalid syntax near #t")]))]
-          [($char= c #\f) 
-           (let ([c (peek-char p)])
-             (cond
-               [(eof-object? c) '(datum . #f)]
-               [(delimiter? c)  '(datum . #f)]
-               [else (error 'tokenize "invalid syntax near #f")]))]
-          [($char= #\\ c) (tokenize-char p)]
-          [($char= #\( c) 'vparen]
-          [($char= #\x c) (tokenize-hex-init p)]
-          [($char= #\' c) '(macro . syntax)]
-          [($char= #\; c) 'hash-semi]
-          [($char= #\% c) '(macro . |#primitive|)]
-          [($char= #\| c) (multiline-comment p) (tokenize p)]
-          [($char= #\b c) 
-           (let ([c (read-char p)])
-             (cond
-               [(eof-object? c) 
-                (error 'tokenize "invalid eof while reading #b")]
-               [($char= #\- c)
-                (let ([c (read-char p)])
-                  (cond
-                    [(eof-object? c)
-                     (error 'tokenize "invalid eof while reading #b-")]
-                    [($char= #\0 c)
-                     (cons 'datum
-                       (fx- 0 (read-binary 0 '(#\0 #\-) p)))]
-                    [($char= #\1 c)
-                     (cons 'datum
-                       (fx- 0 (read-binary 1 '(#\1 #\-) p)))]
-                    [else 
-                     (unread-char c p)
-                     (error 'tokenize "invalid binary syntax #b-~a" c)]))]
-               [($char= #\0 c)
-                (cons 'datum (read-binary 0 '(#\0) p))]
-               [($char= #\1 c)
-                (cons 'datum (read-binary 1 '(#\1) p))]
-               [else 
-                (unread-char c p)
-                (error 'tokenize "invalid syntax #b~a" c)]
-               ))]
-          [($char= #\! c) 
-           (let ([e (read-char p)])
-             (when (eof-object? e)
-               (error 'tokenize "invalid eof near #!"))
-             (unless ($char= #\e e)
-               (error 'tokenize "invalid syntax near #!~a" e))
-             (let ([o (read-char p)])
-               (when (eof-object? o)
-                 (error 'tokenize "invalid eof near #!e"))
-               (unless ($char= #\o o)
-                 (error 'tokenize "invalid syntax near #!e~a" o))
-               (let ([f (read-char p)])
-                 (when (eof-object? f)
-                   (error 'tokenize "invalid syntax near #!eo"))
-                 (unless ($char= #\f f)
-                   (error 'tokenize "invalid syntax near #!eo~a" f))
-                 (cons 'datum (eof-object)))))]
-          [(digit? c) 
-           (tokenize-hashnum p (char->num c))]
-          [else 
-           (unread-char c p)
-           (error 'tokenize "invalid syntax #~a" c)]))))
-  (define (tokenize-hashnum p n)
-    (let ([c (read-char p)])
-      (cond
-        [(eof-object? c) 
-         (error 'tokenize "invalid eof inside #n mark/ref")]
-        [($char= #\= c) (cons 'mark n)]
-        [($char= #\# c) (cons 'ref n)]
-        [(digit? c)
-         (tokenize-hashnum p (fx+ (fx* n 10) (char->num c)))]
-        [else
-         (unread-char c p)
-         (error 'tokenize "invalid char ~a while inside a #n mark/ref" c)])))
-  (define tokenize-bar
-    (lambda (p ac)
-      (let ([c (read-char p)])
-        (cond
-          [(eof-object? c) 
-           (error 'tokenize "unexpected eof while reading symbol")]
-          [($char= #\\ c)
-           (let ([c (read-char p)])
-             (cond
-               [(eof-object? c) 
-                (error 'tokenize "unexpected eof while reading symbol")]
-               [else (tokenize-bar p (cons c ac))]))]
-          [($char= #\| c) ac]
-          [else (tokenize-bar p (cons c ac))]))))
-  (define tokenize
-    (lambda (p)
-      (let ([c (read-char p)])
-        (cond
-          [(eof-object? c) (eof-object)]
-          [(char-whitespace? c) (tokenize p)]
-          [($char= #\( c)   'lparen]
-          [($char= #\) c)   'rparen]
-          [($char= #\[ c)   'lbrack]
-          [($char= #\] c)   'rbrack]
-          [($char= #\' c)   '(macro . quote)]
-          [($char= #\` c)   '(macro . quasiquote)]
-          [($char= #\, c) 
-           (let ([c (peek-char p)])
-             (cond
-              [(eof-object? c) '(macro . unquote)]
-              [($char= c #\@) 
-               (read-char p)
-               '(macro . unquote-splicing)]
-              [else '(macro . unquote)]))]
-          [($char= #\# c) (tokenize-hash p)]
-          [(digit? c) 
-           (cons 'datum (tokenize-number (char->num c) p))]
-          [(initial? c) 
-           (let ([ls (reverse (tokenize-identifier (cons c '()) p))])
-             (cons 'datum (string->symbol (list->string ls))))]
-          [($char= #\" c) 
-           (let ([ls (tokenize-string '() p)])
-             (cons 'datum (list->string (reverse ls))))]
-          [($char= #\; c)
-           (skip-comment p)
-           (tokenize p)]
-          [($char= #\+ c)
-           (tokenize-plus p)]
-          [($char= #\- c)
-           (tokenize-minus p)]
-          [($char= #\. c)
-           (tokenize-dot p)]
-          [($char= #\| c)
-           (let ([ls (reverse (tokenize-bar p '()))])
-             (cons 'datum (string->symbol (list->string ls))))]
-          [else
-           (unread-char c p) 
-           (error 'tokenize "invalid syntax ~a" c)]))))
-
-  ;;;
-  ;;;--------------------------------------------------------------* READ *---
-  ;;;
-  (define read-list-rest
-    (lambda (p locs k end mis)
-      (let ([t (read-token p)])
-        (cond
-         [(eof-object? t)
-          (error 'read "end of file encountered while reading list")]
-         [(eq? t end) (values '() locs k)]
-         [(eq? t mis) 
-          (error 'read "paren mismatch")]
-         [(eq? t 'dot)
-          (let-values ([(d locs k) (read-expr p locs k)])
-            (let ([t (read-token p)])
-              (cond
-               [(eq? t end) (values d locs k)]
-               [(eq? t mis)
-                (error 'read "paren mismatch")]
-               [(eq? t 'dot)
-                (error 'read "cannot have two dots in a list")]
-               [else
-                (error 'read "expecting ~a, got ~a" end t)])))]
-         [(eq? t 'hash-semi)
-          (let-values ([(ignored locs k) (read-expr p locs k)])
-            (read-list-rest p locs k end mis))]
-         [else
-          (let-values ([(a locs k) (parse-token p locs k t)])
-            (let-values ([(d locs k) (read-list-rest p locs k end mis)])
-               (let ([x (cons a d)])
-                 (values x locs 
-                         (if (or (loc? a) (loc? d))
-                             (extend-k-pair x k)
-                             k)))))]))))
-  (define read-list-init
-    (lambda (p locs k end mis)
-      (let ([t (read-token p)])
-       (cond
-         [(eof-object? t)
-          (error 'read "end of file encountered while reading list")]
-         [(eq? t end) (values '() locs k)]
-         [(eq? t mis) 
-          (error 'read "paren mismatch")]
-         [(eq? t 'dot)
-          (error 'read "invalid dot while reading list")]
-         [(eq? t 'hash-semi)
-          (let-values ([(ignored locs k) (read-expr p locs k)])
-            (read-list-init p locs k end mis))]
-         [else
-          (let-values ([(a locs k) (parse-token p locs k t)])
-            (let-values ([(d locs k) (read-list-rest p locs k end mis)])
-              (let ([x (cons a d)])
-                 (values x locs 
-                    (if (or (loc? a) (loc? d))
-                        (extend-k-pair x k)
-                        k)))))]))))
-  (define extend-k-pair
-    (lambda (x k)
-      (lambda ()
-        (let ([a (car x)])
-          (when (loc? a)
-            (set-car! x (loc-value a))))
-        (let ([d (cdr x)])
-          (when (loc? d)
-            (set-cdr! x (loc-value d))))
-        (k))))
-  (define vector-put
-    (lambda (v k i ls)
-      (cond
-        [(null? ls) k]
-        [else
-         (let ([a (car ls)])
-           (vector-set! v i a)
-           (vector-put v  
-              (if (loc? a)
-                  (lambda ()
-                    (vector-set! v i (loc-value (vector-ref v i)))
-                    (k))
-                  k)
-              (fxsub1 i) (cdr ls)))])))
-  (define read-vector
-    (lambda (p locs k count ls)
-      (let ([t (read-token p)])
-        (cond
-          [(eof-object? t) 
-           (error 'read "end of file encountered while reading a vector")]
-          [(eq? t 'rparen) 
-           (let ([v (make-vector count)])
-             (let ([k (vector-put v k (fxsub1 count) ls)])
-               (values v locs k)))]
-          [(eq? t 'rbrack)
-           (error 'read "unexpected ] while reading a vector")]
-          [(eq? t 'dot)
-           (error 'read "unexpected . while reading a vector")]
-          [(eq? t 'hash-semi)
-           (let-values ([(ignored locs k) (read-expr p locs k)])
-             (read-vector p locs k count ls))]
-          [else
-           (let-values ([(a locs k) (parse-token p locs k t)])
-              (read-vector p locs k (fxadd1 count) (cons a ls)))]))))
-  (define-record loc (value set?))
-  (define parse-token
-    (lambda (p locs k t)
-      (cond
-        [(eof-object? t) (values (eof-object) locs k)]
-        [(eq? t 'lparen) (read-list-init p locs k 'rparen 'rbrack)]
-        [(eq? t 'lbrack) (read-list-init p locs k 'rbrack 'rparen)]
-        [(eq? t 'vparen) (read-vector p locs k 0 '())]
-        [(eq? t 'hash-semi)
-         (let-values ([(ignored locs k) (read-expr p locs k)])
-           (read-expr p locs k))]
-        [(pair? t)
-         (cond
-           [(eq? (car t) 'datum) (values (cdr t) locs k)]
-           [(eq? (car t) 'macro)
-            (let-values ([(expr locs k) (read-expr p locs k)])
-              (let ([x (list expr)])
-                (values (cons (cdr t) x) locs
-                        (if (loc? expr)
-                            (lambda ()
-                              (set-car! x (loc-value expr))
-                              (k))
-                            k))))]
-           [(eq? (car t) 'mark) 
-            (let ([n (cdr t)])
-              (let-values ([(expr locs k) (read-expr p locs k)])
-                (cond
-                  [(assq n locs) =>
-                   (lambda (x)
-                     (let ([loc (cdr x)])
-                       (when (loc-set? loc)
-                         (error 'read "duplicate mark ~s" n))
-                       (set-loc-value! loc expr)
-                       (set-loc-set?! loc #t)
-                       (values expr locs k)))]
-                  [else
-                   (let ([loc (make-loc expr #t)])
-                     (let ([locs (cons (cons n loc) locs)])
-                       (values expr locs k)))])))]
-           [(eq? (car t) 'ref)
-            (let ([n (cdr t)])
-              (cond
-                [(assq n locs) =>
-                 (lambda (x)
-                   (values (cdr x) locs k))]
-                [else
-                 (let ([loc (make-loc #f #f)])
-                   (let ([locs (cons (cons n loc) locs)])
-                     (values loc locs k)))]))]
-           [else (error 'read "invalid token! ~s" t)])]
-        [else
-         (error 'read "unexpected ~s found" t)])))
-  (define read-expr
-    (lambda (p locs k)
-      (parse-token p locs k (read-token p))))
-          
-  (define reduce-loc!
-    (lambda (x)
-       (let ([loc (cdr x)])
-         (unless (loc-set? loc)
-           (error 'read "referenced mark ~s not set" (car x)))
-         (when (loc? (loc-value loc))
-           (let f ([h loc] [t loc])
-             (if (loc? h)
-                 (let ([h1 (loc-value h)])
-                   (if (loc? h1)
-                       (begin
-                         (when (eq? h1 t)
-                           (error 'read "circular marks"))
-                         (let ([v (f (loc-value h1) (loc-value t))])
-                           (set-loc-value! h1 v)
-                           (set-loc-value! h v)
-                           v))
-                       (begin
-                         (set-loc-value! h h1)
-                         h1)))
-                 h))))))
-       
-  (define read
-    (lambda (p)
-      (let-values ([(expr locs k) (read-expr p '() void)])
-        (cond
-          [(null? locs) expr]
-          [else
-           (for-each reduce-loc! locs)
-           (k)
-           (if (loc? expr)
-               (loc-value expr)
-               expr)]))))
-
-
-
-
-  ;;;      
-  ;;;--------------------------------------------------------------* INIT *---
-  ;;; 
-  (primitive-set! 'read-token
-    (case-lambda
-      [() (tokenize (current-input-port))]
-      [(p)
-       (if (input-port? p)
-           (tokenize p)
-           (error 'read-token "~s is not an input port" p))]))
-  (primitive-set! 'read
-    (case-lambda
-      [() (read (current-input-port))]
-      [(p)
-       (if (input-port? p)
-           (read p)
-           (error 'read "~s is not an input port" p))]))
-  (let ()
-    (define read-and-eval
-      (lambda (p)
-        (let ([x (read p)])
-          (unless (eof-object? x)
-            (eval x)
-            (read-and-eval p)))))
-    (primitive-set! 'load
-      (lambda (x)
-        (unless (string? x)
-          (error 'load "~s is not a string" x))
-        (let ([p (open-input-file x)])
-          (read-and-eval p)
-          (close-input-port p)))))
-  )
-
diff --git a/src/libtokenizer-9.1.ss b/src/libtokenizer.ss
similarity index 100%
rename from src/libtokenizer-9.1.ss
rename to src/libtokenizer.ss
diff --git a/src/libtoplevel-6.9.ss b/src/libtoplevel.ss
similarity index 100%
rename from src/libtoplevel-6.9.ss
rename to src/libtoplevel.ss
diff --git a/src/libtrace-6.9.ss b/src/libtrace.ss
similarity index 100%
rename from src/libtrace-6.9.ss
rename to src/libtrace.ss
diff --git a/src/libwriter-6.2.ss b/src/libwriter-6.2.ss
deleted file mode 100644
index 2f114f8..0000000
--- a/src/libwriter-6.2.ss
+++ /dev/null
@@ -1,373 +0,0 @@
-
-;;; 6.2: * added a printer for bwp-objects
-
-;;; WRITER provides display and write.
-
-(let ()
-  (define char-table ; first nonprintable chars
-    '#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel" "bs" "tab" "newline"
-       "vt" "ff" "return" "so" "si" "dle" "dc1" "dc2" "dc3" "dc4" "nak" 
-       "syn" "etb" "can" "em" "sub" "esc" "fs" "gs" "rs" "us" "space"))
-  (define write-character
-    (lambda (x p m)
-      (if m 
-          (let ([i ($char->fixnum x)])
-            (write-char #\# p)
-            (cond
-             [(fx< i (vector-length char-table))
-              (write-char #\\ p)
-              (write-char* (vector-ref char-table i) p)]
-             [(fx< i 127)
-              (write-char #\\ p)
-              (write-char x p)]
-             [(fx= i 127) 
-              (write-char #\\ p)
-              (write-char* "del" p)]
-             [else
-              (write-char #\+ p)
-              (write-fixnum i p)]))
-          (write-char x p))))
-  (define write-list
-    (lambda (x p m)
-      (cond
-       [(pair? x)
-        (write-char #\space p)
-        (writer (car x) p m)
-        (write-list (cdr x) p m)]
-       [(not (null? x))
-        (write-char #\space p)
-        (write-char #\. p)
-        (write-char #\space p)
-        (writer x p m)])))
-  (define write-vector
-    (lambda (x p m)
-      (write-char #\# p)
-      (write-char #\( p)
-      (let ([n (vector-length x)])
-        (when (fx> n 0)
-          (writer (vector-ref x 0) p m)
-          (letrec ([f 
-                    (lambda (i)
-                      (unless (fx= i n)
-                        (write-char #\space p)
-                        (writer (vector-ref x i) p m)
-                        (f (fxadd1 i))))])
-            (f 1))))
-      (write-char #\) p)))
-  (define write-record
-    (lambda (x p m)
-      (write-char #\# p)
-      (write-char #\[ p)
-      (writer (record-name x) p m)
-      (let ([n (record-length x)])
-        (letrec ([f 
-                  (lambda (i)
-                    (unless (fx= i n)
-                      (write-char #\space p)
-                      (writer (record-ref x i) p m)
-                      (f (fxadd1 i))))])
-          (f 0)))
-      (write-char #\] p)))
-  (define initial?
-    (lambda (c)
-      (or (letter? c) (special-initial? c))))
-  (define letter?
-    (lambda (c)
-      (or (and ($char<= #\a c) ($char<= c #\z))
-          (and ($char<= #\A c) ($char<= c #\Z)))))
-  (define digit?
-    (lambda (c)
-      (and ($char<= #\0 c) ($char<= c #\9))))
-  (define special-initial? 
-    (lambda (x)
-      (memq x '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~))))
-  (define subsequent?
-    (lambda (x)
-      (or (initial? x)
-          (digit? x)
-          (special-subsequent? x))))
-  (define special-subsequent?
-    (lambda (x) 
-      (memq x '(#\+ #\- #\. #\@))))
-  (define subsequent*?
-    (lambda (str i n)
-      (or ($fx= i n)
-          (and (subsequent? ($string-ref str i))
-               (subsequent*? str ($fxadd1 i) n)))))
-  (define valid-symbol-string?
-    (lambda (str)
-      (or (let ([n ($string-length str)])
-            (and ($fx>= n 1)
-                 (initial? ($string-ref str 0))
-                 (subsequent*? str 1 n)))
-          (string=? str "+")
-          (string=? str "-")
-          (string=? str "..."))))
-  (define write-symbol-esc-loop
-    (lambda (x i n p)
-      (unless ($fx= i n)
-        (let ([c ($string-ref x i)])
-          (when (memq c '(#\\ #\|))
-            (write-char #\\ p))
-          (write-char c p))
-        (write-symbol-esc-loop x ($fxadd1 i) n p))))
-  (define write-symbol-esc
-    (lambda (x p)
-      (write-char #\| p)
-      (write-symbol-esc-loop x 0 ($string-length x) p)
-      (write-char #\| p)))
-  (define write-symbol
-    (lambda (x p m)
-      (let ([str (symbol->string x)])
-        (if m
-            (if (valid-symbol-string? str)
-                (write-char* str p)
-                (write-symbol-esc str p))
-            (write-char* str p)))))
-  (define write-gensym
-    (lambda (x p m)
-      (cond
-        [(and m (print-gensym))
-         (let ([str (symbol->string x)])
-           (write-char #\# p)
-           (write-char #\{ p)
-           (if (valid-symbol-string? str)
-               (write-char* str p)
-               (write-symbol-esc str p))
-           (write-char #\space p)
-           (write-symbol-esc (gensym->unique-string x) p)
-           (write-char #\} p))]
-        [else (write-symbol x p m)])))
-  (define write-string-escape
-    (lambda (x p)
-      (define loop 
-        (lambda (x i n p)
-         (unless (fx= i n)
-           (let ([c (string-ref x i)])
-             (cond
-               [(or ($char= #\" c) ($char= #\\ c))
-                (write-char #\\ p)
-                (write-char c p)]
-               [($char= #\tab c)
-                (write-char #\\ p)
-                (write-char #\t p)]
-               [else
-                (write-char c p)]))
-           (loop x (fxadd1 i) n p)))) 
-      (write-char #\" p)
-      (loop x 0 (string-length x) p)
-      (write-char #\" p)))
-  (define write-string
-    (lambda (x p m)
-      (if m
-          (write-string-escape x p)
-          (write-char* x p))))
-  (define write-fixnum
-    (lambda (x p)
-      (define loop
-        (lambda (x p)
-          (unless (fxzero? x)
-            (loop (fxquotient x 10) p)
-            (write-char 
-               ($fixnum->char
-                  ($fx+ (fxremainder x 10)
-                        ($char->fixnum #\0)))
-               p))))
-      (cond
-       [(fxzero? x) (write-char #\0 p)]
-       [(fx< x 0)
-        (write-char #\- p)
-        (if (fx= x -536870912)
-            (write-char* "536870912" p)
-            (loop (fx- 0 x) p))]
-       [else (loop x p)])))
-  (define write-char*
-    (lambda (x p)
-      (define loop 
-        (lambda (x i n p)
-         (unless (fx= i n)
-           (write-char (string-ref x i) p)
-           (loop x (fxadd1 i) n p)))) 
-      (loop x 0 (string-length x) p)))
-  (define macro
-    (lambda (x)
-      (define macro-forms
-        '([quote .            "'"]
-          [quasiquote .       "`"]
-          [unquote .          ","]
-          [unquote-splicing . ",@"]
-          [syntax .           "#'"]
-          [|#primitive| .     "#%"]))
-      (and (pair? x)
-           (let ([d ($cdr x)])
-             (and (pair? d)
-                  (null? ($cdr d))))
-           (assq ($car x) macro-forms))))
-  (define writer
-    (lambda (x p m)
-      (cond
-        [(macro x) =>
-         (lambda (y)
-           (write-char* (cdr y) p)
-           (writer (cadr x) p m))]
-        [(pair? x) 
-         (write-char #\( p)
-         (writer (car x) p m)
-         (write-list (cdr x) p m)
-         (write-char #\) p)]
-        [(symbol? x) 
-         (if (gensym? x)
-             (write-gensym x p m)
-             (write-symbol x p m))]
-        [(fixnum? x)
-         (write-fixnum x p)]
-        [(string? x)
-         (write-string x p m)]
-        [(boolean? x)
-         (write-char* (if x "#t" "#f") p)]
-        [(char? x)
-         (write-character x p m)]
-        [(procedure? x)
-         (write-char* "#<procedure>" p)]
-        [(output-port? x)
-         (write-char* "#<output-port " p)
-         (writer (output-port-name x) p #t)
-         (write-char #\> p)]
-        [(input-port? x)
-         (write-char* "#<input-port " p)
-         (writer (input-port-name x) p #t)
-         (write-char #\> p)]
-        [(vector? x)
-         (write-vector x p m)]
-        [(null? x) 
-         (write-char #\( p)
-         (write-char #\) p)]
-        [(eq? x (void)) 
-         (write-char* "#<void>" p)]
-        [(eof-object? x)
-         (write-char* "#!eof" p)]
-        [(bwp-object? x)
-         (write-char* "#!bwp" p)]
-        [(record? x)
-         (let ([printer (record-printer x)])
-           (if (procedure? printer)
-               (printer x p)
-               (write-record x p m)))]
-        ;[(code? x)
-        ; (write-char* "#<code>" p)]
-        [(hash-table? x)
-         (write-char* "#<hash-table>" p)]
-        [($unbound-object? x)
-         (write-char* "#<unbound-object>" p)]
-        [($forward-ptr? x)
-         (write-char* "#<forward-ptr>" p)]
-        [else 
-         (write-char* "#<unknown>" p)])))
-
-  (define (write x p)
-    (writer x p #t)
-    (flush-output-port p))
-  (define (display x p)
-    (writer x p #f)
-    (flush-output-port p))
-  ;;;
-  (define formatter
-    (lambda (who p fmt args)
-      (let f ([i 0] [args args])
-        (unless (fx= i (string-length fmt))
-          (let ([c (string-ref fmt i)])
-            (cond
-              [($char= c #\~)
-               (let ([i (fxadd1 i)])
-                 (when (fx= i (string-length fmt))
-                   (error who "invalid ~~ at end of format string ~s" fmt))
-                 (let ([c (string-ref fmt i)])
-                  (cond
-                    [($char= c #\~) 
-                     (write-char #\~ p)
-                     (f (fxadd1 i) args)]
-                    [($char= c #\a)
-                     (when (null? args)
-                       (error who "insufficient arguments"))
-                     (display (car args) p)
-                     (f (fxadd1 i) (cdr args))]
-                    [($char= c #\s)
-                     (when (null? args)
-                       (error who "insufficient arguments"))
-                     (write (car args) p)
-                     (f (fxadd1 i) (cdr args))]
-                    [else
-                     (error who "invalid sequence ~~~a" c)])))]
-              [else 
-               (write-char c p)
-               (f (fxadd1 i) args)]))))))
-
-  (define fprintf
-    (lambda (port fmt . args)
-      (unless (output-port? port) 
-        (error 'fprintf "~s is not an output port" port))
-      (unless (string? fmt)
-        (error 'fprintf "~s is not a string" fmt))
-      (formatter 'fprintf port fmt args)))
-
-  (define printf
-    (lambda (fmt . args)
-      (unless (string? fmt)
-        (error 'printf "~s is not a string" fmt))
-      (formatter 'printf (current-output-port) fmt args)))
-
-  (define format
-    (lambda (fmt . args)
-      (unless (string? fmt)
-        (error 'format "~s is not a string" fmt))
-      (let ([p (open-output-string)])
-        (formatter 'format p fmt args)
-        (get-output-string p))))
-
-  (define print-error
-    (lambda (who fmt . args)
-      (unless (string? fmt)
-        (error 'print-error "~s is not a string" fmt))
-      (let ([p (standard-error-port)])
-        (if who
-            (fprintf p "Error in ~a: " who)
-            (fprintf p "Error: "))
-        (formatter 'print-error p fmt args)
-        (write-char #\. p)
-        (newline p))))
-
-  
-  ;;;
-  (primitive-set! 'format format)
-  (primitive-set! 'printf printf)
-  (primitive-set! 'fprintf fprintf)
-  (primitive-set! 'write 
-    (case-lambda
-      [(x) (write x (current-output-port))]
-      [(x p)
-       (unless (output-port? p) 
-         (error 'write "~s is not an output port" p))
-       (write x p)]))
-  (primitive-set! 'display 
-    (case-lambda
-      [(x) (display x (current-output-port))]
-      [(x p)
-       (unless (output-port? p) 
-         (error 'display "~s is not an output port" p))
-       (display x p)]))
-  (primitive-set! 'print-error print-error)
-  (primitive-set! 'current-error-handler
-    (make-parameter
-      (lambda args
-        (apply print-error args)
-        (display "exiting\n" (console-output-port))
-        (flush-output-port (console-output-port))
-        (exit -100))
-      (lambda (x)
-        (if (procedure? x)
-            x
-            (error 'current-error-handler "~s is not a procedure" x)))))
-  (primitive-set! 'error
-    (lambda args
-      (apply (current-error-handler) args)))) 
-
diff --git a/src/libwriter-9.0.ss b/src/libwriter-9.0.ss
deleted file mode 100644
index 9654775..0000000
--- a/src/libwriter-9.0.ss
+++ /dev/null
@@ -1,496 +0,0 @@
-
-;;; 6.2: * added a printer for bwp-objects
-
-;;; WRITER provides display and write.
-
-(let ()
-  (define char-table ; first nonprintable chars
-    '#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel" "bs" "tab" "newline"
-       "vt" "ff" "return" "so" "si" "dle" "dc1" "dc2" "dc3" "dc4" "nak" 
-       "syn" "etb" "can" "em" "sub" "esc" "fs" "gs" "rs" "us" "space"))
-  (define write-character
-    (lambda (x p m)
-      (if m 
-          (let ([i ($char->fixnum x)])
-            (write-char #\# p)
-            (cond
-             [(fx< i (vector-length char-table))
-              (write-char #\\ p)
-              (write-char* (vector-ref char-table i) p)]
-             [(fx< i 127)
-              (write-char #\\ p)
-              (write-char x p)]
-             [(fx= i 127) 
-              (write-char #\\ p)
-              (write-char* "del" p)]
-             [else
-              (write-char #\+ p)
-              (write-fixnum i p)]))
-          (write-char x p))))
-  (define write-list
-    (lambda (x p m h i)
-      (cond
-       [(and (pair? x) 
-             (or (not (get-hash-table h x #f))
-                 (fxzero? (get-hash-table h x 0))))
-        (write-char #\space p)
-        (write-list (cdr x) p m h 
-          (writer (car x) p m h i))]
-       [(null? x) i]
-       [else
-        (write-char #\space p)
-        (write-char #\. p)
-        (write-char #\space p)
-        (writer x p m h i)])))
-  (define write-vector
-    (lambda (x p m h i)
-      (write-char #\# p)
-      (write-char #\( p)
-      (let ([n (vector-length x)])
-        (let ([i 
-               (cond
-                 [(fx> n 0)
-                  (let f ([idx 1] [i (writer (vector-ref x 0) p m h i)])
-                    (cond
-                      [(fx= idx n)
-                       i]
-                      [else
-                       (write-char #\space p)
-                       (f (fxadd1 idx)
-                          (writer (vector-ref x idx) p m h i))]))]
-                 [else i])])
-           (write-char #\) p)
-           i))))
-  (define write-record
-    (lambda (x p m h i)
-      (write-char #\# p)
-      (write-char #\[ p)
-      (let ([i (writer (record-name x) p m h i)])
-        (let ([n (record-length x)])
-          (let f ([idx 0] [i i])
-            (cond
-              [(fx= idx n)
-               (write-char #\] p)
-               i]
-              [else 
-               (write-char #\space p)
-               (f (fxadd1 idx) 
-                  (writer (record-ref x idx) p m h i))]))))))
-  (define initial?
-    (lambda (c)
-      (or (letter? c) (special-initial? c))))
-  (define letter?
-    (lambda (c)
-      (or (and ($char<= #\a c) ($char<= c #\z))
-          (and ($char<= #\A c) ($char<= c #\Z)))))
-  (define digit?
-    (lambda (c)
-      (and ($char<= #\0 c) ($char<= c #\9))))
-  (define special-initial? 
-    (lambda (x)
-      (memq x '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~))))
-  (define subsequent?
-    (lambda (x)
-      (or (initial? x)
-          (digit? x)
-          (special-subsequent? x))))
-  (define special-subsequent?
-    (lambda (x) 
-      (memq x '(#\+ #\- #\. #\@))))
-  (define subsequent*?
-    (lambda (str i n)
-      (or ($fx= i n)
-          (and (subsequent? ($string-ref str i))
-               (subsequent*? str ($fxadd1 i) n)))))
-  (define valid-symbol-string?
-    (lambda (str)
-      (or (let ([n ($string-length str)])
-            (and ($fx>= n 1)
-                 (initial? ($string-ref str 0))
-                 (subsequent*? str 1 n)))
-          (string=? str "+")
-          (string=? str "-")
-          (string=? str "..."))))
-  (define write-symbol-esc-loop
-    (lambda (x i n p)
-      (unless ($fx= i n)
-        (let ([c ($string-ref x i)])
-          (when (memq c '(#\\ #\|))
-            (write-char #\\ p))
-          (write-char c p))
-        (write-symbol-esc-loop x ($fxadd1 i) n p))))
-  (define write-symbol-esc
-    (lambda (x p)
-      (write-char #\| p)
-      (write-symbol-esc-loop x 0 ($string-length x) p)
-      (write-char #\| p)))
-  (define write-symbol
-    (lambda (x p m)
-      (let ([str (symbol->string x)])
-        (if m
-            (if (valid-symbol-string? str)
-                (write-char* str p)
-                (write-symbol-esc str p))
-            (write-char* str p)))))
-  (define write-gensym
-    (lambda (x p m h i)
-      (cond
-        [(and m (print-gensym))
-         (let ([str (symbol->string x)])
-           (write-char #\# p)
-           (write-char #\{ p)
-           (if (valid-symbol-string? str)
-               (write-char* str p)
-               (write-symbol-esc str p))
-           (write-char #\space p)
-           (write-symbol-esc (gensym->unique-string x) p)
-           (write-char #\} p))
-         i]
-        [else 
-         (write-symbol x p m)
-         i])))
-  (define write-string-escape
-    (lambda (x p)
-      (define loop 
-        (lambda (x i n p)
-         (unless (fx= i n)
-           (let ([c (string-ref x i)])
-             (cond
-               [(or ($char= #\" c) ($char= #\\ c))
-                (write-char #\\ p)
-                (write-char c p)]
-               [($char= #\tab c)
-                (write-char #\\ p)
-                (write-char #\t p)]
-               [else
-                (write-char c p)]))
-           (loop x (fxadd1 i) n p)))) 
-      (write-char #\" p)
-      (loop x 0 (string-length x) p)
-      (write-char #\" p)))
-  (define write-string
-    (lambda (x p m)
-      (if m
-          (write-string-escape x p)
-          (write-char* x p))))
-  (define write-fixnum
-    (lambda (x p)
-      (define loop
-        (lambda (x p)
-          (unless (fxzero? x)
-            (loop (fxquotient x 10) p)
-            (write-char 
-               ($fixnum->char
-                  ($fx+ (fxremainder x 10)
-                        ($char->fixnum #\0)))
-               p))))
-      (cond
-       [(fxzero? x) (write-char #\0 p)]
-       [(fx< x 0)
-        (write-char #\- p)
-        (if (fx= x -536870912)
-            (write-char* "536870912" p)
-            (loop (fx- 0 x) p))]
-       [else (loop x p)])))
-  (define write-char*
-    (lambda (x p)
-      (define loop 
-        (lambda (x i n p)
-         (unless (fx= i n)
-           (write-char (string-ref x i) p)
-           (loop x (fxadd1 i) n p)))) 
-      (loop x 0 (string-length x) p)))
-  (define macro
-    (lambda (x)
-      (define macro-forms
-        '([quote .            "'"]
-          [quasiquote .       "`"]
-          [unquote .          ","]
-          [unquote-splicing . ",@"]
-          [syntax .           "#'"]
-          [|#primitive| .     "#%"]))
-      (and (pair? x)
-           (let ([d ($cdr x)])
-             (and (pair? d)
-                  (null? ($cdr d))))
-           (assq ($car x) macro-forms))))
-  (define write-pair
-    (lambda (x p m h i)
-      (write-char #\( p)
-      (let ([i (writer (car x) p m h i)])
-        (let ([i (write-list (cdr x) p m h i)])
-          (write-char #\) p)
-          i))))
-  (define write-ref
-    (lambda (n p)
-      (write-char #\# p)
-      (write-fixnum (fx- -1 n) p)
-      (write-char #\# p)))
-  (define write-mark
-    (lambda (n p)
-      (write-char #\# p)
-      (write-fixnum (fx- -1 n) p)
-      (write-char #\= p)))
-  (define write-shareable
-    (lambda (x p m h i k)
-      (cond
-        [(get-hash-table h x #f) =>
-         (lambda (n)
-           (cond
-             [(fx< n 0) 
-              (write-ref n p)
-              i]
-             [(fx= n 0)
-              (k x p m h i)]
-             [else
-              (let ([i (fx- i 1)])
-                (put-hash-table! h x i)
-                (write-mark i p)
-                (k x p m h i))]))]
-        [else (k x p m h i)])))
-  (define writer
-    (lambda (x p m h i)
-      (cond
-        [(pair? x) 
-         (write-shareable x p m h i write-pair)]
-        [(symbol? x)
-         (if (gensym? x)
-             (write-gensym x p m h i)
-             (begin (write-symbol x p m) i))]
-        [(fixnum? x)
-         (write-fixnum x p)
-         i]
-        [(string? x)
-         (write-string x p m)
-         i]
-        [(boolean? x)
-         (write-char* (if x "#t" "#f") p)
-         i]
-        [(char? x)
-         (write-character x p m)
-         i]
-        [(procedure? x)
-         (write-char* "#<procedure>" p)
-         i]
-        [(output-port? x)
-         (write-char* "#<output-port " p)
-         (let ([i (writer (output-port-name x) p #t h i)])
-           (write-char #\> p)
-           i)]
-        [(input-port? x)
-         (write-char* "#<input-port " p)
-         (let ([i (writer (input-port-name x) p #t h i)])
-           (write-char #\> p)
-           i)]
-        [(vector? x)
-         (write-shareable x p m h i write-vector)]
-        [(null? x) 
-         (write-char #\( p)
-         (write-char #\) p)
-         i]
-        [(eq? x (void)) 
-         (write-char* "#<void>" p)
-         i]
-        [(eof-object? x)
-         (write-char* "#!eof" p)
-         i]
-        [(bwp-object? x)
-         (write-char* "#!bwp" p)
-         i]
-        [(record? x)
-         (let ([printer (record-printer x)])
-           (if (procedure? printer)
-               (begin (printer x p) i)
-               (write-shareable x p m h i write-record)))]
-        ;[(code? x)
-        ; (write-char* "#<code>" p)]
-        [(hash-table? x)
-         (write-char* "#<hash-table>" p)
-         i]
-        [($unbound-object? x)
-         (write-char* "#<unbound-object>" p)
-         i]
-        [($forward-ptr? x)
-         (write-char* "#<forward-ptr>" p)
-         i]
-        [else 
-         (write-char* "#<unknown>" p)
-         i])))
-
-  (define print-graph (make-parameter #f))
-
-  (define (hasher x h)
-    (define (vec-graph x i j h)
-      (unless (fx= i j)
-        (graph (vector-ref x i) h)
-        (vec-graph x (fxadd1 i) j h)))
-    (define (vec-dynamic x i j h)
-      (unless (fx= i j)
-        (dynamic (vector-ref x i) h)
-        (vec-dynamic x (fxadd1 i) j h))) 
-    (define (graph x h)
-      (cond
-        [(pair? x)
-         (cond
-           [(get-hash-table h x #f) =>
-            (lambda (n)
-              (put-hash-table! h x (fxadd1 n)))]
-           [else
-            (put-hash-table! h x 0)
-            (graph (car x) h)
-            (graph (cdr x) h)])]
-        [(vector? x)
-         (cond
-           [(get-hash-table h x #f) =>
-            (lambda (n)
-              (put-hash-table! h x (fxadd1 n)))]
-           [else
-            (put-hash-table! h x 0)
-            (vec-graph x 0 (vector-length x) h)])]
-        [(gensym? x)
-         (cond
-           [(get-hash-table h x #f) =>
-            (lambda (n)
-              (put-hash-table! h x (fxadd1 n)))])]))
-    (define (dynamic x h)
-      (cond
-        [(pair? x)
-         (cond
-           [(get-hash-table h x #f) =>
-            (lambda (n)
-              (put-hash-table! h x (fxadd1 n)))]
-           [else
-            (put-hash-table! h x 0)
-            (dynamic (car x) h)
-            (dynamic (cdr x) h)
-            (when (and (get-hash-table h x #f)
-                       (fxzero? (get-hash-table h x #f)))
-              (put-hash-table! h x #f))])]
-        [(vector? x)
-         (cond
-           [(get-hash-table h x #f) =>
-            (lambda (n)
-              (put-hash-table! h x (fxadd1 n)))]
-           [else
-            (put-hash-table! h x 0)
-            (vec-dynamic x 0 (vector-length x) h)
-            (when (and (get-hash-table h x #f)
-                       (fxzero? (get-hash-table h x #f)))
-              (put-hash-table! h x #f))])])) 
-    (if (print-graph) 
-        (graph x h)
-        (dynamic x h)))
-
-  (define (write x p)
-    (let ([h (make-hash-table)])
-      (hasher x h)
-      (writer x p #t h 0))
-    (flush-output-port p))
-  ;;;
-  (define (display x p)
-    (let ([h (make-hash-table)])
-      (hasher x h)
-      (writer x p #f h 0))
-    (flush-output-port p))
-  ;;;
-  (define formatter
-    (lambda (who p fmt args)
-      (let f ([i 0] [args args])
-        (unless (fx= i (string-length fmt))
-          (let ([c (string-ref fmt i)])
-            (cond
-              [($char= c #\~)
-               (let ([i (fxadd1 i)])
-                 (when (fx= i (string-length fmt))
-                   (error who "invalid ~~ at end of format string ~s" fmt))
-                 (let ([c (string-ref fmt i)])
-                  (cond
-                    [($char= c #\~) 
-                     (write-char #\~ p)
-                     (f (fxadd1 i) args)]
-                    [($char= c #\a)
-                     (when (null? args)
-                       (error who "insufficient arguments"))
-                     (display (car args) p)
-                     (f (fxadd1 i) (cdr args))]
-                    [($char= c #\s)
-                     (when (null? args)
-                       (error who "insufficient arguments"))
-                     (write (car args) p)
-                     (f (fxadd1 i) (cdr args))]
-                    [else
-                     (error who "invalid sequence ~~~a" c)])))]
-              [else 
-               (write-char c p)
-               (f (fxadd1 i) args)]))))))
-
-  (define fprintf
-    (lambda (port fmt . args)
-      (unless (output-port? port) 
-        (error 'fprintf "~s is not an output port" port))
-      (unless (string? fmt)
-        (error 'fprintf "~s is not a string" fmt))
-      (formatter 'fprintf port fmt args)))
-
-  (define printf
-    (lambda (fmt . args)
-      (unless (string? fmt)
-        (error 'printf "~s is not a string" fmt))
-      (formatter 'printf (current-output-port) fmt args)))
-
-  (define format
-    (lambda (fmt . args)
-      (unless (string? fmt)
-        (error 'format "~s is not a string" fmt))
-      (let ([p (open-output-string)])
-        (formatter 'format p fmt args)
-        (get-output-string p))))
-
-  (define print-error
-    (lambda (who fmt . args)
-      (unless (string? fmt)
-        (error 'print-error "~s is not a string" fmt))
-      (let ([p (standard-error-port)])
-        (if who
-            (fprintf p "Error in ~a: " who)
-            (fprintf p "Error: "))
-        (formatter 'print-error p fmt args)
-        (write-char #\. p)
-        (newline p))))
-
-  
-  ;;;
-  (primitive-set! 'format format)
-  (primitive-set! 'printf printf)
-  (primitive-set! 'fprintf fprintf)
-  (primitive-set! 'print-graph print-graph)
-  (primitive-set! 'write 
-    (case-lambda
-      [(x) (write x (current-output-port))]
-      [(x p)
-       (unless (output-port? p) 
-         (error 'write "~s is not an output port" p))
-       (write x p)]))
-  (primitive-set! 'display 
-    (case-lambda
-      [(x) (display x (current-output-port))]
-      [(x p)
-       (unless (output-port? p) 
-         (error 'display "~s is not an output port" p))
-       (display x p)]))
-  (primitive-set! 'print-error print-error)
-  (primitive-set! 'current-error-handler
-    (make-parameter
-      (lambda args
-        (apply print-error args)
-        (display "exiting\n" (console-output-port))
-        (flush-output-port (console-output-port))
-        (exit -100))
-      (lambda (x)
-        (if (procedure? x)
-            x
-            (error 'current-error-handler "~s is not a procedure" x)))))
-  (primitive-set! 'error
-    (lambda args
-      (apply (current-error-handler) args)))) 
-
diff --git a/src/libwriter-9.1.ss b/src/libwriter.ss
similarity index 100%
rename from src/libwriter-9.1.ss
rename to src/libwriter.ss
diff --git a/src/makefile.ss b/src/makefile.ss
index dcd206b..86252bb 100644
--- a/src/makefile.ss
+++ b/src/makefile.ss
@@ -241,27 +241,27 @@
 (whack-system-env #t)
 
 (define scheme-library-files
-  '(["libhandlers-6.9.ss"   #t  "libhandlers.fasl"]
-    ["libcontrol-6.1.ss"    #t  "libcontrol.fasl"]
-    ["libcollect-6.1.ss"    #t  "libcollect.fasl"]
-    ["librecord-6.4.ss"     #t  "librecord.fasl"]
-    ["libcxr-6.0.ss"        #t  "libcxr.fasl"]
-    ["libnumerics-9.1.ss"   #t  "libnumerics.fasl"]
-    ["libcore-6.9.ss"       #t  "libcore.fasl"]
-    ["libchezio-8.1.ss"     #t  "libchezio.fasl"]
-    ["libhash-9.2.ss"       #t  "libhash.fasl"]
-    ["libwriter-9.1.ss"     #t  "libwriter.fasl"]
-    ["libtokenizer-9.1.ss"  #t  "libtokenizer.fasl"]
-    ["libassembler-6.7.ss"  #t  "libassembler.fasl"]
-    ["libintelasm-6.9.ss"   #t  "libintelasm.fasl"]
-    ["libfasl-6.7.ss"       #t  "libfasl.fasl"]
-    ["libcompile-9.1.ss"    #t  "libcompile.fasl"]
-    ["psyntax-7.1-9.1.ss"   #t  "psyntax.fasl"]
-    ["libinterpret-6.5.ss"  #t  "libinterpret.fasl"]
-    ["libcafe-6.1.ss"       #t  "libcafe.fasl"]
-    ["libtrace-6.9.ss"      #t  "libtrace.fasl"]
-    ["libposix-6.0.ss"      #t  "libposix.fasl"]
-    ["libtoplevel-6.9.ss"   #t  "libtoplevel.fasl"]
+  '(["libhandlers.ss"   #t  "libhandlers.fasl"]
+    ["libcontrol.ss"    #t  "libcontrol.fasl"]
+    ["libcollect.ss"    #t  "libcollect.fasl"]
+    ["librecord.ss"     #t  "librecord.fasl"]
+    ["libcxr.ss"        #t  "libcxr.fasl"]
+    ["libnumerics.ss"   #t  "libnumerics.fasl"]
+    ["libcore.ss"       #t  "libcore.fasl"]
+    ["libchezio.ss"     #t  "libchezio.fasl"]
+    ["libhash.ss"       #t  "libhash.fasl"]
+    ["libwriter.ss"     #t  "libwriter.fasl"]
+    ["libtokenizer.ss"  #t  "libtokenizer.fasl"]
+    ["libassembler.ss"  #t  "libassembler.fasl"]
+    ["libintelasm.ss"   #t  "libintelasm.fasl"]
+    ["libfasl.ss"       #t  "libfasl.fasl"]
+    ["libcompile.ss"    #t  "libcompile.fasl"]
+    ["psyntax-7.1.ss"   #t  "psyntax.fasl"]
+    ["libinterpret.ss"  #t  "libinterpret.fasl"]
+    ["libcafe.ss"       #t  "libcafe.fasl"]
+    ["libtrace.ss"      #t  "libtrace.fasl"]
+    ["libposix.ss"      #t  "libposix.fasl"]
+    ["libtoplevel.ss"   #t  "libtoplevel.fasl"]
     ))
 
 
diff --git a/src/psyntax-7.1-6.9.ss b/src/psyntax-7.1-6.9.ss
deleted file mode 100644
index e50e456..0000000
--- a/src/psyntax-7.1-6.9.ss
+++ /dev/null
@@ -1,4711 +0,0 @@
-;;; Portable implementation of syntax-case
-;;; Extracted from Chez Scheme Version 7.1 (Aug 01, 2006)
-;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
-
-;;; Copyright (c) 1992-2002 Cadence Research Systems
-;;; Permission to copy this software, in whole or in part, to use this
-;;; software for any lawful purpose, and to redistribute this software
-;;; is granted subject to the restriction that all copies made of this
-;;; software must include this copyright notice in full.  This software
-;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
-;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
-;;; OR FITNESS FOR ANY PARTICULAR PURPOSE.  IN NO EVENT SHALL THE
-;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
-;;; NATURE WHATSOEVER.
-
-;;; Before attempting to port this code to a new implementation of
-;;; Scheme, please read the notes below carefully.
-
-;;; This file defines the syntax-case expander, sc-expand, and a set
-;;; of associated syntactic forms and procedures.  Of these, the
-;;; following are documented in The Scheme Programming Language,
-;;; Third Edition (R. Kent Dybvig, MIT Press, 2003), which can be
-;;; found online at http://www.scheme.com/tspl3/.  Most are also documented
-;;; in the R4RS and draft R5RS.
-;;;
-;;;   bound-identifier=?
-;;;   datum->syntax-object
-;;;   define-syntax
-;;;   fluid-let-syntax
-;;;   free-identifier=?
-;;;   generate-temporaries
-;;;   identifier?
-;;;   identifier-syntax
-;;;   let-syntax
-;;;   letrec-syntax
-;;;   syntax
-;;;   syntax-case
-;;;   syntax-object->datum
-;;;   syntax-rules
-;;;   with-syntax
-;;;
-;;; All standard Scheme syntactic forms are supported by the expander
-;;; or syntactic abstractions defined in this file.  Only the R4RS
-;;; delay is omitted, since its expansion is implementation-dependent.
-
-;;; Also defined are three forms that support modules: module, import,
-;;; and import-only.  These are documented in the Chez Scheme User's
-;;; Guide (R. Kent Dybvig, Cadence Research Systems, 1998), which can
-;;; also be found online at http://www.scheme.com/csug/.  They are
-;;; described briefly here as well.
-    
-;;; All are definitions and may appear where and only where other
-;;; definitions may appear.  modules may be named:
-;;;
-;;;   (module id (ex ...) defn ... init ...)
-;;;
-;;; or anonymous:
-;;;
-;;;   (module (ex ...) defn ... init ...)
-;;;
-;;; The latter form is semantically equivalent to:
-;;;
-;;;   (module T (ex ...) defn ... init ...)
-;;;   (import T)
-;;;
-;;; where T is a fresh identifier.
-;;;
-;;; In either form, each of the exports in (ex ...) is either an
-;;; identifier or of the form (id ex ...).  In the former case, the
-;;; single identifier ex is exported.  In the latter, the identifier
-;;; id is exported and the exports ex ... are "implicitly" exported.
-;;; This listing of implicit exports is useful only when id is a
-;;; keyword bound to a transformer that expands into references to
-;;; the listed implicit exports.  In the present implementation,
-;;; listing of implicit exports is necessary only for top-level
-;;; modules and allows the implementation to avoid placing all
-;;; identifiers into the top-level environment where subsequent passes
-;;; of the compiler will be unable to deal effectively with them.
-;;;
-;;; Named modules may be referenced in import statements, which
-;;; always take one of the forms:
-;;;
-;;;   (import id)
-;;;   (import-only id)
-;;;
-;;; id must name a module.  Each exported identifier becomes visible
-;;; within the scope of the import form.  In the case of import-only,
-;;; all other identifiers become invisible in the scope of the
-;;; import-only form, except for those established by definitions
-;;; that appear textually after the import-only form.
-
-;;; import and import-only also support a variety of identifier
-;;; selection and renaming forms: only, except, add-prefix,
-;;; drop-prefix, rename, and alias.
-;;;
-;;;   (import (only m x y))
-;;; 
-;;; imports x and y (and nothing else) from m.
-;;;
-;;;   (import (except m x y))
-;;; 
-;;; imports all of m's imports except for x and y.
-;;;
-;;;   (import (add-prefix (only m x y) m:))
-;;; 
-;;; imports x and y as m:x and m:y.
-;;;
-;;;   (import (drop-prefix m foo:))
-;;; 
-;;; imports all of m's imports, dropping the common foo: prefix
-;;; (which must appear on all of m's exports).
-;;; 
-;;;   (import (rename (except m a b) (m-c c) (m-d d)))
-;;; 
-;;; imports all of m's imports except for x and y, renaming c
-;;; m-c and d m-d.
-;;; 
-;;;   (import (alias (except m a b) (m-c c) (m-d d)))
-;;; 
-;;; imports all of m's imports except for x and y, with additional
-;;; aliases m-c for c and m-d for d.
-;;; 
-;;; multiple imports may be specified with one import form:
-;;; 
-;;;   (import (except m1 x) (only m2 x))
-;;; 
-;;; imports all of m1's exports except for x plus x from m2.
-
-;;; Another form, meta, may be used as a prefix for any definition and
-;;; causes any resulting variable bindings to be created at expansion
-;;; time.  Meta variables (variables defined using meta) are available
-;;; only at expansion time.  Meta definitions are often used to create
-;;; data and helpers that can be shared by multiple macros, for example:
-
-;;; (module (alpha beta)
-;;;   (meta define key-error
-;;;     (lambda (key)
-;;;       (syntax-error key "invalid key")))
-;;;   (meta define parse-keys
-;;;     (lambda (keys)
-;;;       (let f ((keys keys) (c #'white) (s 10))
-;;;         (syntax-case keys (color size)
-;;;           (() (list c s))
-;;;           (((color c) . keys) (f #'keys #'c s))
-;;;           (((size s) . keys) (f #'keys c #'s))
-;;;           ((k . keys) (key-error #'k))))))
-;;;   (define-syntax alpha
-;;;     (lambda (x)
-;;;       (syntax-case x ()
-;;;         ((_ (k ...) <other stuff>)
-;;;          (with-syntax (((c s) (parse-keys (syntax (k ...)))))
-;;;            ---)))))
-;;;   (define-syntax beta
-;;;     (lambda (x)
-;;;       (syntax-case x ()
-;;;         ((_ (k ...) <other stuff>)
-;;;          (with-syntax (((c s) (parse-keys (syntax (k ...)))))
-;;;            ---))))))
-
-;;; As with define-syntax rhs expressions, meta expressions can evaluate
-;;; references only to identifiers whose values are (already) available
-;;; in the compile-time environment, e.g., macros and meta variables.
-;;; They can, however, like define-syntax rhs expressions, build syntax
-;;; objects containing occurrences of any identifiers in their scope.
-
-;;; meta definitions propagate through macro expansion, so one can write,
-;;; for example:
-;;; 
-;;;   (module (a)
-;;;     (meta define-structure (foo x))
-;;;     (define-syntax a
-;;;       (let ((q (make-foo (syntax 'q))))
-;;;         (lambda (x)
-;;;           (foo-x q)))))
-;;;   a -> q
-;;; 
-;;; where define-record is a macro that expands into a set of defines.
-;;; 
-;;; It is also sometimes convenient to write
-;;; 
-;;;   (meta begin defn ...)
-;;; 
-;;; or
-;;; 
-;;;   (meta module {exports} defn ...)
-;;; 
-;;; to create groups of meta bindings.
-
-;;; Another form, alias, is used to create aliases from one identifier
-;;; to another.  This is used primarily to support the extended import
-;;; syntaxes (add-prefix, drop-prefix, rename, and alias).
-
-;;; (let ((x 3)) (alias y x) y) -> 3
-
-;;; The remaining exports are listed below.  sc-expand, eval-when, and
-;;; syntax-error are described in the Chez Scheme User's Guide.
-;;;
-;;;   (sc-expand datum)
-;;;      if datum represents a valid expression, sc-expand returns an
-;;;      expanded version of datum in a core language that includes no
-;;;      syntactic abstractions.  The core language includes begin,
-;;;      define, if, lambda, letrec, quote, and set!.
-;;;   (eval-when situations expr ...)
-;;;      conditionally evaluates expr ... at compile-time or run-time
-;;;      depending upon situations
-;;;   (syntax-error object message)
-;;;      used to report errors found during expansion
-;;;   ($syntax-dispatch e p)
-;;;      used by expanded code to handle syntax-case matching
-;;;   ($sc-put-cte symbol val top-token)
-;;;      used to establish top-level compile-time (expand-time) bindings.
-
-;;; The following nonstandard procedures must be provided by the
-;;; implementation for this code to run.
-;;;
-;;; (void)
-;;; returns the implementation's cannonical "unspecified value".  The
-;;; following usually works:
-;;;
-;;; (define void (lambda () (if #f #f))).
-;;;
-;;; (andmap proc list1 list2 ...)
-;;; returns true if proc returns true when applied to each element of list1
-;;; along with the corresponding elements of list2 ....  The following
-;;; definition works but does no error checking:
-;;;
-;;; (define andmap
-;;;   (lambda (f first . rest)
-;;;     (or (null? first)
-;;;         (if (null? rest)
-;;;             (let andmap ((first first))
-;;;               (let ((x (car first)) (first (cdr first)))
-;;;                 (if (null? first)
-;;;                     (f x)
-;;;                     (and (f x) (andmap first)))))
-;;;             (let andmap ((first first) (rest rest))
-;;;               (let ((x (car first))
-;;;                     (xr (map car rest))
-;;;                     (first (cdr first))
-;;;                     (rest (map cdr rest)))
-;;;                 (if (null? first)
-;;;                     (apply f (cons x xr))
-;;;                     (and (apply f (cons x xr)) (andmap first rest)))))))))
-;;;
-;;; (ormap proc list1)
-;;; returns the first non-false return result of proc applied to
-;;; the elements of list1 or false if none.  The following definition
-;;; works but does no error checking:
-;;;
-;;; (define ormap
-;;;   (lambda (proc list1)
-;;;     (and (not (null? list1))
-;;;          (or (proc (car list1)) (ormap proc (cdr list1))))))
-;;;
-;;; The following nonstandard procedures must also be provided by the
-;;; implementation for this code to run using the standard portable
-;;; hooks and output constructors.  They are not used by expanded code,
-;;; and so need be present only at expansion time.
-;;;
-;;; (eval x)
-;;; where x is always in the form ("noexpand" expr).
-;;; returns the value of expr.  the "noexpand" flag is used to tell the
-;;; evaluator/expander that no expansion is necessary, since expr has
-;;; already been fully expanded to core forms.
-;;;
-;;; eval will not be invoked during the loading of psyntax.pp.  After
-;;; psyntax.pp has been loaded, the expansion of any macro definition,
-;;; whether local or global, results in a call to eval.  If, however,
-;;; sc-expand has already been registered as the expander to be used
-;;; by eval, and eval accepts one argument, nothing special must be done
-;;; to support the "noexpand" flag, since it is handled by sc-expand.
-;;;
-;;; (error who format-string why what)
-;;; where who is either a symbol or #f, format-string is always "~a ~s",
-;;; why is always a string, and what may be any object.  error should
-;;; signal an error with a message something like
-;;;
-;;;    "error in <who>: <why> <what>"
-;;;
-;;; (gensym)
-;;; returns a unique symbol each time it's called.  In Chez Scheme, gensym
-;;; returns a symbol with a "globally" unique name so that gensyms that
-;;; end up in the object code of separately compiled files cannot conflict.
-;;; This is necessary only if you intend to support compiled files.
-;;;
-;;; (gensym? x)
-;;; returns #t if x is a gensym, otherwise false.
-;;;
-;;; (putprop symbol key value)
-;;; (getprop symbol key)
-;;; (remprop symbol key)
-;;; key is always a symbol; value may be any object.  putprop should
-;;; associate the given value with the given symbol and key in some way
-;;; that it can be retrieved later with getprop.  getprop should return
-;;; #f if no value is associated with the given symbol and key.  remprop
-;;; should remove the association between the given symbol and key.
-
-;;; When porting to a new Scheme implementation, you should define the
-;;; procedures listed above, load the expanded version of psyntax.ss
-;;; (psyntax.pp, which should be available whereever you found
-;;; psyntax.ss), and register sc-expand as the current expander (how
-;;; you do this depends upon your implementation of Scheme).  You may
-;;; change the hooks and constructors defined toward the beginning of
-;;; the code below, but to avoid bootstrapping problems, do so only
-;;; after you have a working version of the expander.
-
-;;; Chez Scheme allows the syntactic form (syntax <template>) to be
-;;; abbreviated to #'<template>, just as (quote <datum>) may be
-;;; abbreviated to '<datum>.  The #' syntax makes programs written
-;;; using syntax-case shorter and more readable and draws out the
-;;; intuitive connection between syntax and quote.  If you have access
-;;; to the source code of your Scheme system's reader, you might want
-;;; to implement this extension.
-
-;;; If you find that this code loads or runs slowly, consider
-;;; switching to faster hardware or a faster implementation of
-;;; Scheme.  In Chez Scheme on a 200Mhz Pentium Pro, expanding,
-;;; compiling (with full optimization), and loading this file takes
-;;; between one and two seconds.
-
-;;; In the expander implementation, we sometimes use syntactic abstractions
-;;; when procedural abstractions would suffice.  For example, we define
-;;; top-wrap and top-marked? as
-;;;   (define-syntax top-wrap (identifier-syntax '((top))))
-;;;   (define-syntax top-marked?
-;;;     (syntax-rules ()
-;;;       ((_ w) (memq 'top (wrap-marks w)))))
-;;; rather than
-;;;   (define top-wrap '((top)))
-;;;   (define top-marked?
-;;;     (lambda (w) (memq 'top (wrap-marks w))))
-;;; On ther other hand, we don't do this consistently; we define make-wrap,
-;;; wrap-marks, and wrap-subst simply as
-;;;   (define make-wrap cons)
-;;;   (define wrap-marks car)
-;;;   (define wrap-subst cdr)
-;;; In Chez Scheme, the syntactic and procedural forms of these
-;;; abstractions are equivalent, since the optimizer consistently
-;;; integrates constants and small procedures.  Some Scheme
-;;; implementations, however, may benefit from more consistent use
-;;; of one form or the other.
-
-
-;;; Implementation notes:
-
-;;; "begin" is treated as a splicing construct at top level and at
-;;; the beginning of bodies.  Any sequence of expressions that would
-;;; be allowed where the "begin" occurs is allowed.
-
-;;; "let-syntax" and "letrec-syntax" are also treated as splicing
-;;; constructs, in violation of the R5RS.  A consequence is that let-syntax
-;;; and letrec-syntax do not create local contours, as do let and letrec.
-;;; Although the functionality is greater as it is presently implemented,
-;;; we will probably change it to conform to the R5RS.  modules provide
-;;; similar functionality to nonsplicing letrec-syntax when the latter is
-;;; used as a definition.
-
-;;; Objects with no standard print syntax, including objects containing
-;;; cycles and syntax objects, are allowed in quoted data as long as they
-;;; are contained within a syntax form or produced by datum->syntax-object.
-;;; Such objects are never copied.
-
-;;; When the expander encounters a reference to an identifier that has
-;;; no global or lexical binding, it treats it as a global-variable
-;;; reference.  This allows one to write mutually recursive top-level
-;;; definitions, e.g.:
-;;;
-;;;   (define f (lambda (x) (g x)))
-;;;   (define g (lambda (x) (f x)))
-;;;
-;;; but may not always yield the intended when the variable in question
-;;; is later defined as a keyword.
-
-;;; Top-level variable definitions of syntax keywords are permitted.
-;;; In order to make this work, top-level define not only produces a
-;;; top-level definition in the core language, but also modifies the
-;;; compile-time environment (using $sc-put-cte) to record the fact
-;;; that the identifier is a variable.
-
-;;; Top-level definitions of macro-introduced identifiers are visible
-;;; only in code produced by the macro.  That is, a binding for a
-;;; hidden (generated) identifier is created instead, and subsequent
-;;; references within the macro output are renamed accordingly.  For
-;;; example:
-;;;
-;;; (define-syntax a
-;;;   (syntax-rules ()
-;;;     ((_ var exp)
-;;;      (begin
-;;;        (define secret exp)
-;;;        (define var
-;;;          (lambda ()
-;;;            (set! secret (+ secret 17))
-;;;            secret))))))
-;;; (a x 0)
-;;; (x) => 17
-;;; (x) => 34
-;;; secret => Error: variable secret is not bound
-;;;
-;;; The definition above would fail if the definition for secret
-;;; were placed after the definition for var, since the expander would
-;;; encounter the references to secret before the definition that
-;;; establishes the compile-time map from the identifier secret to
-;;; the generated identifier.
-
-;;; Identifiers and syntax objects are implemented as vectors for
-;;; portability.  As a result, it is possible to "forge" syntax
-;;; objects.
-
-;;; The input to sc-expand may contain "annotations" describing, e.g., the
-;;; source file and character position from where each object was read if
-;;; it was read from a file.  These annotations are handled properly by
-;;; sc-expand only if the annotation? hook (see hooks below) is implemented
-;;; properly and the operators annotation-expression and annotation-stripped
-;;; are supplied.  If annotations are supplied, the proper annotated
-;;; expression is passed to the various output constructors, allowing
-;;; implementations to accurately correlate source and expanded code.
-;;; Contact one of the authors for details if you wish to make use of
-;;; this feature.
-
-;;; Implementation of modules:
-;;;
-;;; The implementation of modules requires that implicit top-level exports
-;;; be listed with the exported macro at some level where both are visible,
-;;; e.g.,
-;;;
-;;;   (module M (alpha (beta b))
-;;;     (module ((alpha a) b)
-;;;       (define-syntax alpha (identifier-syntax a))
-;;;       (define a 'a)
-;;;       (define b 'b))
-;;;     (define-syntax beta (identifier-syntax b)))
-;;;
-;;; Listing of implicit imports is not needed for macros that do not make
-;;; it out to top level, including all macros that are local to a "body".
-;;; (They may be listed in this case, however.)  We need this information
-;;; for top-level modules since a top-level module expands into a letrec
-;;; for non-top-level variables and top-level definitions (assignments) for
-;;; top-level variables.  Because of the general nature of macro
-;;; transformers, we cannot determine the set of implicit exports from the
-;;; transformer code, so without the user's help, we'd have to put all
-;;; variables at top level.
-;;;
-;;; Each such top-level identifier is given a generated name (gensym).
-;;; When a top-level module is imported at top level, a compile-time
-;;; alias is established from the top-level name to the generated name.
-;;; The expander follows these aliases transparently.  When any module is
-;;; imported anywhere other than at top level, the id-var-name of the
-;;; import identifier is set to the id-var-name of the export identifier.
-;;; Since we can't determine the actual labels for identifiers defined in
-;;; top-level modules until we determine which are placed in the letrec
-;;; and which make it to top level, we give each an "indirect" label---a
-;;; pair whose car will eventually contain the actual label.  Import does
-;;; not follow the indirect, but id-var-name does.
-;;;
-;;; All identifiers defined within a local module are folded into the
-;;; letrec created for the enclosing body.  Visibility is controlled in
-;;; this case and for nested top-level modules by introducing a new wrap
-;;; for each module.
-
-
-;;; Bootstrapping:
-
-;;; When changing syntax-object representations, it is necessary to support
-;;; both old and new syntax-object representations in id-var-name.  It
-;;; should be sufficient to redefine syntax-object-expression to work for
-;;; both old and new representations and syntax-object-wrap to return the
-;;; empty-wrap for old representations.
-
-
-;;; The following set of definitions establishes bindings for the
-;;; top-level variables assigned values in the let expression below.
-;;; Uncomment them here and copy them to the front of psyntax.pp if
-;;; required by your system.
-
-; (define $sc-put-cte #f)
-; (define sc-expand #f)
-; (define $make-environment #f)
-; (define environment? #f)
-; (define interaction-environment #f)
-; (define identifier? #f)
-; (define syntax->list #f)
-; (define syntax-object->datum #f)
-; (define datum->syntax-object #f)
-; (define generate-temporaries #f)
-; (define free-identifier=? #f)
-; (define bound-identifier=? #f)
-; (define literal-identifier=? #f)
-; (define syntax-error #f)
-; (define $syntax-dispatch #f)
-
-
-(let ()
-
-(define-syntax when
-  (syntax-rules ()
-    ((_ test e1 e2 ...) (if test (begin e1 e2 ...)))))
-(define-syntax unless
-  (syntax-rules ()
-    ((_ test e1 e2 ...) (when (not test) (begin e1 e2 ...)))))
-(define-syntax define-structure
-  (lambda (x)
-    (define construct-name
-      (lambda (template-identifier . args)
-        (datum->syntax-object
-          template-identifier
-          (string->symbol
-            (apply string-append
-                   (map (lambda (x)
-                          (if (string? x)
-                              x
-                              (symbol->string (syntax-object->datum x))))
-                        args))))))
-    (syntax-case x ()
-      ((_ (name id1 ...))
-       (andmap identifier? (syntax (name id1 ...)))
-       (with-syntax
-         ((constructor (construct-name (syntax name) "make-" (syntax name)))
-          (predicate (construct-name (syntax name) (syntax name) "?"))
-          ((access ...)
-           (map (lambda (x) (construct-name x (syntax name) "-" x))
-                (syntax (id1 ...))))
-          ((assign ...)
-           (map (lambda (x)
-                  (construct-name x "set-" (syntax name) "-" x "!"))
-                (syntax (id1 ...))))
-          (structure-length
-           (fx+ (length (syntax (id1 ...))) 1))
-          ((index ...)
-           (let f ((i 1) (ids (syntax (id1 ...))))
-              (if (null? ids)
-                  '()
-                  (cons i (f (fx+ i 1) (cdr ids)))))))
-         (syntax (begin
-                   (define constructor
-                     (lambda (id1 ...)
-                       (vector 'name id1 ... )))
-                   (define predicate
-                     (lambda (x)
-                       (and (vector? x)
-                            (fx= (vector-length x) structure-length)
-                            (eq? (vector-ref x 0) 'name))))
-                   (define access
-                     (lambda (x)
-                       (vector-ref x index)))
-                   ...
-                   (define assign
-                     (lambda (x update)
-                       (vector-set! x index update)))
-                   ...)))))))
-
-(define-syntax let-values ; impoverished one-clause version
-  (syntax-rules ()
-    ((_ ((formals expr)) form1 form2 ...)
-     (call-with-values (lambda () expr) (lambda formals form1 form2 ...)))))
-
-(define noexpand "noexpand")
-
-(define-structure (syntax-object expression wrap))
-
-;;; hooks to nonportable run-time helpers
-(begin
-;(define-syntax fx+ (identifier-syntax +))
-;(define-syntax fx- (identifier-syntax -))
-;(define-syntax fx= (identifier-syntax =))
-;(define-syntax fx< (identifier-syntax <))
-;(define-syntax fx> (identifier-syntax >))
-;(define-syntax fx<= (identifier-syntax <=))
-;(define-syntax fx>= (identifier-syntax >=))
-
-(define annotation? (lambda (x) #f))
-(define annotation-expression 
-  (lambda (x) (error 'annotation-expression "not yet")))
-(define annotation-stripped 
-  (lambda (x) (error 'annotation-stripped "not yet")))
-
-; top-level-eval-hook is used to create "permanent" code (e.g., top-level
-; transformers), so it might be a good idea to compile it
-(define top-level-eval-hook
-  (lambda (x)
-    (eval `(,noexpand ,x))))
-
-; local-eval-hook is used to create "temporary" code (e.g., local
-; transformers), so it might be a good idea to interpret it
-(define local-eval-hook
-  (lambda (x)
-    (eval `(,noexpand ,x))))
-
-(define define-top-level-value-hook
-  (lambda (sym val)
-    (top-level-eval-hook
-      (build-global-definition no-source sym
-        (build-data no-source val)))))
-
-(define error-hook
-  (lambda (who why what)
-    (error who "~a ~s" why what)))
-
-(define-syntax gensym-hook
-  (syntax-rules ()
-    ((_) (gensym))))
-
-;;; AZIZ
-;;; (define put-cte-hook
-;;;   (lambda (symbol val)
-;;;     ($sc-put-cte symbol val '*top*)))
-
-(define put-cte-hook
-  (lambda (symbol val)
-    ($sc-put-cte symbol val '*top*)))
-
-(define get-global-definition-hook
-  (lambda (symbol)
-    (getprop symbol '*sc-expander*)))
-
-(define put-global-definition-hook
-  (lambda (symbol x)
-    (if (not x)
-        (remprop symbol '*sc-expander*)
-        (putprop symbol '*sc-expander* x))))
-
-; if you treat certain bindings (say from environments like ieee or r5rs)
-; read-only, this should return #t for those bindings
-(define read-only-binding?
-  (lambda (symbol)
-    #f))
-
-; should return #f if symbol has no binding for token
-(define get-import-binding
-  (lambda (symbol token)
-    (getprop symbol token)))
-
-; remove binding if x is false
-(define put-import-binding
-  (lambda (symbol token x)
-    (if (not x)
-        (remprop symbol token)
-        (putprop symbol token x))))
-
-;;; generate-id ideally produces globally unique symbols, i.e., symbols
-;;; unique across system runs, to support separate compilation/expansion.
-;;; Use gensym-hook if you do not need to support separate compilation/
-;;; expansion or if your system's gensym creates globally unique
-;;; symbols (as in Chez Scheme).  Otherwise, use the following code
-;;; as a starting point.  session-key should be a unique string for each
-;;; system run to support separate compilation; the default value given
-;;; is satisfactory during initial development only.
-;(define generate-id
-;  (let ((digits "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!$%&*/:<=>?~_^.+-"))
-;    (let ((base (string-length digits)) (session-key "_"))
-;      (define make-digit (lambda (x) (string-ref digits x)))
-;      (define fmt
-;        (lambda (n)
-;          (let fmt ((n n) (a '()))
-;            (if (< n base)
-;                (list->string (cons (make-digit n) a))
-;                (let ((r (modulo n base)) (rest (quotient n base)))
-;                  (fmt rest (cons (make-digit r) a)))))))
-;      (let ((n -1))
-;        (lambda (name) ; name is #f or a symbol
-;          (set! n (+ n 1))
-;          (string->symbol (string-append session-key (fmt n))))))))
-;;; AZIZ
-(define generate-id
-  (lambda (name)
-    (if name (gensym (symbol->string name)) (gensym))))
-)
-
-
-
-;;; output constructors
-(begin
-(define-syntax build-application
-  (syntax-rules ()
-    ((_ ae fun-exp arg-exps)
-     `(,fun-exp . ,arg-exps))))
-
-(define-syntax build-conditional
-  (syntax-rules ()
-    ((_ ae test-exp then-exp else-exp)
-     `(if ,test-exp ,then-exp ,else-exp))))
-
-(define-syntax build-lexical-reference
-  (syntax-rules ()
-    ((_ type ae var)
-     var)))
-
-(define-syntax build-lexical-assignment
-  (syntax-rules ()
-    ((_ ae var exp)
-     `(set! ,var ,exp))))
-
-;;; AZIZ
-;;; (define-syntax build-global-reference
-;;;   (syntax-rules ()
-;;;     ((_ ae var)
-;;;      var)))
-(define-syntax build-global-reference
-  (syntax-rules ()
-    [(_ ae var)
-     `(top-level-value ',var)]))
-
-;;; AZIZ
-;;; (define-syntax build-global-assignment
-;;;   (syntax-rules ()
-;;;     ((_ ae var exp)
-;;;      `(set! ,var ,exp))))
-(define-syntax build-global-assignment
-  (syntax-rules ()
-    [(_ ae var exp)
-     `(set-top-level-value! ',var ,exp)]))
-
-;;; AZIZ
-;;; (define-syntax build-global-definition
-;;;   (syntax-rules ()
-;;;     ((_ ae var exp)
-;;;      `(define ,var ,exp))))
-(define-syntax build-global-definition
-  (syntax-rules ()
-    [(_ ae var exp)
-     (build-global-assignment ae var exp)]))
-
-
-(define-syntax build-cte-install
- ; should build a call that has the same effect as calling put-cte-hook
-  (syntax-rules ()
-    ((_ sym exp token) 
-     `(#%$sc-put-cte ',sym ,exp ',token))))
-
-(define-syntax build-visit-only
- ; should mark the result as "visit only" for compile-file
- ; in implementations that support visit/revisit
-  (syntax-rules ()
-    ((_ exp) exp)))
-
-(define-syntax build-revisit-only
- ; should mark the result as "revisit only" for compile-file,
- ; in implementations that support visit/revisit
-  (syntax-rules ()
-    ((_ exp) exp)))
-
-;;; AZIZ
-;;; (define-syntax build-lambda
-;;;   (syntax-rules ()
-;;;     ((_ ae vars exp)
-;;;      `(lambda ,vars ,exp))))
-(define-syntax build-lambda
-  (syntax-rules ()
-    [(_ ae vars exp)
-     `(case-lambda [,vars ,exp])]))
-
-(define build-case-lambda
-  (lambda (ae vars* exp*)
-    `(case-lambda . ,(map list vars* exp*))))
-
-;;; AZIZ
-;;; (define built-lambda?
-;;;   (lambda (x)
-;;;     (and (pair? x) (eq? (car x) 'lambda))))
-(define built-lambda?
-  (lambda (x)
-    (and (pair? x) (eq? (car x) 'case-lambda))))
-
-;;; AZIZ
-;;; (define-syntax build-primref
-;;;   (syntax-rules ()
-;;;     ((_ ae name) name)
-;;;     ((_ ae level name) name)))
-(define-syntax build-primref
-  (syntax-rules ()
-    [(_ ae name)   (build-primref ae 1 name)]
-    [(_ ae level name)
-     `(|#primitive| ,name)]))
-
-
-;;; AZIZ
-(define-syntax build-foreign-call
-  (syntax-rules ()
-    [(_ ae name arg*) `(foreign-call ,name . ,arg*)]))
-(define-syntax build-$apply
-  (syntax-rules ()
-    [(_ ae proc arg*) `($apply ,proc . ,arg*)]))
-
-(define-syntax build-data
-  (syntax-rules ()
-    ((_ ae exp) `',exp)))
-
-(define build-sequence
-  (lambda (ae exps)
-    (let loop ((exps exps))
-      (if (null? (cdr exps))
-          (car exps)
-         ; weed out leading void calls, assuming ordinary list representation
-          (if (equal? (car exps) '(#%void))
-              (loop (cdr exps))
-              `(begin ,@exps))))))
-
-(define build-letrec
-  (lambda (ae vars val-exps body-exp)
-    (if (null? vars)
-        body-exp
-        `(letrec ,(map list vars val-exps) ,body-exp))))
-
-
-(define build-body
-  (lambda (ae vars val-exps body-exp)
-    (build-letrec ae vars val-exps body-exp)))
-
-(define build-top-module
- ; each type is either global (exported) or local (not exported)
- ; we produce global definitions and assignments for globals and
- ; letrec bindings for locals.  if you don't need the definitions,
- ; (just assignments) you can eliminate them.  if you wish to
- ; have your module definitions ordered from left-to-right (ala
- ; letrec*), you can replace the global var-exps with dummy vars
- ; and global val-exps with global assignments, and produce a letrec*
- ; in place of a letrec.
-  (lambda (ae types vars val-exps body-exp)
-    (let-values (((vars defns sets)
-                  (let f ((types types) (vars vars))
-                    (if (null? types)
-                        (values '() '() '())
-                        (let ((var (car vars)))
-                          (let-values (((vars defns sets) (f (cdr types) (cdr vars))))
-                            (if (eq? (car types) 'global)
-                                (let ((x (build-lexical-var no-source var)))
-                                  (values
-                                    (cons x vars)
-                                    (cons (build-global-definition no-source var (chi-void)) defns)
-                                    (cons (build-global-assignment no-source var (build-lexical-reference 'value no-source x)) sets)))
-                                (values (cons var vars) defns sets))))))))
-      (if (null? defns)
-          (build-letrec ae vars val-exps body-exp)
-          (build-sequence no-source
-            (append defns
-              (list
-                (build-letrec ae vars val-exps
-                  (build-sequence no-source (append sets (list body-exp)))))))))))
-
-(define-syntax build-lexical-var
-  (syntax-rules ()
-    ((_ ae id) (gensym))))
-
-(define-syntax lexical-var? gensym?)
-
-(define-syntax self-evaluating?
-  (syntax-rules ()
-    ((_ e)
-     (let ((x e))
-       (or (boolean? x) (fixnum? x) (string? x) (char? x) (null? x))))))
-)
-
-(define-syntax unannotate
-  (syntax-rules ()
-    ((_ x)
-     (let ((e x))
-       (if (annotation? e)
-           (annotation-expression e)
-           e)))))
-
-(define-syntax no-source (identifier-syntax #f))
-
-(define-syntax arg-check
-  (syntax-rules ()
-    ((_ pred? e who)
-     (let ((x e))
-       (if (not (pred? x)) (error-hook who "invalid argument" x))))))
-
-;;; compile-time environments
-
-;;; wrap and environment comprise two level mapping.
-;;;   wrap : id --> label
-;;;   env : label --> <element>
-
-;;; environments are represented in two parts: a lexical part and a global
-;;; part.  The lexical part is a simple list of associations from labels
-;;; to bindings.  The global part is implemented by
-;;; {put,get}-global-definition-hook and associates symbols with
-;;; bindings.
-
-;;; global (assumed global variable) and displaced-lexical (see below)
-;;; do not show up in any environment; instead, they are fabricated by
-;;; lookup when it finds no other bindings.
-
-;;; <environment>              ::= ((<label> . <binding>)*)
-
-;;; identifier bindings include a type and a value
-
-;;; <binding> ::= <procedure>                     macro keyword
-;;;               (macro . <procedure>)           macro keyword
-;;;               (deferred . <thunk>)            macro keyword w/lazily evaluated transformer
-;;;               (macro! . <procedure>)          extended identifier macro keyword
-;;;               (core . <procedure>)            core keyword
-;;;               (begin)                         begin keyword
-;;;               (define)                        define keyword
-;;;               (define-syntax)                 define-syntax keyword
-;;;               (local-syntax . <boolean>)      let-syntax (#f)/letrec-syntax (#t) keyword
-;;;               (eval-when)                     eval-when keyword
-;;;               (set!)                          set! keyword
-;;;               (meta)                          meta keyword
-;;;               ($module-key)                   $module keyword
-;;;               ($import)                       $import keyword
-;;;               ($module . <interface>)         modules
-;;;               (syntax . (<var> . <level>))    pattern variables
-;;;               (global . <symbol>)             assumed global variable
-;;;               (meta-variable . <symbol>)      meta variable
-;;;               (lexical . <var>)               lexical variables
-;;;               (displaced-lexical . #f)        id-var-name not found in store
-;;; <level>   ::= <nonnegative integer>
-;;; <var>     ::= variable returned by build-lexical-var
-
-;;; a macro is a user-defined syntactic-form.  a core is a system-defined
-;;; syntactic form.  begin, define, define-syntax, let-syntax, letrec-syntax,
-;;; eval-when, and meta are treated specially since they are sensitive to
-;;; whether the form is at top-level and can denote valid internal
-;;; definitions.
-
-;;; a pattern variable is a variable introduced by syntax-case and can
-;;; be referenced only within a syntax form.
-
-;;; any identifier for which no top-level syntax definition or local
-;;; binding of any kind has been seen is assumed to be a global
-;;; variable.
-
-;;; a lexical variable is a lambda- or letrec-bound variable.
-
-;;; a displaced-lexical identifier is a lexical identifier removed from
-;;; it's scope by the return of a syntax object containing the identifier.
-;;; a displaced lexical can also appear when a letrec-syntax-bound
-;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
-;;; a displaced lexical should never occur with properly written macros.
-
-(define sanitize-binding
-  (lambda (b)
-    (cond
-      ((procedure? b) (make-binding 'macro b))
-      ((binding? b)
-       (and (case (binding-type b)
-              ((core macro macro! deferred)
-               (and (procedure? (binding-value b))))
-              (($module) (interface? (binding-value b)))
-              ((lexical) (lexical-var? (binding-value b)))
-              ((global meta-variable) (symbol? (binding-value b)))
-              ((syntax) (let ((x (binding-value b)))
-                          (and (pair? x)
-                               (lexical-var? (car x))
-                               (let ((n (cdr x)))
-                                 (and (fixnum? n) (fx>= n 0))))))
-              ((begin define define-syntax set! $module-key $import eval-when meta) (null? (binding-value b)))
-              ((local-syntax) (boolean? (binding-value b)))
-              ((displaced-lexical) (eq? (binding-value b) #f))
-              (else #t))
-            b))
-      (else #f))))
-
-(define-syntax make-binding
-  (syntax-rules (quote)
-    ((_ 'type #f) '(type . #f))
-    ((_ type value) (cons type value))))
-
-(define binding-type car)
-(define binding-value cdr)
-(define set-binding-type! set-car!)
-(define set-binding-value! set-cdr!)
-(define binding? (lambda (x) (and (pair? x) (symbol? (car x)))))
-
-(define-syntax null-env (identifier-syntax '()))
-
-(define extend-env
-  (lambda (label binding r)
-    (cons (cons label binding) r)))
-
-(define extend-env*
-  (lambda (labels bindings r)
-    (if (null? labels)
-        r
-        (extend-env* (cdr labels) (cdr bindings)
-          (extend-env (car labels) (car bindings) r)))))
-
-(define extend-var-env*
-  ; variant of extend-env* that forms "lexical" binding
-  (lambda (labels vars r)
-    (if (null? labels)
-        r
-        (extend-var-env* (cdr labels) (cdr vars)
-          (extend-env (car labels) (make-binding 'lexical (car vars)) r)))))
-
-(define (displaced-lexical? id r)
-  (let ((n (id-var-name id empty-wrap)))
-    (and n
-         (let ((b (lookup n r)))
-           (eq? (binding-type b) 'displaced-lexical)))))
-
-(define displaced-lexical-error
-  (lambda (id)
-    (syntax-error id
-      (if (id-var-name id empty-wrap)
-          "identifier out of context"
-          "identifier not visible"))))
-
-(define lookup*
-  ; x may be a label or a symbol
-  ; although symbols are usually global, we check the environment first
-  ; anyway because a temporary binding may have been established by
-  ; fluid-let-syntax
-  (lambda (x r)
-    (cond
-      ((assq x r) => cdr)
-      ((symbol? x)
-       (or (get-global-definition-hook x) (make-binding 'global x)))
-      (else (make-binding 'displaced-lexical #f)))))
-
-(define lookup
-  (lambda (x r)
-    (define whack-binding!
-      (lambda (b *b)
-        (set-binding-type! b (binding-type *b))
-        (set-binding-value! b (binding-value *b))))
-    (let ((b (lookup* x r)))
-      (when (eq? (binding-type b) 'deferred)
-        (whack-binding! b (make-transformer-binding ((binding-value b)))))
-      b)))
-
-(define make-transformer-binding
-  (lambda (b)
-    (or (sanitize-binding b)
-        (syntax-error b "invalid transformer"))))
-
-(define defer-or-eval-transformer
-  (lambda (eval x)
-    (if (built-lambda? x)
-        (make-binding 'deferred (lambda () (eval x)))
-        (make-transformer-binding (eval x)))))
-
-(define global-extend
-  (lambda (type sym val)
-    (put-cte-hook sym (make-binding type val))))
-
-
-;;; Conceptually, identifiers are always syntax objects.  Internally,
-;;; however, the wrap is sometimes maintained separately (a source of
-;;; efficiency and confusion), so that symbols are also considered
-;;; identifiers by id?.  Externally, they are always wrapped.
-
-(define nonsymbol-id?
-  (lambda (x)
-    (and (syntax-object? x)
-         (symbol? (unannotate (syntax-object-expression x))))))
-
-(define id?
-  (lambda (x)
-    (cond
-      ((symbol? x) #t)
-      ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
-      ((annotation? x) (symbol? (annotation-expression x)))
-      (else #f))))
-
-(define-syntax id-sym-name
-  (syntax-rules ()
-    ((_ e)
-     (let ((x e))
-       (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))
-
-(define id-marks
-  (lambda (id)
-    (if (syntax-object? id)
-        (wrap-marks (syntax-object-wrap id))
-        (wrap-marks top-wrap))))
-
-(define id-subst
-  (lambda (id)
-    (if (syntax-object? id)
-        (wrap-subst (syntax-object-wrap id))
-        (wrap-marks top-wrap))))
-
-(define id-sym-name&marks
-  (lambda (x w)
-    (if (syntax-object? x)
-        (values
-          (unannotate (syntax-object-expression x))
-          (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
-        (values (unannotate x) (wrap-marks w)))))
-
-;;; syntax object wraps
-
-;;;         <wrap>     ::= ((<mark> ...) . (<subst> ...))
-;;;        <subst>     ::= <ribcage> | <shift>
-;;;      <ribcage>     ::= #((<ex-symname> ...) (<mark> ...) (<label> ...)) ; extensible, for chi-internal/external
-;;;                      | #(#(<symname> ...) #(<mark> ...) #(<label> ...)) ; nonextensible
-;;;   <ex-symname>     ::= <symname> | <import token> | <barrier>
-;;;        <shift>     ::= shift
-;;;      <barrier>     ::= #f                                               ; inserted by import-only
-;;; <import interface> ::= #<import-interface interface new-marks>
-;;;        <token>     ::= <generated id>
-
-(define make-wrap cons)
-(define wrap-marks car)
-(define wrap-subst cdr)
-
-
-(define-syntax empty-wrap (identifier-syntax '(())))
-
-(define-syntax top-wrap (identifier-syntax '((top))))
-
-(define-syntax top-marked?
-  (syntax-rules ()
-    ((_ w) (memq 'top (wrap-marks w)))))
-
-(define-syntax only-top-marked?
-  (syntax-rules ()
-    ((_ id) (same-marks? (wrap-marks (syntax-object-wrap id)) (wrap-marks top-wrap)))))
-
-;;; labels
-
-;;; simple labels must be comparable with "eq?" and distinct from symbols
-;;; and pairs.
-
-;;; indirect labels, which are implemented as pairs, are used to support
-;;; import aliasing for identifiers exported (explictly or implicitly) from
-;;; top-level modules.  chi-external creates an indirect label for each
-;;; defined identifier, import causes the pair to be shared with aliases it
-;;; establishes, and chi-top-module whacks the pair to hold the top-level
-;;; identifier name (symbol) if the id is to be placed at top level, before
-;;; expanding the right-hand sides of the definitions in the module.
-
-(module (gen-indirect-label indirect-label? get-indirect-label set-indirect-label!)
-  (define-structure (indirect-label label))
-  (define gen-indirect-label
-    (lambda ()
-      (make-indirect-label (gen-label))))
-  (define get-indirect-label (lambda (x) (indirect-label-label x)))
-  (define set-indirect-label! (lambda (x v) (set-indirect-label-label! x v))))
-
-(define gen-label
-  (lambda () (string #\i)))
-(define label?
-  (lambda (x)
-    (or (string? x) ; normal lexical labels
-        (symbol? x) ; global labels (symbolic names)
-        (indirect-label? x))))
-
-(define gen-labels
-  (lambda (ls)
-    (if (null? ls)
-        '()
-        (cons (gen-label) (gen-labels (cdr ls))))))
-
-(define-structure (ribcage symnames marks labels))
-(define-structure (top-ribcage key mutable?))
-(define-structure (import-interface interface new-marks))
-(define-structure (env top-ribcage wrap))
-
-;;; Marks must be comparable with "eq?" and distinct from pairs and
-;;; the symbol top.  We do not use integers so that marks will remain
-;;; unique even across file compiles.
-
-(define-syntax the-anti-mark (identifier-syntax #f))
-
-(define anti-mark
-  (lambda (w)
-    (make-wrap (cons the-anti-mark (wrap-marks w))
-               (cons 'shift (wrap-subst w)))))
-
-(define-syntax new-mark
-  (syntax-rules ()
-    ((_) (string #\m))))
-
-(define barrier-marker #f)
-
-;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
-;;; internal definitions, in which the ribcages are built incrementally
-(define-syntax make-empty-ribcage
-  (syntax-rules ()
-    ((_) (make-ribcage '() '() '()))))
-
-(define extend-ribcage!
- ; must receive ids with complete wraps
- ; ribcage guaranteed to be list-based
-  (lambda (ribcage id label)
-    (set-ribcage-symnames! ribcage
-      (cons (unannotate (syntax-object-expression id))
-            (ribcage-symnames ribcage)))
-    (set-ribcage-marks! ribcage
-      (cons (wrap-marks (syntax-object-wrap id))
-            (ribcage-marks ribcage)))
-    (set-ribcage-labels! ribcage
-      (cons label (ribcage-labels ribcage)))))
-
-(define import-extend-ribcage!
- ; must receive ids with complete wraps
- ; ribcage guaranteed to be list-based
-  (lambda (ribcage new-marks id label)
-    (set-ribcage-symnames! ribcage
-      (cons (unannotate (syntax-object-expression id))
-            (ribcage-symnames ribcage)))
-    (set-ribcage-marks! ribcage
-      (cons (join-marks new-marks (wrap-marks (syntax-object-wrap id)))
-            (ribcage-marks ribcage)))
-    (set-ribcage-labels! ribcage
-      (cons label (ribcage-labels ribcage)))))
-
-(define extend-ribcage-barrier!
- ; must receive ids with complete wraps
- ; ribcage guaranteed to be list-based
-  (lambda (ribcage killer-id)
-    (extend-ribcage-barrier-help! ribcage (syntax-object-wrap killer-id))))
-
-(define extend-ribcage-barrier-help!
-  (lambda (ribcage wrap)
-    (set-ribcage-symnames! ribcage
-      (cons barrier-marker (ribcage-symnames ribcage)))
-    (set-ribcage-marks! ribcage
-      (cons (wrap-marks wrap) (ribcage-marks ribcage)))))
-
-(define extend-ribcage-subst!
- ; ribcage guaranteed to be list-based
-  (lambda (ribcage import-iface)
-    (set-ribcage-symnames! ribcage
-      (cons import-iface (ribcage-symnames ribcage)))))
-
-(define lookup-import-binding-name
-  (lambda (sym marks token new-marks)
-    (let ((new (get-import-binding sym token)))
-      (and new
-           (let f ((new new))
-             (cond
-               ((pair? new) (or (f (car new)) (f (cdr new))))
-               ((symbol? new)
-                (and (same-marks? marks (join-marks new-marks (wrap-marks top-wrap))) new))
-               ((same-marks? marks (join-marks new-marks (wrap-marks (syntax-object-wrap new)))) new)
-               (else #f)))))))
-  
-(define store-import-binding
-  (lambda (id token new-marks)
-    (define cons-id
-      (lambda (id x)
-        (if (not x) id (cons id x))))
-    (define weed ; remove existing binding for id, if any
-      (lambda (marks x)
-        (if (pair? x)
-            (if (same-marks? (id-marks (car x)) marks)
-                (weed marks (cdr x))
-                (cons-id (car x) (weed marks (cdr x))))
-            (and x (not (same-marks? (id-marks x) marks)) x))))
-    (let ((id (if (null? new-marks)
-                  id
-                  (make-syntax-object (id-sym-name id)
-                    (make-wrap
-                      (join-marks new-marks (id-marks id))
-                      (id-subst id))))))
-      (let ((sym (id-sym-name id)))
-       ; no need to record bindings mapping symbol to self, since this   
-       ; assumed by default.
-        (unless (eq? id sym)
-          (let ((marks (id-marks id)))
-            (let ((x (weed marks (get-import-binding sym token))))
-              (put-import-binding sym token
-                (cons-id
-                  (if (same-marks? marks (wrap-marks top-wrap))
-                     ; need full id only if more than top-marked.
-                      (resolved-id-var-name id)
-                      id)
-                  x)))))))))
-
-;;; make-binding-wrap creates vector-based ribcages
-(define make-binding-wrap
-  (lambda (ids labels w)
-    (if (null? ids)
-        w
-        (make-wrap
-          (wrap-marks w)
-          (cons
-            (let ((labelvec (list->vector labels)))
-              (let ((n (vector-length labelvec)))
-                (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
-                  (let f ((ids ids) (i 0))
-                    (unless (null? ids)
-                      (let-values (((symname marks) (id-sym-name&marks (car ids) w)))
-                        (vector-set! symnamevec i symname)
-                        (vector-set! marksvec i marks)
-                        (f (cdr ids) (fx+ i 1)))))
-                  (make-ribcage symnamevec marksvec labelvec))))
-            (wrap-subst w))))))
-
-;;; resolved ids contain no unnecessary substitutions or marks.  they are
-;;; used essentially as indirects or aliases in modules interfaces.
-(define make-resolved-id
-  (lambda (fromsym marks tosym)
-    (make-syntax-object fromsym
-      (make-wrap marks
-        (list (make-ribcage (vector fromsym) (vector marks) (vector tosym)))))))
-
-(define id->resolved-id
-  (lambda (id)
-    (let-values (((tosym marks) (id-var-name&marks id empty-wrap)))
-      (unless tosym
-        (syntax-error id "identifier not visible for export"))
-      (make-resolved-id (id-sym-name id) marks tosym))))
-
-(define resolved-id-var-name
-  (lambda (id)
-    (vector-ref
-      (ribcage-labels (car (wrap-subst (syntax-object-wrap id))))
-      0)))
-
-;;; Scheme's append should not copy the first argument if the second is
-;;; nil, but it does, so we define a smart version here.
-(define smart-append
-  (lambda (m1 m2)
-    (if (null? m2)
-        m1
-        (append m1 m2))))
-
-(define join-wraps
-  (lambda (w1 w2)
-    (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
-      (if (null? m1)
-          (if (null? s1)
-              w2
-              (make-wrap
-                (wrap-marks w2)
-                (join-subst s1 (wrap-subst w2))))
-          (make-wrap
-            (join-marks m1 (wrap-marks w2))
-            (join-subst s1 (wrap-subst w2)))))))
-
-(define join-marks
-  (lambda (m1 m2)
-    (smart-append m1 m2)))
-
-(define join-subst
-  (lambda (s1 s2)
-    (smart-append s1 s2)))
-
-(define same-marks?
-  (lambda (x y)
-    (or (eq? x y)
-        (and (not (null? x))
-             (not (null? y))
-             (eq? (car x) (car y))
-             (same-marks? (cdr x) (cdr y))))))
-
-(define diff-marks
-  (lambda (m1 m2)
-    (let ((n1 (length m1)) (n2 (length m2)))
-      (let f ((n1 n1) (m1 m1))
-        (cond
-          ((fx> n1 n2) (cons (car m1) (f (fx- n1 1) (cdr m1))))
-          ((equal? m1 m2) '())
-          (else (error 'sc-expand
-                  "internal error in diff-marks: ~s is not a tail of ~s"
-                  m1 m2)))))))
-
-(module (top-id-bound-var-name top-id-free-var-name)
-  ;; top-id-bound-var-name is used to look up or establish new top-level
-  ;; substitutions, while top-id-free-var-name is used to look up existing
-  ;; (possibly implicit) substitutions.  Implicit substitutions exist
-  ;; for top-marked names in all environments, but we represent them
-  ;; explicitly only on demand.
-  ;;
-  ;; In both cases, we first look for an existing substitution for sym
-  ;; and the given marks.  If we find one, we return it.  Otherwise, we
-  ;; extend the appropriate top-level environment
-  ;;
-  ;; For top-id-bound-var-name, we extend the environment with a substition
-  ;; keyed by the given marks, so that top-level definitions introduced by
-  ;; a macro are distinct from other top-level definitions for the same
-  ;; name.  For example, if macros a and b both introduce definitions and
-  ;; bound references to identifier x, the two x's should be different,
-  ;; i.e., keyed by their own marks.
-  ;;
-  ;; For top-id-free-var-name, we extend the environment with a substition
-  ;; keyed by the top marks, since top-level free identifier references
-  ;; should refer to the existing implicit (top-marked) substitution.  For
-  ;; example, if macros a and b both introduce free references to identifier
-  ;; x, they should both refer to the same (global, unmarked) x.
-  ;;
- ;; If the environment is *top*, we map a symbol to itself
-
- (define leave-implicit? (lambda (token) (eq? token '*top*)))
-
-  (define new-binding
-    (lambda (sym marks token)
-      (let ((loc (if (and (leave-implicit? token)
-                          (same-marks? marks (wrap-marks top-wrap)))
-                     sym
-                     (generate-id sym))))
-        (let ((id (make-resolved-id sym marks loc)))
-          (store-import-binding id token '())
-          (values loc id)))))
-
-  (define top-id-bound-var-name
-   ; should be called only when top-ribcage is mutable
-    (lambda (sym marks top-ribcage)
-      (let ((token (top-ribcage-key top-ribcage)))
-        (cond
-          ((lookup-import-binding-name sym marks token '()) =>
-           (lambda (id)
-             (if (symbol? id) ; symbol iff marks == (wrap-marks top-wrap)
-                 (if (read-only-binding? id)
-                     (new-binding sym marks token)
-                     (values id (make-resolved-id sym marks id)))
-                 (values (resolved-id-var-name id) id))))
-          (else (new-binding sym marks token))))))
-
-  (define top-id-free-var-name
-    (lambda (sym marks top-ribcage)
-      (let ((token (top-ribcage-key top-ribcage)))
-        (cond
-          ((lookup-import-binding-name sym marks token '()) =>
-           (lambda (id) (if (symbol? id) id (resolved-id-var-name id))))
-          ((and (top-ribcage-mutable? top-ribcage)
-                (same-marks? marks (wrap-marks top-wrap)))
-           (let-values (((sym id) (new-binding sym (wrap-marks top-wrap) token)))
-             sym))
-          (else #f))))))
-
-(define id-var-name-loc&marks
-  (lambda (id w)
-    (define search
-      (lambda (sym subst marks)
-        (if (null? subst)
-            (values #f marks)
-            (let ((fst (car subst)))
-               (cond
-                 ((eq? fst 'shift) (search sym (cdr subst) (cdr marks)))
-                 ((ribcage? fst)
-                  (let ((symnames (ribcage-symnames fst)))
-                    (if (vector? symnames)
-                        (search-vector-rib sym subst marks symnames fst)
-                        (search-list-rib sym subst marks symnames fst))))
-                 ((top-ribcage? fst)
-                  (cond
-                    ((top-id-free-var-name sym marks fst) =>
-                     (lambda (var-name) (values var-name marks)))
-                    (else (search sym (cdr subst) marks))))
-                 (else
-                  (error 'sc-expand
-                    "internal error in id-var-name-loc&marks: improper subst ~s"
-                    subst)))))))
-    (define search-list-rib
-      (lambda (sym subst marks symnames ribcage)
-        (let f ((symnames symnames) (i 0))
-          (if (null? symnames)
-              (search sym (cdr subst) marks)
-              (let ((x (car symnames)))
-                (cond
-                  ((and (eq? x sym)
-                        (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
-                   (values (list-ref (ribcage-labels ribcage) i) marks))
-                  ((import-interface? x)
-                   (let ((iface (import-interface-interface x))
-                         (new-marks (import-interface-new-marks x)))
-                     (cond
-                       ((interface-token iface) =>
-                        (lambda (token)
-                          (cond
-                            ((lookup-import-binding-name sym marks token new-marks) =>
-                             (lambda (id)
-                               (values
-                                 (if (symbol? id) id (resolved-id-var-name id))
-                                 marks)))
-                            (else (f (cdr symnames) i)))))
-                       (else
-                        (let* ((ie (interface-exports iface))
-                               (n (vector-length ie)))
-                          (let g ((j 0))
-                            (if (fx= j n)
-                                (f (cdr symnames) i)
-                                (let ((id (vector-ref ie j)))
-                                  (let ((id.sym (id-sym-name id))
-                                        (id.marks (join-marks new-marks (id-marks id))))
-                                    (if (help-bound-id=? id.sym id.marks sym marks)
-                                        (values (lookup-import-label id) marks)
-                                        (g (fx+ j 1))))))))))))
-                  ((and (eq? x barrier-marker)
-                        (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
-                   (values #f marks))
-                  (else (f (cdr symnames) (fx+ i 1)))))))))
-    (define search-vector-rib
-      (lambda (sym subst marks symnames ribcage)
-        (let ((n (vector-length symnames)))
-          (let f ((i 0))
-            (cond
-              ((fx= i n) (search sym (cdr subst) marks))
-              ((and (eq? (vector-ref symnames i) sym)
-                    (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
-               (values (vector-ref (ribcage-labels ribcage) i) marks))
-              (else (f (fx+ i 1))))))))
-    (cond
-      ((symbol? id) (search id (wrap-subst w) (wrap-marks w)))
-      ((syntax-object? id)
-       (let ((sym (unannotate (syntax-object-expression id)))
-             (w1 (syntax-object-wrap id)))
-         (let-values (((name marks) (search sym (wrap-subst w)
-                                      (join-marks
-                                        (wrap-marks w)
-                                        (wrap-marks w1)))))
-           (if name
-               (values name marks)
-               (search sym (wrap-subst w1) marks)))))
-      ((annotation? id) (search (unannotate id) (wrap-subst w) (wrap-marks w)))
-      (else (error-hook 'id-var-name "invalid id" id)))))
-
-(define id-var-name&marks
- ; this version follows indirect labels
-  (lambda (id w)
-    (let-values (((label marks) (id-var-name-loc&marks id w)))
-      (values (if (indirect-label? label) (get-indirect-label label) label) marks))))
-
-(define id-var-name-loc
- ; this version doesn't follow indirect labels
-  (lambda (id w)
-    (let-values (((label marks) (id-var-name-loc&marks id w)))
-      label)))
-
-(define id-var-name
- ; this version follows indirect labels
-  (lambda (id w)
-    (let-values (((label marks) (id-var-name-loc&marks id w)))
-      (if (indirect-label? label) (get-indirect-label label) label))))
-
-;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
-;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
-
-(define free-id=?
-  (lambda (i j)
-    (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
-         (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
-
-(define literal-id=?
-  (lambda (id literal)
-    (and (eq? (id-sym-name id) (id-sym-name literal))
-         (let ((n-id (id-var-name id empty-wrap))
-               (n-literal (id-var-name literal empty-wrap)))
-           (or (eq? n-id n-literal)
-               (and (or (not n-id) (symbol? n-id))
-                    (or (not n-literal) (symbol? n-literal))))))))
-
-;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
-;;; long as the missing portion of the wrap is common to both of the ids
-;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
-
-(define help-bound-id=?
-  (lambda (i.sym i.marks j.sym j.marks)
-    (and (eq? i.sym j.sym)
-         (same-marks? i.marks j.marks))))
-   
-(define bound-id=?
-  (lambda (i j)
-    (help-bound-id=? (id-sym-name i) (id-marks i) (id-sym-name j) (id-marks j))))
-
-;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
-;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
-;;; as long as the missing portion of the wrap is common to all of the
-;;; ids.
-
-(define valid-bound-ids?
-  (lambda (ids)
-     (and (let all-ids? ((ids ids))
-            (or (null? ids)
-                (and (id? (car ids))
-                     (all-ids? (cdr ids)))))
-          (distinct-bound-ids? ids))))
-
-;;; distinct-bound-ids? expects a list of ids and returns #t if there are
-;;; no duplicates.  It is quadratic on the length of the id list; long
-;;; lists could be sorted to make it more efficient.  distinct-bound-ids?
-;;; may be passed unwrapped (or partially wrapped) ids as long as the
-;;; missing portion of the wrap is common to all of the ids.
-
-(define distinct-bound-ids?
-  (lambda (ids)
-    (let distinct? ((ids ids))
-      (or (null? ids)
-          (and (not (bound-id-member? (car ids) (cdr ids)))
-               (distinct? (cdr ids)))))))
-
-(define invalid-ids-error
- ; find first bad one and complain about it
-  (lambda (ids exp class)
-    (let find ((ids ids) (gooduns '()))
-      (if (null? ids)
-          (syntax-error exp) ; shouldn't happen
-          (if (id? (car ids))
-              (if (bound-id-member? (car ids) gooduns)
-                  (syntax-error (car ids) "duplicate " class)
-                  (find (cdr ids) (cons (car ids) gooduns)))
-              (syntax-error (car ids) "invalid " class))))))
-
-(define bound-id-member?
-   (lambda (x list)
-      (and (not (null? list))
-           (or (bound-id=? x (car list))
-               (bound-id-member? x (cdr list))))))
-
-;;; wrapping expressions and identifiers
-
-(define wrap
-  (lambda (x w)
-    (cond
-      ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
-      ((syntax-object? x)
-       (make-syntax-object
-         (syntax-object-expression x)
-         (join-wraps w (syntax-object-wrap x))))
-      ((null? x) x)
-      (else (make-syntax-object x w)))))
-
-(define source-wrap
-  (lambda (x w ae)
-    (wrap (if (annotation? ae)
-              (begin
-                (unless (eq? (annotation-expression ae) x)
-                  (error 'sc-expand "internal error in source-wrap: ae/x mismatch"))
-                ae)
-              x)
-          w)))
-
-;;; expanding
-
-(define chi-when-list
-  (lambda (when-list w)
-    ; when-list is syntax'd version of list of situations
-    (map (lambda (x)
-           (cond
-             ((literal-id=? x (syntax compile)) 'compile)
-             ((literal-id=? x (syntax load)) 'load)
-             ((literal-id=? x (syntax visit)) 'visit)
-             ((literal-id=? x (syntax revisit)) 'revisit)
-             ((literal-id=? x (syntax eval)) 'eval)
-             (else (syntax-error (wrap x w) "invalid eval-when situation"))))
-         when-list)))
-
-;;; syntax-type returns five values: type, value, e, w, and ae.  The first
-;;; two are described in the table below.
-;;;
-;;;    type                   value         explanation
-;;;    -------------------------------------------------------------------
-;;;    alias                  none          alias keyword
-;;;    alias-form             none          alias expression
-;;;    begin                  none          begin keyword
-;;;    begin-form             none          begin expression
-;;;    call                   none          any other call
-;;;    constant               none          self-evaluating datum
-;;;    core                   procedure     core form (including singleton)
-;;;    define                 none          define keyword
-;;;    define-form            none          variable definition
-;;;    define-syntax          none          define-syntax keyword
-;;;    define-syntax-form     none          syntax definition
-;;;    displaced-lexical      none          displaced lexical identifier
-;;;    eval-when              none          eval-when keyword
-;;;    eval-when-form         none          eval-when form
-;;;    global                 name          global variable reference
-;;;    $import                none          $import keyword
-;;;    $import-form           none          $import form
-;;;    lexical                name          lexical variable reference
-;;;    lexical-call           name          call to lexical variable
-;;;    local-syntax           rec?          letrec-syntax/let-syntax keyword
-;;;    local-syntax-form      rec?          syntax definition
-;;;    meta                   none          meta keyword
-;;;    meta-form              none          meta form
-;;;    meta-variable          name          meta variable
-;;;    $module                none          $module keyword
-;;;    $module-form           none          $module definition
-;;;    syntax                 level         pattern variable
-;;;    other                  none          anything else
-;;;
-;;; For all forms, e is the form, w is the wrap for e. and ae is the
-;;; (possibly) source-annotated form.
-;;;
-;;; syntax-type expands macros and unwraps as necessary to get to
-;;; one of the forms above.
-
-(define syntax-type
-  (lambda (e r w ae rib)
-    (cond
-      ((symbol? e)
-       (let* ((n (id-var-name e w))
-              (b (lookup n r))
-              (type (binding-type b)))
-         (case type
-           ((macro macro!) (syntax-type (chi-macro (binding-value b) e r w ae rib) r empty-wrap #f rib))
-           (else (values type (binding-value b) e w ae)))))
-      ((pair? e)
-       (let ((first (car e)))
-         (if (id? first)
-             (let* ((n (id-var-name first w))
-                    (b (lookup n r))
-                    (type (binding-type b)))
-               (case type
-                 ((lexical) (values 'lexical-call (binding-value b) e w ae))
-                 ((macro macro!)
-                  (syntax-type (chi-macro (binding-value b) e r w ae rib)
-                    r empty-wrap #f rib))
-                 ((core) (values type (binding-value b) e w ae))
-                 ((begin) (values 'begin-form #f e w ae))
-                 ((alias) (values 'alias-form #f e w ae))
-                 ((define) (values 'define-form #f e w ae))
-                 ((define-syntax) (values 'define-syntax-form #f e w ae))
-                 ((set!) (chi-set! e r w ae rib))
-                 (($module-key) (values '$module-form #f e w ae))
-                 (($import) (values '$import-form #f e w ae))
-                 ((eval-when) (values 'eval-when-form #f e w ae))
-                 ((meta) (values 'meta-form #f e w ae))
-                 ((local-syntax)
-                  (values 'local-syntax-form (binding-value b) e w ae))
-                 (else (values 'call #f e w ae))))
-             (values 'call #f e w ae))))
-      ((syntax-object? e)
-       (syntax-type (syntax-object-expression e)
-                    r
-                    (join-wraps w (syntax-object-wrap e))
-                    #f rib))
-      ((annotation? e)
-       (syntax-type (annotation-expression e) r w e rib))
-      ((self-evaluating? e) (values 'constant #f e w ae))
-      (else (values 'other #f e w ae)))))
-
-(define chi-top*
-  (lambda (e r w ctem rtem meta? top-ribcage)
-    (let ((meta-residuals '()))
-      (define meta-residualize!
-        (lambda (x)
-          (set! meta-residuals
-            (cons x meta-residuals))))
-      (let ((e (chi-top e r w ctem rtem meta? top-ribcage meta-residualize! #f)))
-        (build-sequence no-source
-          (reverse (cons e meta-residuals)))))))
-
-(define chi-top-sequence
-  (lambda (body r w ae ctem rtem meta? ribcage meta-residualize!)
-    (build-sequence ae
-      (let dobody ((body body))
-        (if (null? body)
-            '()
-            (let ((first (chi-top (car body) r w ctem rtem meta? ribcage meta-residualize! #f)))
-              (cons first (dobody (cdr body)))))))))
-
-(define chi-top
-  (lambda (e r w ctem rtem meta? top-ribcage meta-residualize! meta-seen?)
-    (let-values (((type value e w ae) (syntax-type e r w no-source top-ribcage)))
-      (case type
-        ((begin-form)
-         (let ((forms (parse-begin e w ae #t)))
-           (if (null? forms)
-               (chi-void)
-               (chi-top-sequence forms r w ae ctem rtem meta? top-ribcage meta-residualize!))))
-        ((local-syntax-form)
-         (let-values (((forms r mr w ae) (chi-local-syntax value e r r w ae)))
-          ; mr should be same as r here
-           (chi-top-sequence forms r w ae ctem rtem meta? top-ribcage meta-residualize!)))
-        ((eval-when-form)
-         (let-values (((when-list forms) (parse-eval-when e w ae)))
-           (let ((ctem (update-mode-set when-list ctem))
-                 (rtem (update-mode-set when-list rtem)))
-             (if (and (null? ctem) (null? rtem))
-                 (chi-void)
-                 (chi-top-sequence forms r w ae ctem rtem meta? top-ribcage meta-residualize!)))))
-        ((meta-form) (chi-top (parse-meta e w ae) r w ctem rtem #t top-ribcage meta-residualize! #t))
-        ((define-syntax-form)
-         (let-values (((id rhs w) (parse-define-syntax e w ae)))
-           (let ((id (wrap id w)))
-             (when (displaced-lexical? id r) (displaced-lexical-error id))
-             (unless (top-ribcage-mutable? top-ribcage)
-               (syntax-error (source-wrap e w ae)
-                 "invalid definition in read-only environment"))
-             (let ((sym (id-sym-name id)))
-               (let-values (((valsym bound-id) (top-id-bound-var-name sym (wrap-marks (syntax-object-wrap id)) top-ribcage)))
-                 (unless (eq? (id-var-name id empty-wrap) valsym)
-                   (syntax-error (source-wrap e w ae)
-                     "definition not permitted"))
-                 (when (read-only-binding? valsym)
-                   (syntax-error (source-wrap e w ae)
-                     "invalid definition of read-only identifier"))
-                 (ct-eval/residualize2 ctem
-                   (lambda ()
-                     (build-cte-install
-                       bound-id
-                       (chi rhs r r w #t)
-                       (top-ribcage-key top-ribcage)))))))))
-        ((define-form)
-         (let-values (((id rhs w) (parse-define e w ae)))
-           (let ((id (wrap id w)))
-             (when (displaced-lexical? id r) (displaced-lexical-error id))
-             (unless (top-ribcage-mutable? top-ribcage)
-               (syntax-error (source-wrap e w ae)
-                 "invalid definition in read-only environment"))
-             (let ((sym (id-sym-name id)))
-               (let-values (((valsym bound-id) (top-id-bound-var-name sym (wrap-marks (syntax-object-wrap id)) top-ribcage)))
-                 (unless (eq? (id-var-name id empty-wrap) valsym)
-                   (syntax-error (source-wrap e w ae)
-                     "definition not permitted"))
-                 (when (read-only-binding? valsym)
-                   (syntax-error (source-wrap e w ae)
-                     "invalid definition of read-only identifier"))
-                 (if meta?
-                     (ct-eval/residualize2 ctem
-                       (lambda ()
-                         (build-sequence no-source
-                           (list
-                             (build-cte-install bound-id
-                               (build-data no-source (make-binding 'meta-variable valsym))
-                               (top-ribcage-key top-ribcage))
-                             (build-global-definition ae valsym (chi rhs r r w #t))))))
-                    ; make sure compile-time definitions occur before we
-                    ; expand the run-time code
-                     (let ((x (ct-eval/residualize2 ctem
-                                (lambda ()
-                                  (build-cte-install
-                                    bound-id
-                                    (build-data no-source (make-binding 'global valsym))
-                                    (top-ribcage-key top-ribcage))))))
-                       (build-sequence no-source
-                         (list
-                           x
-                           (rt-eval/residualize rtem
-                             (lambda ()
-                               (build-global-definition ae valsym (chi rhs r r w #f)))))))))
-             ))))
-        (($module-form)
-         (let ((ribcage (make-empty-ribcage)))
-           (let-values (((orig id exports forms)
-                         (parse-module e w ae
-                           (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))))
-             (when (displaced-lexical? id r) (displaced-lexical-error (wrap id w)))
-             (unless (top-ribcage-mutable? top-ribcage)
-               (syntax-error orig
-                 "invalid definition in read-only environment"))
-             (chi-top-module orig r r top-ribcage ribcage ctem rtem meta? id exports forms meta-residualize!))))
-        (($import-form)
-         (let-values (((orig only? mid) (parse-import e w ae)))
-           (unless (top-ribcage-mutable? top-ribcage)
-             (syntax-error orig
-               "invalid definition in read-only environment"))
-           (ct-eval/residualize2 ctem
-             (lambda ()
-               (let ((binding (lookup (id-var-name mid empty-wrap) null-env)))
-                 (case (binding-type binding)
-                   (($module) (do-top-import only? top-ribcage mid (interface-token (binding-value binding))))
-                   ((displaced-lexical) (displaced-lexical-error mid))
-                   (else (syntax-error mid "unknown module"))))))))
-        ((alias-form)
-         (let-values (((new-id old-id) (parse-alias e w ae)))
-           (let ((new-id (wrap new-id w)))
-             (when (displaced-lexical? new-id r) (displaced-lexical-error new-id))
-             (unless (top-ribcage-mutable? top-ribcage)
-               (syntax-error (source-wrap e w ae)
-                 "invalid definition in read-only environment"))
-             (let ((sym (id-sym-name new-id)))
-               (let-values (((valsym bound-id) (top-id-bound-var-name sym (wrap-marks (syntax-object-wrap new-id)) top-ribcage)))
-                 (unless (eq? (id-var-name new-id empty-wrap) valsym)
-                   (syntax-error (source-wrap e w ae)
-                     "definition not permitted"))
-                 (when (read-only-binding? valsym)
-                   (syntax-error (source-wrap e w ae)
-                     "invalid definition of read-only identifier"))
-                 (ct-eval/residualize2 ctem
-                   (lambda ()
-                     (build-cte-install
-                       (make-resolved-id sym (wrap-marks (syntax-object-wrap new-id)) (id-var-name old-id w))
-                       (build-data no-source (make-binding 'do-alias #f))
-                       (top-ribcage-key top-ribcage)))))))))
-        (else
-         (when meta-seen? (syntax-error (source-wrap e w ae) "invalid meta definition"))
-         (if meta?
-             (let ((x (chi-expr type value e r r w ae #t)))
-               (top-level-eval-hook x)
-               (ct-eval/residualize3 ctem void (lambda () x)))
-             (rt-eval/residualize rtem
-               (lambda ()
-                 (chi-expr type value e r r w ae #f)))))))))
-
-(define flatten-exports
-  (lambda (exports)
-    (let loop ((exports exports) (ls '()))
-      (if (null? exports)
-          ls
-          (loop (cdr exports)
-                (if (pair? (car exports))
-                    (loop (car exports) ls)
-                    (cons (car exports) ls)))))))
-
-
-(define-structure (interface marks exports token))
-
-;; leaves interfaces unresolved so that indirect labels can be followed.
-;; (can't resolve until indirect labels have their final value)
-(define make-unresolved-interface
- ; trim out implicit exports
-  (lambda (mid exports)
-    (make-interface
-      (wrap-marks (syntax-object-wrap mid))
-      (list->vector (map (lambda (x) (if (pair? x) (car x) x)) exports))
-      #f)))
-
-(define make-resolved-interface
- ; trim out implicit exports & resolve others to actual top-level symbol
-  (lambda (mid exports token)
-    (make-interface
-      (wrap-marks (syntax-object-wrap mid))
-      (list->vector (map (lambda (x) (id->resolved-id (if (pair? x) (car x) x))) exports))
-      token)))
-
-(define-structure (module-binding type id label imps val exported))
-(define create-module-binding
-  (lambda (type id label imps val)
-    (make-module-binding type id label imps val #f)))
-
-;;; frobs represent body forms
-(define-structure (frob e meta?))
-
-(define chi-top-module
-  (lambda (orig r mr top-ribcage ribcage ctem rtem meta? id exports forms meta-residualize!)
-    (let ((fexports (flatten-exports exports)))
-      (let-values (((r mr bindings inits)
-                    (chi-external ribcage orig
-                      (map (lambda (d) (make-frob d meta?)) forms) r mr ctem exports fexports
-                      meta-residualize!)))
-       ; identify exported identifiers, create ctdefs
-        (let process-exports ((fexports fexports) (ctdefs (lambda () '())))
-          (if (null? fexports)
-             ; remaining bindings are either identified global vars,
-             ; local vars, or local compile-time entities
-             ; dts: type (local/global)
-             ; dvs & des: define lhs & rhs
-              (let process-locals ((bs bindings) (r r) (dts '()) (dvs '()) (des '()))
-                (if (null? bs)
-                    (let ((des (chi-frobs des r mr #f))
-                          (inits (chi-frobs inits r mr #f)))
-                      (build-sequence no-source
-                        (append
-                         ; we wait to establish global compile-time definitions so that
-                         ; expansion of des use local versions of modules and macros
-                         ; in case ctem tells us not to eval ctdefs now.  this means that
-                         ; local code can use exported compile-time values (modules, macros,
-                         ; meta variables) just as it can unexported ones.
-                          (ctdefs)
-                          (list
-                            (ct-eval/residualize2 ctem
-                              (lambda ()
-                                (let ((sym (id-sym-name id)))
-                                  (let* ((token (generate-id sym))
-                                         (b (build-data no-source
-                                              (make-binding '$module
-                                                (make-resolved-interface id exports token)))))
-                                    (let-values (((valsym bound-id)
-                                                  (top-id-bound-var-name sym
-                                                    (wrap-marks (syntax-object-wrap id))
-                                                    top-ribcage)))
-                                      (unless (eq? (id-var-name id empty-wrap) valsym)
-                                        (syntax-error orig
-                                          "definition not permitted"))
-                                      (when (read-only-binding? valsym)
-                                        (syntax-error orig
-                                          "invalid definition of read-only identifier"))
-                                      (build-cte-install bound-id b
-                                        (top-ribcage-key top-ribcage)))))))
-                            (rt-eval/residualize rtem
-                              (lambda ()
-                                (build-top-module no-source dts dvs des
-                                  (if (null? inits)
-                                      (chi-void)
-                                      (build-sequence no-source
-                                        (append inits (list (chi-void))))))))))))
-                    (let ((b (car bs)) (bs (cdr bs)))
-                      (let ((t (module-binding-type b)))
-                        (case (module-binding-type b)
-                          ((define-form)
-                           (let ((label (get-indirect-label (module-binding-label b))))
-                             (if (module-binding-exported b)
-                                 (let ((var (module-binding-id b)))
-                                   (process-locals bs r (cons 'global dts) (cons label dvs)
-                                     (cons (module-binding-val b) des)))
-                                 (let ((var (gen-var (module-binding-id b))))
-                                   (process-locals bs
-                                    ; add lexical bindings only to run-time environment
-                                     (extend-env label (make-binding 'lexical var) r)
-                                     (cons 'local dts) (cons var dvs)
-                                     (cons (module-binding-val b) des))))))
-                          ((ctdefine-form define-syntax-form $module-form alias-form) (process-locals bs r dts dvs des))
-                          (else (error 'sc-expand-internal "unexpected module binding type ~s" t)))))))
-              (let ((id (car fexports)) (fexports (cdr fexports)))
-                (let loop ((bs bindings))
-                  (if (null? bs)
-                     ; must be rexport from an imported module
-                      (process-exports fexports ctdefs)
-                      (let ((b (car bs)) (bs (cdr bs)))
-                       ; following formerly used bound-id=?, but free-id=? can prevent false positives
-                       ; and is okay since the substitutions have already been applied
-                        (if (free-id=? (module-binding-id b) id)
-                            (if (module-binding-exported b)
-                                (process-exports fexports ctdefs)
-                                (let* ((t (module-binding-type b))
-                                       (label (module-binding-label b))
-                                       (imps (module-binding-imps b))
-                                       (fexports (append imps fexports)))
-                                  (set-module-binding-exported! b #t)
-                                  (case t
-                                    ((define-form)
-                                     (let ((sym (generate-id (id-sym-name id))))
-                                       (set-indirect-label! label sym)
-                                       (process-exports fexports ctdefs)))
-                                    ((ctdefine-form)
-                                     (let ((b (module-binding-val b)))
-                                       (process-exports fexports
-                                         (lambda ()
-                                           (let ((sym (binding-value b)))
-                                             (set-indirect-label! label sym)
-                                             (cons (ct-eval/residualize3 ctem
-                                                     (lambda () (put-cte-hook sym b))
-                                                     (lambda () (build-cte-install sym (build-data no-source b) #f)))
-                                                   (ctdefs)))))))
-                                    ((define-syntax-form)
-                                     (let ((sym (generate-id (id-sym-name id))))
-                                       (process-exports fexports
-                                         (lambda () 
-                                           (let ((local-label (get-indirect-label label)))
-                                             (set-indirect-label! label sym)
-                                             (cons
-                                               (ct-eval/residualize3 ctem
-                                                 (lambda () (put-cte-hook sym (car (module-binding-val b))))
-                                                 (lambda () (build-cte-install sym (cdr (module-binding-val b)) #f)))
-                                               (ctdefs)))))))
-                                    (($module-form)
-                                     (let ((sym (generate-id (id-sym-name id)))
-                                           (exports (module-binding-val b)))
-                                       (process-exports (append (flatten-exports exports) fexports)
-                                         (lambda ()
-                                           (set-indirect-label! label sym)
-                                           (let ((rest (ctdefs))) ; set indirect labels before resolving
-                                             (let ((x (make-binding '$module (make-resolved-interface id exports sym))))
-                                               (cons (ct-eval/residualize3 ctem
-                                                       (lambda () (put-cte-hook sym x))
-                                                       (lambda () (build-cte-install sym (build-data no-source x) #f)))
-                                                     rest)))))))
-                                    ((alias-form)
-                                     (process-exports
-                                       fexports
-                                       (lambda ()
-                                         (let ((rest (ctdefs))) ; set indirect labels before resolving
-                                           (when (indirect-label? label)
-                                             (unless (symbol? (get-indirect-label label))
-                                               (syntax-error (module-binding-id b) "unexported target of alias")))
-                                           rest))))
-                                    (else (error 'sc-expand-internal "unexpected module binding type ~s" t)))))
-                            (loop bs))))))))))))
-
-(define id-set-diff
-  (lambda (exports defs)
-    (cond
-      ((null? exports) '())
-      ((bound-id-member? (car exports) defs) (id-set-diff (cdr exports) defs))
-      (else (cons (car exports) (id-set-diff (cdr exports) defs))))))
-
-(define check-module-exports
-  ; After processing the definitions of a module this is called to verify that the
-  ; module has defined or imported each exported identifier.  Because ids in fexports are
-  ; wrapped with the given ribcage, they will contain substitutions for anything defined
-  ; or imported here.  These subsitutions can be used by do-import! and do-import-top! to
-  ; provide access to reexported bindings, for example.
-  (lambda (source-exp fexports ids)
-    (define defined?
-      (lambda (e ids)
-        (ormap (lambda (x)
-                 (if (import-interface? x)
-                     (let ((x.iface (import-interface-interface x))
-                           (x.new-marks (import-interface-new-marks x)))
-                       (cond
-                         ((interface-token x.iface) =>
-                          (lambda (token)
-                            (lookup-import-binding-name (id-sym-name e) (id-marks e) token x.new-marks)))
-                         (else
-                          (let ((v (interface-exports x.iface)))
-                            (let lp ((i (fx- (vector-length v) 1)))
-                              (and (fx>= i 0)
-                                   (or (let ((id (vector-ref v i)))
-                                         (help-bound-id=?
-                                           (id-sym-name id)
-                                           (join-marks x.new-marks (id-marks id))
-                                           (id-sym-name e) (id-marks e)))
-                                       (lp (fx- i 1)))))))))
-                     (bound-id=? e x)))
-               ids)))
-    (let loop ((fexports fexports) (missing '()))
-      (if (null? fexports)
-          (unless (null? missing)
-            (syntax-error (car missing)
-              (if (fx= (length missing) 1)
-                  "missing definition for export"
-                  "missing definition for multiple exports, including")))
-          (let ((e (car fexports)) (fexports (cdr fexports)))
-            (if (defined? e ids)
-                (loop fexports missing)
-                (loop fexports (cons e missing))))))))
-
-(define check-defined-ids
-  (lambda (source-exp ls)
-    (define vfold
-      (lambda (v p cls)
-        (let ((len (vector-length v)))
-          (let lp ((i 0) (cls cls))
-            (if (fx= i len)
-                cls
-                (lp (fx+ i 1) (p (vector-ref v i) cls)))))))
-    (define conflicts
-      (lambda (x y cls)
-        (if (import-interface? x)
-            (let ((x.iface (import-interface-interface x))
-                  (x.new-marks (import-interface-new-marks x)))
-              (if (import-interface? y)
-                  (let ((y.iface (import-interface-interface y))
-                        (y.new-marks (import-interface-new-marks y)))
-                    (let ((xe (interface-exports x.iface)) (ye (interface-exports y.iface)))
-                      (if (fx> (vector-length xe) (vector-length ye))
-                          (vfold ye
-                            (lambda (id cls)
-                              (id-iface-conflicts id y.new-marks x.iface x.new-marks cls)) cls)
-                          (vfold xe
-                            (lambda (id cls)
-                              (id-iface-conflicts id x.new-marks y.iface y.new-marks cls)) cls))))
-                  (id-iface-conflicts y '() x.iface x.new-marks cls)))
-            (if (import-interface? y)
-                (let ((y.iface (import-interface-interface y))
-                      (y.new-marks (import-interface-new-marks y)))
-                  (id-iface-conflicts x '() y.iface y.new-marks cls))
-                (if (bound-id=? x y) (cons x cls) cls)))))
-     (define id-iface-conflicts
-       (lambda (id id.new-marks iface iface.new-marks cls)
-         (let ((id.sym (id-sym-name id))
-               (id.marks (join-marks id.new-marks (id-marks id))))
-           (cond
-             ((interface-token iface) =>
-              (lambda (token)
-                (if (lookup-import-binding-name id.sym id.marks token iface.new-marks)
-                    (cons id cls)
-                    cls)))
-             (else
-              (vfold (interface-exports iface)
-                     (lambda (*id cls)
-                       (let ((*id.sym (id-sym-name *id))
-                             (*id.marks (join-marks iface.new-marks (id-marks *id))))
-                         (if (help-bound-id=? *id.sym *id.marks id.sym id.marks)
-                             (cons *id cls)
-                             cls)))
-                     cls))))))
-     (unless (null? ls)
-       (let lp ((x (car ls)) (ls (cdr ls)) (cls '()))
-         (if (null? ls)
-             (unless (null? cls)
-               (let ((cls (syntax-object->datum cls)))
-                 (syntax-error source-exp "duplicate definition for "
-                  (symbol->string (car cls))
-                   " in")))
-             (let lp2 ((ls2 ls) (cls cls))
-               (if (null? ls2)
-                   (lp (car ls) (cdr ls) cls)
-                   (lp2 (cdr ls2) (conflicts x (car ls2) cls)))))))))
-
-(define chi-external
-  (lambda (ribcage source-exp body r mr ctem exports fexports meta-residualize!)
-    (define return
-      (lambda (r mr bindings ids inits)
-        (check-defined-ids source-exp ids)
-        (check-module-exports source-exp fexports ids)
-        (values r mr bindings inits)))
-    (define get-implicit-exports
-      (lambda (id)
-        (let f ((exports exports))
-          (if (null? exports)
-              '()
-              (if (and (pair? (car exports)) (bound-id=? id (caar exports)))
-                  (flatten-exports (cdar exports))
-                  (f (cdr exports)))))))
-    (define update-imp-exports
-      (lambda (bindings exports)
-        (let ((exports (map (lambda (x) (if (pair? x) (car x) x)) exports)))
-          (map (lambda (b)
-                 (let ((id (module-binding-id b)))
-                   (if (not (bound-id-member? id exports))
-                       b
-                       (create-module-binding
-                         (module-binding-type b)
-                         id
-                         (module-binding-label b)
-                         (append (get-implicit-exports id) (module-binding-imps b))
-                         (module-binding-val b)))))
-               bindings))))
-    (let parse ((body body) (r r) (mr mr) (ids '()) (bindings '()) (inits '()) (meta-seen? #f))
-      (if (null? body)
-          (return r mr bindings ids inits)
-          (let* ((fr (car body)) (e (frob-e fr)) (meta? (frob-meta? fr)))
-            (let-values (((type value e w ae) (syntax-type e r empty-wrap no-source ribcage)))
-              (case type
-                ((define-form)
-                 (let-values (((id rhs w) (parse-define e w ae)))
-                   (let* ((id (wrap id w))
-                          (label (gen-indirect-label))
-                          (sym (generate-id (id-sym-name id)))
-                          (imps (get-implicit-exports id)))
-                     (extend-ribcage! ribcage id label)
-                     (cond
-                       (meta?
-                        (let* ((sym (generate-id (id-sym-name id)))
-                               (b (make-binding 'meta-variable sym)))
-                         ; add meta bindings only to meta environment
-                          (let ((mr (extend-env (get-indirect-label label) b mr)))
-                            (let ((exp (chi rhs mr mr w #t)))
-                              (define-top-level-value-hook sym (top-level-eval-hook exp))
-                              (meta-residualize!
-                                (ct-eval/residualize3 ctem
-                                  void
-                                  (lambda () (build-global-definition no-source sym exp))))
-                              (parse (cdr body) r mr
-                                (cons id ids)
-                                (cons (create-module-binding 'ctdefine-form id label imps b) bindings)
-                                inits
-                                #f)))))
-                       (else
-                        (parse (cdr body) r mr
-                          (cons id ids)
-                          (cons (create-module-binding type id label
-                                  imps (make-frob (wrap rhs w) meta?))
-                                bindings)
-                          inits
-                          #f))))))
-                ((define-syntax-form)
-                 (let-values (((id rhs w) (parse-define-syntax e w ae)))
-                   (let* ((id (wrap id w))
-                          (label (gen-indirect-label))
-                          (imps (get-implicit-exports id))
-                          (exp (chi rhs mr mr w #t)))
-                     (extend-ribcage! ribcage id label)
-                     (let ((l (get-indirect-label label)) (b (defer-or-eval-transformer top-level-eval-hook exp)))
-                       (parse (cdr body)
-                         (extend-env l b r)
-                         (extend-env l b mr)
-                         (cons id ids)
-                         (cons (create-module-binding type id label imps (cons b exp))
-                               bindings)
-                         inits
-                         #f)))))
-                (($module-form)
-                 (let* ((*ribcage (make-empty-ribcage))
-                        (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
-                   (let-values (((orig id *exports forms) (parse-module e w ae *w)))
-                     (let-values (((r mr *bindings *inits)
-                                   (chi-external *ribcage orig
-                                     (map (lambda (d) (make-frob d meta?)) forms)
-                                     r mr ctem *exports (flatten-exports *exports) meta-residualize!)))
-                       (let ((iface (make-unresolved-interface id *exports))
-                             (bindings (append *bindings bindings))
-                             (inits (append inits *inits))
-                             (label (gen-indirect-label))
-                             (imps (get-implicit-exports id)))
-                         (extend-ribcage! ribcage id label)
-                         (let ((l (get-indirect-label label)) (b (make-binding '$module iface)))
-                           (parse (cdr body)
-                             (extend-env l b r)
-                             (extend-env l b mr)
-                             (cons id ids)
-                             (cons (create-module-binding type id label imps *exports) bindings)
-                             inits
-                             #f)))))))
-               (($import-form)
-                (let-values (((orig only? mid) (parse-import e w ae)))
-                  (let ((mlabel (id-var-name mid empty-wrap)))
-                    (let ((binding (lookup mlabel r)))
-                      (case (binding-type binding)
-                        (($module)
-                         (let* ((iface (binding-value binding))
-                                (import-iface (make-import-interface iface (import-mark-delta mid iface))))
-                           (when only? (extend-ribcage-barrier! ribcage mid))
-                           (do-import! import-iface ribcage)
-                           (parse (cdr body) r mr
-                             (cons import-iface ids)
-                             (update-imp-exports bindings (vector->list (interface-exports iface)))
-                             inits
-                             #f)))
-                        ((displaced-lexical) (displaced-lexical-error mid))
-                        (else (syntax-error mid "unknown module")))))))
-               ((alias-form)
-                (let-values (((new-id old-id) (parse-alias e w ae)))
-                  (let* ((new-id (wrap new-id w))
-                         (label (id-var-name-loc old-id w))
-                         (imps (get-implicit-exports new-id)))
-                    (extend-ribcage! ribcage new-id label)
-                    (parse (cdr body) r mr
-                      (cons new-id ids)
-                      (cons (create-module-binding type new-id label imps #f)
-                            bindings)
-                      inits
-                      #f))))
-                ((begin-form)
-                 (parse (let f ((forms (parse-begin e w ae #t)))
-                          (if (null? forms)
-                              (cdr body)
-                              (cons (make-frob (wrap (car forms) w) meta?)
-                                    (f (cdr forms)))))
-                   r mr ids bindings inits #f))
-                ((eval-when-form)
-                 (let-values (((when-list forms) (parse-eval-when e w ae)))
-                    (parse (if (memq 'eval when-list) ; mode set is implicitly (E)
-                               (let f ((forms forms))
-                                 (if (null? forms)
-                                     (cdr body)
-                                     (cons (make-frob (wrap (car forms) w) meta?)
-                                           (f (cdr forms)))))
-                               (cdr body))
-                      r mr ids bindings inits #f)))
-                ((meta-form)
-                 (parse (cons (make-frob (wrap (parse-meta e w ae) w) #t)
-                              (cdr body))
-                   r mr ids bindings inits #t))
-                ((local-syntax-form)
-                 (let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
-                   (parse (let f ((forms forms))
-                            (if (null? forms)
-                                (cdr body)
-                                (cons (make-frob (wrap (car forms) w) meta?)
-                                      (f (cdr forms)))))
-                     r mr ids bindings inits #f)))
-                (else ; found an init expression
-                 (when meta-seen? (syntax-error (source-wrap e w ae) "invalid meta definition"))
-                 (let f ((body (cons (make-frob (source-wrap e w ae) meta?) (cdr body))))
-                   (if (or (null? body) (not (frob-meta? (car body))))
-                       (return r mr bindings ids (append inits body))
-                       (begin
-                        ; expand and eval meta inits for effect only
-                         (let ((x (chi-meta-frob (car body) mr)))
-                           (top-level-eval-hook x)
-                           (meta-residualize! (ct-eval/residualize3 ctem void (lambda () x))))
-                         (f (cdr body)))))))))))))
-
-(define vmap
-  (lambda (fn v)
-    (do ((i (fx- (vector-length v) 1) (fx- i 1))
-         (ls '() (cons (fn (vector-ref v i)) ls)))
-        ((fx< i 0) ls))))
-
-(define vfor-each
-  (lambda (fn v)
-    (let ((len (vector-length v)))
-      (do ((i 0 (fx+ i 1)))
-          ((fx= i len))
-        (fn (vector-ref v i))))))
-
-(define do-top-import
-  (lambda (import-only? top-ribcage mid token)
-   ; silently treat import-only like regular import at top level
-    (build-cte-install mid
-      (build-data no-source
-        (make-binding 'do-import token))
-      (top-ribcage-key top-ribcage))))
-
-(define update-mode-set
-  (let ((table
-         '((L (load . L) (compile . C) (visit . V) (revisit . R) (eval . -))
-           (C (load . -) (compile . -) (visit . -) (revisit . -) (eval . C))
-           (V (load . V) (compile . C) (visit . V) (revisit . -) (eval . -))
-           (R (load . R) (compile . C) (visit . -) (revisit . R) (eval . -))
-           (E (load . -) (compile . -) (visit . -) (revisit . -) (eval . E)))))
-    (lambda (when-list mode-set)
-      (define remq
-        (lambda (x ls)
-          (if (null? ls)
-              '()
-              (if (eq? (car ls) x)
-                  (remq x (cdr ls))
-                  (cons (car ls) (remq x (cdr ls)))))))
-      (remq '-
-        (apply append
-          (map (lambda (m)
-                 (let ((row (cdr (assq m table))))
-                   (map (lambda (s) (cdr (assq s row)))
-                        when-list)))
-               mode-set))))))
-
-(define initial-mode-set
-  (lambda (when-list compiling-a-file)
-    (apply append
-      (map (lambda (s)
-             (if compiling-a-file
-                 (case s
-                   ((compile) '(C))
-                   ((load) '(L))
-                   ((visit) '(V))
-                   ((revisit) '(R))
-                   (else '()))
-                 (case s
-                   ((eval) '(E))
-                   (else '()))))
-           when-list))))
-
-(define rt-eval/residualize
-  (lambda (rtem thunk)
-    (if (memq 'E rtem)
-        (thunk)
-        (let ((thunk (if (memq 'C rtem)
-                         (let ((x (thunk)))
-                           (top-level-eval-hook x)
-                           (lambda () x))
-                         thunk)))
-          (if (memq 'V rtem)
-              (if (or (memq 'L rtem) (memq 'R rtem))
-                  (thunk) ; visit-revisit
-                  (build-visit-only (thunk)))
-              (if (or (memq 'L rtem) (memq 'R rtem))
-                  (build-revisit-only (thunk))
-                  (chi-void)))))))
-
-(define ct-eval/residualize2
-  (lambda (ctem thunk)
-    (let ((t #f))
-      (ct-eval/residualize3 ctem
-        (lambda ()
-          (unless t (set! t (thunk)))
-          (top-level-eval-hook t))
-        (lambda () (or t (thunk)))))))
-
-(define ct-eval/residualize3
-  (lambda (ctem eval-thunk residualize-thunk)
-    (if (memq 'E ctem)
-        (begin (eval-thunk) (chi-void))
-        (begin
-          (when (memq 'C ctem) (eval-thunk))
-          (if (memq 'R ctem)
-              (if (or (memq 'L ctem) (memq 'V ctem))
-                  (residualize-thunk) ; visit-revisit
-                  (build-revisit-only (residualize-thunk)))
-              (if (or (memq 'L ctem) (memq 'V ctem))
-                  (build-visit-only (residualize-thunk))
-                  (chi-void)))))))
-
-(define chi-frobs
-  (lambda (frob* r mr m?)
-    (map (lambda (x) (chi (frob-e x) r mr empty-wrap m?)) frob*)))
-
-(define chi-meta-frob
-  (lambda (x mr)
-    (chi (frob-e x) mr mr empty-wrap #t)))
-
-(define chi-sequence
-  (lambda (body r mr w ae m?)
-    (build-sequence ae
-      (let dobody ((body body))
-        (if (null? body)
-            '()
-            (let ((first (chi (car body) r mr w m?)))
-              (cons first (dobody (cdr body)))))))))
-
-(define chi
-  (lambda (e r mr w m?)
-    (let-values (((type value e w ae) (syntax-type e r w no-source #f)))
-      (chi-expr type value e r mr w ae m?))))
-
-(define chi-expr
-  (lambda (type value e r mr w ae m?)
-    (case type
-      ((lexical)
-       (build-lexical-reference 'value ae value))
-      ;;; AZIZ
-      ((core-primitive)
-       (build-primref ae value))
-      ((core) (value e r mr w ae m?))
-      ((lexical-call)
-       (chi-application
-         (build-lexical-reference 'fun
-           (let ((x (car e)))
-             (if (syntax-object? x) (syntax-object-expression x) x))
-           value)
-         e r mr w ae m?))
-      ((constant) (build-data ae (strip (source-wrap e w ae) empty-wrap)))
-      ((global) (build-global-reference ae value))
-      ((meta-variable)
-       (if m?
-           (build-global-reference ae value)
-           (displaced-lexical-error (source-wrap e w ae))))
-      ((call) (chi-application (chi (car e) r mr w m?) e r mr w ae m?))
-      ((begin-form) (chi-sequence (parse-begin e w ae #f) r mr w ae m?))
-      ((local-syntax-form)
-       (let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
-         (chi-sequence forms r mr w ae m?)))
-      ((eval-when-form)
-       (let-values (((when-list forms) (parse-eval-when e w ae)))
-         (if (memq 'eval when-list) ; mode set is implicitly (E)
-             (chi-sequence forms r mr w ae m?)
-             (chi-void))))
-      ((meta-form)
-       (syntax-error (source-wrap e w ae) "invalid context for meta definition"))
-      ((define-form)
-       (parse-define e w ae)
-       (syntax-error (source-wrap e w ae) "invalid context for definition"))
-      ((define-syntax-form)
-       (parse-define-syntax e w ae)
-       (syntax-error (source-wrap e w ae) "invalid context for definition"))
-      (($module-form)
-       (let-values (((orig id exports forms) (parse-module e w ae w)))
-         (syntax-error orig "invalid context for definition")))
-      (($import-form)
-       (let-values (((orig only? mid) (parse-import e w ae)))
-         (syntax-error orig "invalid context for definition")))
-      ((alias-form)
-       (parse-alias e w ae)
-       (syntax-error (source-wrap e w ae) "invalid context for definition"))
-      ((syntax)
-       (syntax-error (source-wrap e w ae)
-         "reference to pattern variable outside syntax form"))
-      ((displaced-lexical) (displaced-lexical-error (source-wrap e w ae)))
-      (else (syntax-error (source-wrap e w ae))))))
-
-(define chi-application
-  (lambda (x e r mr w ae m?)
-    (syntax-case e ()
-      ((e0 e1 ...)
-       (build-application ae x
-         (map (lambda (e) (chi e r mr w m?)) (syntax (e1 ...)))))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define chi-set!
-  (lambda (e r w ae rib)
-    (syntax-case e ()
-      ((_ id val)
-       (id? (syntax id))
-       (let ((n (id-var-name (syntax id) w)))
-         (let ((b (lookup n r)))
-           (case (binding-type b)
-             ((macro!)
-              (let ((id (wrap (syntax id) w)) (val (wrap (syntax val) w)))
-                (syntax-type (chi-macro (binding-value b)
-                               `(,(syntax set!) ,id ,val)
-                               r empty-wrap #f rib) r empty-wrap #f rib)))
-             (else
-              (values 'core
-                (lambda (e r mr w ae m?)
-                 ; repeat lookup in case we were first expression (init) in
-                 ; module or lambda body.  we repeat id-var-name as well,
-                 ; although this is only necessary if we allow inits to
-                 ; preced definitions
-                  (let ((val (chi (syntax val) r mr w m?))
-                        (n (id-var-name (syntax id) w)))
-                    (let ((b (lookup n r)))
-                      (case (binding-type b)
-                        ((lexical) (build-lexical-assignment ae (binding-value b) val))
-                        ((global)
-                         (let ((sym (binding-value b)))
-                           (when (read-only-binding? n)
-                             (syntax-error (source-wrap e w ae)
-                               "invalid assignment to read-only variable"))
-                           (build-global-assignment ae sym val)))
-                        ((meta-variable)
-                         (if m?
-                             (build-global-assignment ae (binding-value b) val)
-                             (displaced-lexical-error (wrap (syntax id) w))))
-                        ((displaced-lexical)
-                         (displaced-lexical-error (wrap (syntax id) w)))
-                        (else (syntax-error (source-wrap e w ae)))))))
-                e w ae))))))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-
-
-
-(define chi-macro
-  (lambda (p e r w ae rib)
-    (define rebuild-macro-output
-      (lambda (x m)
-        (cond ((pair? x)
-               (cons (rebuild-macro-output (car x) m)
-                     (rebuild-macro-output (cdr x) m)))
-              ((syntax-object? x)
-               (let ((w (syntax-object-wrap x)))
-                 (let ((ms (wrap-marks w)) (s (wrap-subst w)))
-                   (make-syntax-object (syntax-object-expression x)
-                     (if (and (pair? ms) (eq? (car ms) the-anti-mark))
-                         (make-wrap (cdr ms) (cdr s))
-                         (make-wrap (cons m ms)
-                           (if rib
-                               (cons rib (cons 'shift s))
-                               (cons 'shift s))))))))
-              ((vector? x)
-               (let* ((n (vector-length x)) (v (make-vector n)))
-                 (do ((i 0 (fx+ i 1)))
-                     ((fx= i n) v)
-                     (vector-set! v i
-                       (rebuild-macro-output (vector-ref x i) m)))))
-              ((symbol? x)
-               (syntax-error (source-wrap e w ae)
-                 "encountered raw symbol "
-                (symbol->string x)
-                 " in output of macro"))
-              (else x))))
-    (rebuild-macro-output
-      (let ((out (p (source-wrap e (anti-mark w) ae))))
-        (if (procedure? out)
-            (out (lambda (id)
-                   (unless (identifier? id)
-                     (syntax-error id
-                       "environment argument is not an identifier"))
-                   (lookup (id-var-name id empty-wrap) r)))
-            out))
-      (new-mark))))
-
-(define chi-body
-  (lambda (body outer-form r mr w m?)
-    (let* ((ribcage (make-empty-ribcage))
-           (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))
-           (body (map (lambda (x) (make-frob (wrap x w) #f)) body)))
-      (let-values (((r mr exprs ids vars vals inits)
-                    (chi-internal ribcage outer-form body r mr m?)))
-        (when (null? exprs) (syntax-error outer-form "no expressions in body"))
-        (build-body no-source
-          (reverse vars) (chi-frobs (reverse vals) r mr m?)
-          (build-sequence no-source
-            (chi-frobs (append inits exprs) r mr m?)))))))
-
-(define chi-internal
-  ;; In processing the forms of the body, we create a new, empty wrap.
-  ;; This wrap is augmented (destructively) each time we discover that
-  ;; the next form is a definition.  This is done:
-  ;;
-  ;;   (1) to allow the first nondefinition form to be a call to
-  ;;       one of the defined ids even if the id previously denoted a
-  ;;       definition keyword or keyword for a macro expanding into a
-  ;;       definition;
-  ;;   (2) to prevent subsequent definition forms (but unfortunately
-  ;;       not earlier ones) and the first nondefinition form from
-  ;;       confusing one of the bound identifiers for an auxiliary
-  ;;       keyword; and
-  ;;   (3) so that we do not need to restart the expansion of the
-  ;;       first nondefinition form, which is problematic anyway
-  ;;       since it might be the first element of a begin that we
-  ;;       have just spliced into the body (meaning if we restarted,
-  ;;       we'd really need to restart with the begin or the macro
-  ;;       call that expanded into the begin, and we'd have to give
-  ;;       up allowing (begin <defn>+ <expr>+), which is itself
-  ;;       problematic since we don't know if a begin contains only
-  ;;       definitions until we've expanded it).
-  ;;
-  ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
-  ;; into the body.
-  ;;
-  ;; outer-form is fully wrapped w/source
-  (lambda (ribcage source-exp body r mr m?)
-    (define return
-      (lambda (r mr exprs ids vars vals inits)
-        (check-defined-ids source-exp ids)
-        (values r mr exprs ids vars vals inits)))
-    (let parse ((body body) (r r) (mr mr) (ids '()) (vars '()) (vals '()) (inits '()) (meta-seen? #f))
-      (if (null? body)
-          (return r mr body ids vars vals inits)
-          (let* ((fr (car body)) (e (frob-e fr)) (meta? (frob-meta? fr)))
-            (let-values (((type value e w ae) (syntax-type e r empty-wrap no-source ribcage)))
-              (case type
-                ((define-form)
-                 (let-values (((id rhs w) (parse-define e w ae)))
-                   (let ((id (wrap id w)) (label (gen-label)))
-                     (cond
-                       (meta?
-                        (let ((sym (generate-id (id-sym-name id))))
-                          (extend-ribcage! ribcage id label)
-                         ; add meta bindings only to meta environment
-                         ; so visible only to next higher level and beyond
-                          (let ((mr (extend-env label (make-binding 'meta-variable sym) mr)))
-                            (define-top-level-value-hook sym
-                              (top-level-eval-hook (chi rhs mr mr w #t)))
-                            (parse (cdr body) r mr (cons id ids) vars vals inits #f))))
-                       (else
-                        (let ((var (gen-var id)))
-                          (extend-ribcage! ribcage id label)
-                         ; add lexical bindings only to run-time environment
-                          (parse (cdr body)
-                            (extend-env label (make-binding 'lexical var) r)
-                            mr
-                            (cons id ids)
-                            (cons var vars)
-                            (cons (make-frob (wrap rhs w) meta?) vals)
-                            inits
-                            #f)))))))
-                ((define-syntax-form)
-                 (let-values (((id rhs w) (parse-define-syntax e w ae)))
-                   (let ((id (wrap id w))
-                         (label (gen-label))
-                         (exp (chi rhs mr mr w #t)))
-                     (extend-ribcage! ribcage id label)
-                     (let ((b (defer-or-eval-transformer local-eval-hook exp)))
-                       (parse (cdr body)
-                         (extend-env label b r) (extend-env label b mr)
-                         (cons id ids) vars vals inits #f)))))
-                (($module-form)
-                 (let* ((*ribcage (make-empty-ribcage))
-                        (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
-                   (let-values (((orig id exports forms) (parse-module e w ae *w)))
-                     (let-values (((r mr *body *ids *vars *vals *inits)
-                                   (chi-internal *ribcage orig
-                                     (map (lambda (d) (make-frob d meta?)) forms)
-                                     r mr m?)))
-                      ; valid bound ids checked already by chi-internal
-                       (check-module-exports source-exp (flatten-exports exports) *ids)
-                       (let ((iface (make-resolved-interface id exports #f))
-                             (vars (append *vars vars))
-                             (vals (append *vals vals))
-                             (inits (append inits *inits *body))
-                             (label (gen-label)))
-                         (extend-ribcage! ribcage id label)
-                         (let ((b (make-binding '$module iface)))
-                           (parse (cdr body)
-                             (extend-env label b r) (extend-env label b mr)
-                             (cons id ids) vars vals inits #f)))))))
-               (($import-form)
-                (let-values (((orig only? mid) (parse-import e w ae)))
-                  (let ((mlabel (id-var-name mid empty-wrap)))
-                    (let ((binding (lookup mlabel r)))
-                      (case (binding-type binding)
-                        (($module)
-                         (let* ((iface (binding-value binding))
-                                (import-iface (make-import-interface iface (import-mark-delta mid iface))))
-                           (when only? (extend-ribcage-barrier! ribcage mid))
-                           (do-import! import-iface ribcage)
-                           (parse (cdr body) r mr (cons import-iface ids) vars vals inits #f)))
-                        ((displaced-lexical) (displaced-lexical-error mid))
-                        (else (syntax-error mid "unknown module")))))))
-                ((alias-form)
-                 (let-values (((new-id old-id) (parse-alias e w ae)))
-                   (let ((new-id (wrap new-id w)))
-                     (extend-ribcage! ribcage new-id (id-var-name-loc old-id w))
-                     (parse (cdr body) r mr
-                       (cons new-id ids)
-                       vars
-                       vals
-                       inits
-                       #f))))
-                ((begin-form)
-                 (parse (let f ((forms (parse-begin e w ae #t)))
-                          (if (null? forms)
-                              (cdr body)
-                              (cons (make-frob (wrap (car forms) w) meta?)
-                                    (f (cdr forms)))))
-                   r mr ids vars vals inits #f))
-                ((eval-when-form)
-                 (let-values (((when-list forms) (parse-eval-when e w ae)))
-                   (parse (if (memq 'eval when-list) ; mode set is implicitly (E)
-                              (let f ((forms forms))
-                                (if (null? forms)
-                                    (cdr body)
-                                    (cons (make-frob (wrap (car forms) w) meta?)
-                                          (f (cdr forms)))))
-                              (cdr body))
-                     r mr ids vars vals inits #f)))
-                ((meta-form)
-                 (parse (cons (make-frob (wrap (parse-meta e w ae) w) #t)
-                              (cdr body))
-                   r mr ids vars vals inits #t))
-                ((local-syntax-form)
-                 (let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
-                   (parse (let f ((forms forms))
-                            (if (null? forms)
-                                (cdr body)
-                                (cons (make-frob (wrap (car forms) w) meta?)
-                                      (f (cdr forms)))))
-                     r mr ids vars vals inits #f)))
-                (else ; found a non-definition
-                 (when meta-seen? (syntax-error (source-wrap e w ae) "invalid meta definition"))
-                 (let f ((body (cons (make-frob (source-wrap e w ae) meta?) (cdr body))))
-                   (if (or (null? body) (not (frob-meta? (car body))))
-                       (return r mr body ids vars vals inits)
-                       (begin
-                        ; expand meta inits for effect only
-                         (top-level-eval-hook (chi-meta-frob (car body) mr))
-                         (f (cdr body)))))))))))))
-
-(define import-mark-delta
- ; returns list of marks layered on top of module id beyond those
- ; cached in the interface
-  (lambda (mid iface)
-    (diff-marks (id-marks mid) (interface-marks iface))))
-
-(define lookup-import-label
-  (lambda (id)
-    (let ((label (id-var-name-loc id empty-wrap)))
-      (unless label
-        (syntax-error id "exported identifier not visible"))
-      label)))
-  
-(define do-import!
-  (lambda (import-iface ribcage)
-    (let ((ie (interface-exports (import-interface-interface import-iface))))
-      (if (fx<= (vector-length ie) 20)
-          (let ((new-marks (import-interface-new-marks import-iface)))
-            (vfor-each
-              (lambda (id)
-                (import-extend-ribcage! ribcage new-marks id
-                  (lookup-import-label id)))
-              ie))
-          (extend-ribcage-subst! ribcage import-iface)))))
-
-(define parse-module
-  (lambda (e w ae *w)
-    (define listify
-      (lambda (exports)
-        (if (null? exports)
-            '()
-            (cons (syntax-case (car exports) ()
-                    ((ex ...) (listify (syntax (ex ...))))
-                    (x (if (id? (syntax x))
-                           (wrap (syntax x) *w)
-                           (syntax-error (source-wrap e w ae)
-                             "invalid exports list in"))))
-                  (listify (cdr exports))))))
-    (syntax-case e ()
-      ((_ orig mid (ex ...) form ...)
-       (id? (syntax mid))
-      ; id receives old wrap so it won't be confused with id of same name
-      ; defined within the module
-       (values (syntax orig) (wrap (syntax mid) w) (listify (syntax (ex ...))) (map (lambda (x) (wrap x *w)) (syntax (form ...)))))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-import
-  (lambda (e w ae)
-    (syntax-case e ()
-      ((_ orig #t mid)
-       (id? (syntax mid))
-       (values (syntax orig) #t (wrap (syntax mid) w)))
-      ((_ orig #f mid)
-       (id? (syntax mid))
-       (values (syntax orig) #f (wrap (syntax mid) w)))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-define
-  (lambda (e w ae)
-    (syntax-case e ()
-      ((_ name val)
-       (id? (syntax name))
-       (values (syntax name) (syntax val) w))
-      ((_ (name . args) e1 e2 ...)
-       (and (id? (syntax name))
-            (valid-bound-ids? (lambda-var-list (syntax args))))
-       (values (wrap (syntax name) w)
-               (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
-               empty-wrap))
-      ((_ name)
-       (id? (syntax name))
-       (values (wrap (syntax name) w) (syntax (void)) empty-wrap))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-define-syntax
-  (lambda (e w ae)
-    (syntax-case e ()
-      ((_ (name id) e1 e2 ...)
-       (and (id? (syntax name)) (id? (syntax id)))
-       (values (wrap (syntax name) w)
-               `(,(syntax lambda) ,(wrap (syntax (id)) w)
-                   ,@(wrap (syntax (e1 e2 ...)) w))
-               empty-wrap))
-      ((_ name val)
-       (id? (syntax name))
-       (values (syntax name) (syntax val) w))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-meta
-  (lambda (e w ae)
-    (syntax-case e ()
-      ((_ . form) (syntax form))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-eval-when
-  (lambda (e w ae)
-    (syntax-case e ()
-      ((_ (x ...) e1 e2 ...)
-       (values (chi-when-list (syntax (x ...)) w) (syntax (e1 e2 ...))))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-alias
-  (lambda (e w ae)
-    (syntax-case e ()
-      ((_ new-id old-id)
-       (and (id? (syntax new-id)) (id? (syntax old-id)))
-       (values (syntax new-id) (syntax old-id)))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-begin
-  (lambda (e w ae empty-okay?)
-    (syntax-case e ()
-      ((_) empty-okay? '())
-      ((_ e1 e2 ...) (syntax (e1 e2 ...)))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define chi-lambda-clause
-  (lambda (e c r mr w m?)
-    (syntax-case c ()
-      (((id ...) e1 e2 ...)
-       (let ((ids (syntax (id ...))))
-         (if (not (valid-bound-ids? ids))
-             (syntax-error e "invalid parameter list in")
-             (let ((labels (gen-labels ids))
-                   (new-vars (map gen-var ids)))
-               (values
-                 new-vars
-                 (chi-body (syntax (e1 e2 ...))
-                           e
-                           (extend-var-env* labels new-vars r)
-                           mr
-                           (make-binding-wrap ids labels w)
-                           m?))))))
-      ((ids e1 e2 ...)
-       (let ((old-ids (lambda-var-list (syntax ids))))
-         (if (not (valid-bound-ids? old-ids))
-             (syntax-error e "invalid parameter list in")
-             (let ((labels (gen-labels old-ids))
-                   (new-vars (map gen-var old-ids)))
-               (values
-                 (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
-                   (if (null? ls1)
-                       ls2
-                       (f (cdr ls1) (cons (car ls1) ls2))))
-                 (chi-body (syntax (e1 e2 ...))
-                           e
-                           (extend-var-env* labels new-vars r)
-                           mr
-                           (make-binding-wrap old-ids labels w)
-                           m?))))))
-      (_ (syntax-error e)))))
-
-(define chi-local-syntax
-  (lambda (rec? e r mr w ae)
-    (syntax-case e ()
-      ((_ ((id val) ...) e1 e2 ...)
-       (let ((ids (syntax (id ...))))
-         (if (not (valid-bound-ids? ids))
-             (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
-               (source-wrap e w ae)
-               "keyword")
-             (let ((labels (gen-labels ids)))
-               (let ((new-w (make-binding-wrap ids labels w)))
-                 (let ((b* (let ((w (if rec? new-w w)))
-                             (map (lambda (x)
-                                    (defer-or-eval-transformer
-                                      local-eval-hook
-                                      (chi x mr mr w #t)))
-                                  (syntax (val ...))))))
-                   (values
-                     (syntax (e1 e2 ...))
-                     (extend-env* labels b* r)
-                     (extend-env* labels b* mr)
-                     new-w
-                     ae)))))))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define chi-void
-  (lambda ()
-    (build-application no-source (build-primref no-source 'void) '())))
-
-(define ellipsis?
-  (lambda (x)
-    (and (nonsymbol-id? x)
-         (literal-id=? x (syntax (... ...))))))
-
-;;; data
-
-;;; strips all annotations from potentially circular reader output.
-
-(define strip-annotation
-  (lambda (x)
-    (cond
-      ((pair? x)
-       (cons (strip-annotation (car x))
-             (strip-annotation (cdr x))))
-      ((annotation? x) (annotation-stripped x))
-      (else x))))
-
-;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
-;;; on an annotation, strips the annotation as well.
-;;; since only the head of a list is annotated by the reader, not each pair
-;;; in the spine, we also check for pairs whose cars are annotated in case
-;;; we've been passed the cdr of an annotated list
-
-(define strip*
-  (lambda (x w fn)
-    (if (top-marked? w)
-        (fn x)
-        (let f ((x x))
-          (cond
-            ((syntax-object? x)
-             (strip* (syntax-object-expression x) (syntax-object-wrap x) fn))
-            ((pair? x)
-             (let ((a (f (car x))) (d (f (cdr x))))
-               (if (and (eq? a (car x)) (eq? d (cdr x)))
-                   x
-                   (cons a d))))
-            ((vector? x)
-             (let ((old (vector->list x)))
-                (let ((new (map f old)))
-                   (if (andmap eq? old new) x (list->vector new)))))
-            (else x))))))
-
-(define strip
-  (lambda (x w)
-    (strip* x w
-      (lambda (x)
-        (if (or (annotation? x) (and (pair? x) (annotation? (car x))))
-            (strip-annotation x)
-            x)))))
-
-;;; lexical variables
-
-(define gen-var
-  (lambda (id)
-    (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
-      (if (annotation? id)
-          (build-lexical-var id (annotation-expression id))
-          (build-lexical-var id id)))))
-
-(define lambda-var-list
-  (lambda (vars)
-    (let lvl ((vars vars) (ls '()) (w empty-wrap))
-       (cond
-         ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w))
-         ((id? vars) (cons (wrap vars w) ls))
-         ((null? vars) ls)
-         ((syntax-object? vars)
-          (lvl (syntax-object-expression vars)
-               ls
-               (join-wraps w (syntax-object-wrap vars))))
-         ((annotation? vars)
-          (lvl (annotation-expression vars) ls w))
-       ; include anything else to be caught by subsequent error
-       ; checking
-         (else (cons vars ls))))))
-
-
-; must precede global-extends
-
-(primitive-set! '$sc-put-cte
-  (lambda (id b top-token)
-     (define sc-put-module
-       (lambda (exports token new-marks)
-         (vfor-each
-           (lambda (id) (store-import-binding id token new-marks))
-           exports)))
-     (define (put-cte id binding token)
-       (let ((sym (if (symbol? id) id (id-var-name id empty-wrap))))
-        (store-import-binding id token '())
-         (put-global-definition-hook sym
-          ; global binding is assumed; if global pass #f to remove existing binding, if any
-           (if (and (eq? (binding-type binding) 'global)
-                    (eq? (binding-value binding) sym))
-               #f
-               binding))))
-     (let ((binding (make-transformer-binding b)))
-       (case (binding-type binding)
-         (($module)
-          (let ((iface (binding-value binding)))
-            (sc-put-module (interface-exports iface) (interface-token iface) '()))
-          (put-cte id binding top-token))
-         ((do-alias) (store-import-binding id top-token '()))
-         ((do-import)
-          ; fake binding: id is module id binding-value is token
-          (let ((token (binding-value b)))
-             (let ((b (lookup (id-var-name id empty-wrap) null-env)))
-               (case (binding-type b)
-                 (($module)
-                  (let* ((iface (binding-value b))
-                         (exports (interface-exports iface)))
-                    (unless (eq? (interface-token iface) token)
-                      (syntax-error id "import mismatch for module"))
-                    (sc-put-module (interface-exports iface) top-token
-                      (import-mark-delta id iface))))
-                 (else (syntax-error id "unknown module"))))))
-         (else (put-cte id binding top-token))))
-     ))
-
-
-;;; core transformers
-
-(global-extend 'local-syntax 'letrec-syntax #t)
-(global-extend 'local-syntax 'let-syntax #f)
-
-
-(global-extend 'core 'fluid-let-syntax
-  (lambda (e r mr w ae m?)
-    (syntax-case e ()
-      ((_ ((var val) ...) e1 e2 ...)
-       (valid-bound-ids? (syntax (var ...)))
-       (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
-         (for-each
-           (lambda (id n)
-             (case (binding-type (lookup n r))
-               ((displaced-lexical) (displaced-lexical-error (wrap id w)))))
-           (syntax (var ...))
-           names)
-         (let ((b* (map (lambda (x)
-                          (defer-or-eval-transformer
-                            local-eval-hook
-                            (chi x mr mr w #t)))
-                        (syntax (val ...)))))
-           (chi-body
-             (syntax (e1 e2 ...))
-             (source-wrap e w ae)
-             (extend-env* names b* r)
-             (extend-env* names b* mr)
-             w
-             m?))))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(global-extend 'core 'quote
-   (lambda (e r mr w ae m?)
-      (syntax-case e ()
-         ((_ e) (build-data ae (strip (syntax e) w)))
-         (_ (syntax-error (source-wrap e w ae))))))
-
-(global-extend 'core '|#primitive|
-   (lambda (e r mr w ae m?)
-      (syntax-case e ()
-         ((_ name) (id? #'name)
-          (let ([name (strip (syntax name) w)])
-            (if (or (memq name (public-primitives))
-                    (memq name (system-primitives)))
-                (build-primref ae name)
-                (syntax-error (source-wrap e w ae)))))
-         (_ (syntax-error (source-wrap e w ae))))))
-
-(global-extend 'core 'syntax
-  (let ()
-    (define gen-syntax
-      (lambda (src e r maps ellipsis? vec?)
-        (if (id? e)
-            (let ((label (id-var-name e empty-wrap)))
-              (let ((b (lookup label r)))
-                (if (eq? (binding-type b) 'syntax)
-                    (let-values (((var maps)
-                                  (let ((var.lev (binding-value b)))
-                                    (gen-ref src (car var.lev) (cdr var.lev) maps))))
-                      (values `(ref ,var) maps))
-                    (if (ellipsis? e)
-                        (syntax-error src "misplaced ellipsis in syntax form")
-                        (values `(quote ,e) maps)))))
-            (syntax-case e ()
-              ((dots e)
-               (ellipsis? (syntax dots))
-               (if vec?
-                   (syntax-error src "misplaced ellipsis in syntax template")
-                   (gen-syntax src (syntax e) r maps (lambda (x) #f) #f)))
-              ((x dots . y)
-               ; this could be about a dozen lines of code, except that we
-               ; choose to handle (syntax (x ... ...)) forms
-               (ellipsis? (syntax dots))
-               (let f ((y (syntax y))
-                       (k (lambda (maps)
-                            (let-values (((x maps)
-                                          (gen-syntax src (syntax x) r
-                                            (cons '() maps) ellipsis? #f)))
-                              (if (null? (car maps))
-                                  (syntax-error src
-                                    "extra ellipsis in syntax form")
-                                  (values (gen-map x (car maps))
-                                          (cdr maps)))))))
-                 (syntax-case y ()
-                   ((dots . y)
-                    (ellipsis? (syntax dots))
-                    (f (syntax y)
-                       (lambda (maps)
-                         (let-values (((x maps) (k (cons '() maps))))
-                           (if (null? (car maps))
-                               (syntax-error src
-                                 "extra ellipsis in syntax form")
-                               (values (gen-mappend x (car maps))
-                                       (cdr maps)))))))
-                   (_ (let-values (((y maps) (gen-syntax src y r maps ellipsis? vec?)))
-                        (let-values (((x maps) (k maps)))
-                          (values (gen-append x y) maps)))))))
-              ((x . y)
-               (let-values (((xnew maps) (gen-syntax src (syntax x) r maps ellipsis? #f)))
-                 (let-values (((ynew maps) (gen-syntax src (syntax y) r maps ellipsis? vec?)))
-                   (values (gen-cons e (syntax x) (syntax y) xnew ynew)
-                           maps))))
-              (#(x1 x2 ...)
-               (let ((ls (syntax (x1 x2 ...))))
-                 (let-values (((lsnew maps) (gen-syntax src ls r maps ellipsis? #t)))
-                   (values (gen-vector e ls lsnew) maps))))
-              (_ (values `(quote ,e) maps))))))
-
-    (define gen-ref
-      (lambda (src var level maps)
-        (if (fx= level 0)
-            (values var maps)
-            (if (null? maps)
-                (syntax-error src "missing ellipsis in syntax form")
-                (let-values (((outer-var outer-maps) (gen-ref src var (fx- level 1) (cdr maps))))
-                  (let ((b (assq outer-var (car maps))))
-                    (if b
-                        (values (cdr b) maps)
-                        (let ((inner-var (gen-var 'tmp)))
-                          (values inner-var
-                                  (cons (cons (cons outer-var inner-var)
-                                              (car maps))
-                                        outer-maps))))))))))
-
-    (define gen-append
-      (lambda (x y)
-        (if (equal? y '(quote ()))
-            x
-            `(append ,x ,y))))
-
-    (define gen-mappend
-      (lambda (e map-env)
-        `(apply (primitive append) ,(gen-map e map-env))))
-
-    (define gen-map
-      (lambda (e map-env)
-        (let ((formals (map cdr map-env))
-              (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
-          (cond
-            ((eq? (car e) 'ref)
-             ; identity map equivalence:
-             ; (map (lambda (x) x) y) == y
-             (car actuals))
-            ((andmap
-                (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
-                (cdr e))
-             ; eta map equivalence:
-             ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
-             `(map (primitive ,(car e))
-                   ,@(map (let ((r (map cons formals actuals)))
-                            (lambda (x) (cdr (assq (cadr x) r))))
-                          (cdr e))))
-            (else `(map (case-lambda [,formals ,e]) ,@actuals))))))
-
-   ; 12/12/00: semantic change: we now return original syntax object (e)
-   ; if no pattern variables were found within, to avoid dropping
-   ; source annotations prematurely.  the "syntax returns lists" for
-   ; lists in its input guarantee counts only for substructure that
-   ; contains pattern variables
-    (define gen-cons
-      (lambda (e x y xnew ynew)
-        (case (car ynew)
-          ((quote)
-           (if (eq? (car xnew) 'quote)
-               (let ((xnew (cadr xnew)) (ynew (cadr ynew)))
-                 (if (and (eq? xnew x) (eq? ynew y))
-                     `',e
-                     `'(,xnew . ,ynew)))
-               (if (eq? (cadr ynew) '()) `(list ,xnew) `(cons ,xnew ,ynew))))
-          ((list) `(list ,xnew ,@(cdr ynew)))
-          (else `(cons ,xnew ,ynew)))))
-
-    (define gen-vector
-      (lambda (e ls lsnew)
-        (cond
-          ((eq? (car lsnew) 'quote)
-           (if (eq? (cadr lsnew) ls)
-               `',e
-               `(quote #(,@(cadr lsnew)))))
-          ((eq? (car lsnew) 'list) `(vector ,@(cdr lsnew)))
-          (else `(list->vector ,lsnew)))))
-
-
-    (define regen
-      (lambda (x)
-        (case (car x)
-          ((ref) (build-lexical-reference 'value no-source (cadr x)))
-          ((primitive) (build-primref no-source (cadr x)))
-          ((quote) (build-data no-source (cadr x)))
-          ((lambda) 
-           (build-lambda no-source (cadr x) (regen (caddr x))))
-          ((case-lambda)
-           (let ([d (cdr x)])
-             (build-case-lambda no-source
-              (map car d)
-              (map (lambda (x) (regen (cadr x))) d))))
-          ((map) (let ((ls (map regen (cdr x))))
-                   (build-application no-source
-                     (if (fx= (length ls) 2)
-                         (build-primref no-source 'map)
-                        ; really need to do our own checking here
-                         (build-primref no-source 2 'map)) ; require error check
-                     ls)))
-          (else (build-application no-source
-                  (build-primref no-source (car x))
-                  (map regen (cdr x)))))))
-
-    (lambda (e r mr w ae m?)
-      (let ((e (source-wrap e w ae)))
-        (syntax-case e ()
-          ((_ x)
-           (let-values (((e maps) (gen-syntax e (syntax x) r '() ellipsis? #f)))
-             (regen e)))
-          (_ (syntax-error e)))))))
-
-
-(global-extend 'core 'lambda
-  (lambda (e r mr w ae m?)
-    (syntax-case e ()
-      ((_ . c)
-       (let-values (((vars body)
-                     (chi-lambda-clause 
-                       (source-wrap e w ae) 
-                       (syntax c) r mr w m?)))
-         (build-lambda ae vars body))))))
-
-;;; AZIZ
-(global-extend 'core 'case-lambda
-   (lambda (e r mr w ae m?)
-     (syntax-case e ()
-       [(_ c* ...)
-        (let-values ([(vars* body*)
-                      (let f ([c* #'(c* ...)])
-                        (syntax-case c* ()
-                          [() (values '() '())]
-                          [(c . c*) 
-                           (let-values ([(vars body)
-                                         (chi-lambda-clause
-                                           (source-wrap e w ae)
-                                           #'c r mr w m?)])
-                             (let-values ([(vars* body*) (f #'c*)])
-                               (values 
-                                 (cons vars vars*)
-                                 (cons body body*))))]))])
-           (build-case-lambda ae vars* body*))])))
-
-
-
-
-(global-extend 'core 'letrec
-  (lambda (e r mr w ae m?)
-    (syntax-case e ()
-      ((_ ((id val) ...) e1 e2 ...)
-       (let ((ids (syntax (id ...))))
-         (if (not (valid-bound-ids? ids))
-             (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
-               (source-wrap e w ae) "bound variable")
-             (let ((labels (gen-labels ids))
-                   (new-vars (map gen-var ids)))
-               (let ((w (make-binding-wrap ids labels w))
-                    (r (extend-var-env* labels new-vars r)))
-                 (build-letrec ae
-                   new-vars
-                   (map (lambda (x) (chi x r mr w m?)) (syntax (val ...)))
-                   (chi-body (syntax (e1 e2 ...)) (source-wrap e w ae) r mr w m?)))))))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-
-(global-extend 'core 'if
-   (lambda (e r mr w ae m?)
-      (syntax-case e ()
-         ((_ test then)
-          (build-conditional ae
-             (chi (syntax test) r mr w m?)
-             (chi (syntax then) r mr w m?)
-             (chi-void)))
-         ((_ test then else)
-          (build-conditional ae
-             (chi (syntax test) r mr w m?)
-             (chi (syntax then) r mr w m?)
-             (chi (syntax else) r mr w m?)))
-         (_ (syntax-error (source-wrap e w ae))))))
-
-;;; AZIZ
-(global-extend 'core 'foreign-call
-  (lambda (e r mr w ae m?)
-    (syntax-case e ()
-      [(_ proc arg* ...)
-       (build-foreign-call ae
-         (chi #'proc r mr w m?)
-         (let f ([arg* #'(arg* ...)])
-           (syntax-case arg* ()
-             [() '()]
-             [(a . arg*)
-              (cons (chi #'a r mr w m?)
-                    (f #'arg*))])))]
-      [_ (syntax-error (source-wrap e w ae))])))
-
-(global-extend 'core '$apply
-  (lambda (e r mr w ae m?)
-    (syntax-case e ()
-      [(_ proc arg* ...)
-       (build-$apply ae
-         (chi #'proc r mr w m?)
-         (let f ([arg* #'(arg* ...)])
-           (syntax-case arg* ()
-             [() '()]
-             [(a . arg*)
-              (cons (chi #'a r mr w m?)
-                    (f #'arg*))])))]
-      [_ (syntax-error (source-wrap e w ae))])))
-
-;;; AZIZ
-(global-extend 'core 'type-descriptor
-  (lambda (e r mr w ae m?)
-    (syntax-case e ()
-      ((_ id)
-       (id? (syntax id))
-       (let ((n (id-var-name (syntax id) w)))
-         (let ((b (lookup n r)))
-           (case (binding-type b)
-             (($rtd) 
-              (build-data ae (binding-value b)))
-             (else (syntax-error (source-wrap e w ae)))))))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-
-(global-extend 'set! 'set! '())
-
-(global-extend 'alias 'alias '())
-(global-extend 'begin 'begin '())
-
-(global-extend '$module-key '$module '())
-(global-extend '$import '$import '())
-
-(global-extend 'define 'define '())
-
-(global-extend 'define-syntax 'define-syntax '())
-
-(global-extend 'eval-when 'eval-when '())
-
-(global-extend 'meta 'meta '())
-
-(global-extend 'core 'syntax-case
-  (let ()
-    (define convert-pattern
-      ; accepts pattern & keys
-      ; returns syntax-dispatch pattern & ids
-      (lambda (pattern keys)
-        (define cvt*
-          (lambda (p* n ids)
-            (if (null? p*)
-                (values '() ids)
-                (let-values (((y ids) (cvt* (cdr p*) n ids)))
-                  (let-values (((x ids) (cvt (car p*) n ids)))
-                    (values (cons x y) ids))))))
-        (define cvt
-          (lambda (p n ids)
-            (if (id? p)
-                (if (bound-id-member? p keys)
-                    (values (vector 'free-id p) ids)
-                    (values 'any (cons (cons p n) ids)))
-                (syntax-case p ()
-                  ((x dots)
-                   (ellipsis? (syntax dots))
-                   (let-values (((p ids) (cvt (syntax x) (fx+ n 1) ids)))
-                     (values (if (eq? p 'any) 'each-any (vector 'each p))
-                             ids)))
-                  ((x dots y ... . z)
-                   (ellipsis? (syntax dots))
-                   (let-values (((z ids) (cvt (syntax z) n ids)))
-                     (let-values (((y ids) (cvt* (syntax (y ...)) n ids)))
-                       (let-values (((x ids) (cvt (syntax x) (fx+ n 1) ids)))
-                         (values `#(each+ ,x ,(reverse y) ,z) ids)))))
-                  ((x . y)
-                   (let-values (((y ids) (cvt (syntax y) n ids)))
-                     (let-values (((x ids) (cvt (syntax x) n ids)))
-                       (values (cons x y) ids))))
-                  (() (values '() ids))
-                  (#(x ...)
-                   (let-values (((p ids) (cvt (syntax (x ...)) n ids)))
-                     (values (vector 'vector p) ids)))
-                  (x (values (vector 'atom (strip p empty-wrap)) ids))))))
-        (cvt pattern 0 '())))
-
-    (define build-dispatch-call
-      (lambda (pvars exp y r mr m?)
-        (let ((ids (map car pvars)) (levels (map cdr pvars)))
-          (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
-            (build-application no-source
-              (build-primref no-source 'apply)
-              (list (build-lambda no-source new-vars
-                      (chi exp
-                         (extend-env*
-                             labels
-                             (map (lambda (var level)
-                                    (make-binding 'syntax `(,var . ,level)))
-                                  new-vars
-                                  (map cdr pvars))
-                             r)
-                         mr
-                         (make-binding-wrap ids labels empty-wrap)
-                         m?))
-                    y))))))
-
-    (define gen-clause
-      (lambda (x keys clauses r mr m? pat fender exp)
-        (let-values (((p pvars) (convert-pattern pat keys)))
-          (cond
-            ((not (distinct-bound-ids? (map car pvars)))
-             (invalid-ids-error (map car pvars) pat "pattern variable"))
-            ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
-             (syntax-error pat
-               "misplaced ellipsis in syntax-case pattern"))
-            (else
-             (let ((y (gen-var 'tmp)))
-               ; fat finger binding and references to temp variable y
-               (build-application no-source
-                 (build-lambda no-source (list y)
-                   (let-syntax ((y (identifier-syntax
-                                     (build-lexical-reference 'value no-source y))))
-                     (build-conditional no-source
-                       (syntax-case fender ()
-                         (#t y)
-                         (_ (build-conditional no-source
-                              y
-                              (build-dispatch-call pvars fender y r mr m?)
-                              (build-data no-source #f))))
-                       (build-dispatch-call pvars exp y r mr m?)
-                       (gen-syntax-case x keys clauses r mr m?))))
-                 (list (if (eq? p 'any)
-                           (build-application no-source
-                             (build-primref no-source 'list)
-                             (list (build-lexical-reference no-source 'value x)))
-                           (build-application no-source
-                             (build-primref no-source '$syntax-dispatch)
-                             (list (build-lexical-reference no-source 'value x)
-                                   (build-data no-source p))))))))))))
-
-    (define gen-syntax-case
-      (lambda (x keys clauses r mr m?)
-        (if (null? clauses)
-            (build-application no-source
-              (build-primref no-source 'syntax-error)
-              (list (build-lexical-reference 'value no-source x)))
-            (syntax-case (car clauses) ()
-              ((pat exp)
-               (if (and (id? (syntax pat))
-                        (not (bound-id-member? (syntax pat) keys))
-                        (not (ellipsis? (syntax pat))))
-                   (let ((label (gen-label))
-                         (var (gen-var (syntax pat))))
-                     (build-application no-source
-                       (build-lambda no-source (list var)
-                         (chi (syntax exp)
-                              (extend-env label (make-binding 'syntax `(,var . 0)) r)
-                              mr
-                              (make-binding-wrap (syntax (pat))
-                                (list label) empty-wrap)
-                              m?))
-                       (list (build-lexical-reference 'value no-source x))))
-                   (gen-clause x keys (cdr clauses) r mr m?
-                     (syntax pat) #t (syntax exp))))
-              ((pat fender exp)
-               (gen-clause x keys (cdr clauses) r mr m?
-                 (syntax pat) (syntax fender) (syntax exp)))
-              (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
-
-    (lambda (e r mr w ae m?)
-      (let ((e (source-wrap e w ae)))
-        (syntax-case e ()
-          ((_ val (key ...) m ...)
-           (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
-                       (syntax (key ...)))
-               (let ((x (gen-var 'tmp)))
-                 ; fat finger binding and references to temp variable x
-                 (build-application ae
-                   (build-lambda no-source (list x)
-                     (gen-syntax-case x
-                       (syntax (key ...)) (syntax (m ...))
-                       r mr m?))
-                   (list (chi (syntax val) r mr empty-wrap m?))))
-               (syntax-error e "invalid literals list in"))))))))
-
-(put-cte-hook 'module
-  (lambda (x)
-    (define proper-export?
-      (lambda (e)
-        (syntax-case e ()
-          ((id e ...)
-           (and (identifier? (syntax id))
-                (andmap proper-export? (syntax (e ...)))))
-          (id (identifier? (syntax id))))))
-    (with-syntax ((orig x))
-      (syntax-case x ()
-        ((_ (e ...) d ...)
-         (if (andmap proper-export? (syntax (e ...)))
-             (syntax 
-               (begin 
-                 ($module orig anon (e ...) d ...)
-                 ($import orig #f anon)))
-             (syntax-error x "invalid exports list in")))
-        ((_ m (e ...) d ...)
-         (identifier? (syntax m))
-         (if (andmap proper-export? (syntax (e ...)))
-             (syntax 
-               ($module orig m (e ...) d ...))
-             (syntax-error x "invalid exports list in")))))))
-
-(let ()
-  (define $module-exports
-    (lambda (m r)
-      (let ((b (r m)))
-        (case (binding-type b)
-          (($module)
-           (let* ((interface (binding-value b))
-                  (new-marks (import-mark-delta m interface)))
-             (vmap (lambda (x)
-                     (let ((id (if (pair? x) (car x) x)))
-                       (make-syntax-object
-                         (syntax-object->datum id)
-                         (let ((marks (join-marks new-marks (wrap-marks (syntax-object-wrap id))))) 
-                           (make-wrap marks
-                                     ; the anti mark should always be present at the head
-                                     ; of new-marks, but we paranoically check anyway
-                                      (if (eq? (car marks) the-anti-mark)
-                                          (cons 'shift (wrap-subst top-wrap))
-                                          (wrap-subst top-wrap)))))))
-                   (interface-exports interface))))
-          ((displaced-lexical) (displaced-lexical-error m))
-          (else (syntax-error m "unknown module"))))))
-  (define $import-help
-    (lambda (orig import-only?)
-      (lambda (r)
-        (define difference
-          (lambda (ls1 ls2)
-            (if (null? ls1)
-                ls1
-                (if (bound-id-member? (car ls1) ls2)
-                    (difference (cdr ls1) ls2)
-                    (cons (car ls1) (difference (cdr ls1) ls2))))))
-        (define prefix-add
-          (lambda (prefix-id)
-            (let ((prefix (symbol->string (syntax-object->datum prefix-id))))
-              (lambda (id)
-                (datum->syntax-object id
-                  (string->symbol
-                    (string-append prefix
-                      (symbol->string (syntax-object->datum id)))))))))
-        (define prefix-drop
-          (lambda (prefix-id)
-            (let ((prefix (symbol->string (syntax-object->datum prefix-id))))
-              (lambda (id)
-                (let ((s (symbol->string (syntax-object->datum id))))
-                  (let ((np (string-length prefix)) (ns (string-length s)))
-                    (unless (and (fx>= ns np) (string=? (substring s 0 np) prefix))
-                      (syntax-error id (string-append "missing expected prefix " prefix)))
-                    (datum->syntax-object id
-                      (string->symbol (substring s np ns)))))))))
-        (define gen-mid
-          (lambda (mid)
-           ; introduced module ids must have same marks as original
-           ; for import-only, since the barrier carries the marks of
-           ; the module id
-            (datum->syntax-object mid (gensym-hook))))
-        (define (modspec m exports?)
-          (with-syntax ((orig orig) (import-only? import-only?))
-            (syntax-case m (only-for-syntax also-for-syntax
-                            only except
-                            add-prefix drop-prefix rename alias)
-              ((only m id ...)
-               (andmap identifier? (syntax (id ...)))
-               (let-values (((mid d exports) (modspec (syntax m) #f)))
-                 (with-syntax ((d d) (tmid (gen-mid mid)))
-                   (values mid
-                           (syntax (begin ($module orig tmid (id ...) d) ($import orig import-only? tmid)))
-                           (and exports? (syntax (id ...)))))))
-              ((except m id ...)
-               (andmap identifier? (syntax (id ...)))
-               (let-values (((mid d exports) (modspec (syntax m) #t)))
-                 (with-syntax ((d d)
-                               (tmid (gen-mid mid))
-                               ((id ...) (difference exports (syntax (id ...)))))
-                   (values mid
-                           (syntax (begin ($module orig tmid (id ...) d) ($import orig import-only? tmid)))
-                           (and exports? (syntax (id ...)))))))
-              ((add-prefix m prefix-id)
-               (identifier? (syntax prefix-id))
-               (let-values (((mid d exports) (modspec (syntax m) #t)))
-                 (with-syntax ((d d)
-                               (tmid (gen-mid mid))
-                               ((old-id ...) exports)
-                               ((tmp ...) (generate-temporaries exports))
-                               ((id ...) (map (prefix-add (syntax prefix-id)) exports)))
-                   (values mid
-                           (syntax (begin ($module orig tmid ((id tmp) ...)
-                                            ($module orig tmid ((tmp old-id) ...) d (alias tmp old-id) ...)
-                                            ($import orig import-only? tmid)
-                                            (alias id tmp) ...)
-                                          ($import orig import-only? tmid)))
-                           (and exports? (syntax (id ...)))))))
-              ((drop-prefix m prefix-id)
-               (identifier? (syntax prefix-id))
-               (let-values (((mid d exports) (modspec (syntax m) #t)))
-                 (with-syntax ((d d)
-                               (tmid (gen-mid mid))
-                               ((old-id ...) exports)
-                               ((tmp ...) (generate-temporaries exports))
-                               ((id ...) (map (prefix-drop (syntax prefix-id)) exports)))
-                   (values mid
-                           (syntax (begin ($module orig tmid ((id tmp) ...)
-                                            ($module orig tmid ((tmp old-id) ...) d (alias tmp old-id) ...)
-                                            ($import orig import-only? tmid)
-                                            (alias id tmp) ...)
-                                          ($import orig import-only? tmid)))
-                           (and exports? (syntax (id ...)))))))
-              ((rename m (new-id old-id) ...)
-               (and (andmap identifier? (syntax (new-id ...)))
-                    (andmap identifier? (syntax (old-id ...))))
-               (let-values (((mid d exports) (modspec (syntax m) #t)))
-                 (with-syntax ((d d)
-                               (tmid (gen-mid mid))
-                               ((tmp ...) (generate-temporaries (syntax (old-id ...))))
-                               ((other-id ...) (difference exports (syntax (old-id ...)))))
-                   (values mid
-                           (syntax (begin ($module orig tmid ((new-id tmp) ... other-id ...)
-                                            ($module orig tmid (other-id ... (tmp old-id) ...) d (alias tmp old-id) ...)
-                                            ($import orig import-only? tmid)
-                                            (alias new-id tmp) ...)
-                                          ($import orig import-only? tmid)))
-                           (and exports? (syntax (new-id ... other-id ...)))))))
-              ((alias m (new-id old-id) ...)
-               (and (andmap identifier? (syntax (new-id ...)))
-                    (andmap identifier? (syntax (old-id ...))))
-               (let-values (((mid d exports) (modspec (syntax m) #t)))
-                 (with-syntax ((d d)
-                               (tmid (gen-mid mid))
-                               ((other-id ...) exports))
-                   (values mid
-                           (syntax (begin ($module orig tmid ((new-id old-id) ... other-id ...) d (alias new-id old-id) ...)
-                                          ($import orig import-only? tmid)))
-                           (and exports? (syntax (new-id ... other-id ...)))))))
-             ; base cases
-              (mid
-               (identifier? (syntax mid))
-               (values (syntax mid)
-                       (syntax ($import orig import-only? mid))
-                       (and exports? ($module-exports (syntax mid) r))))
-              ((mid)
-               (identifier? (syntax mid))
-               (values (syntax mid)
-                       (syntax ($import orig import-only? mid))
-                       (and exports? ($module-exports (syntax mid) r))))
-            (_ (syntax-error m "invalid module specifier")))))
-        (define modspec*
-          (lambda (m)
-            (let-values (((mid d exports) (modspec m #f))) d)))
-        (syntax-case orig ()
-          ((_ m ...)
-           (with-syntax (((d ...) (map modspec* (syntax (m ...)))))
-             (syntax (begin d ...))))))))
-
-  (put-cte-hook 'import
-    (lambda (orig)
-      ($import-help orig #f)))
-  
-  (put-cte-hook 'import-only
-    (lambda (orig)
-      ($import-help orig #t)))
-)
-
-;;; To support eval-when, we maintain two mode sets:
-;;;
-;;; ctem (compile-time-expression mode)
-;;;   determines whether/when to evaluate compile-time expressions such
-;;;   as macro definitions, module definitions, and compile-time
-;;;   registration of variable definitions
-;;;
-;;; rtem (run-time-expression mode)
-;;;   determines whether/when to evaluate run-time expressions such
-;;;   as the actual assignment performed by a variable definition or
-;;;   arbitrary top-level expressions
-
-;;; Possible modes in the mode set are:
-;;;
-;;; L (load): evaluate at load time.  implies V for compile-time
-;;;     expressions and R for run-time expressions.
-;;;
-;;; C (compile): evaluate at compile (file) time
-;;;
-;;; E (eval): evaluate at evaluation (compile or interpret) time
-;;;
-;;; V (visit): evaluate at visit time
-;;;
-;;; R (revisit): evaluate at revisit time
-
-;;; The mode set for the body of an eval-when is determined by
-;;; translating each mode in the old mode set based on the situations
-;;; present in the eval-when form and combining these into a set,
-;;; using the following table.  See also update-mode-set.
-
-;;;      load  compile  visit  revisit  eval
-;;;
-;;; L     L      C        V       R      -
-;;;
-;;; C     -      -        -       -      C
-;;;
-;;; V     V      C        V       -      -
-;;;
-;;; R     R      C        -       R      -
-;;;
-;;; E     -      -        -       -      E
-
-;;; When we complete the expansion of a compile or run-time expression,
-;;; the current ctem or rtem determines how the expression will be
-;;; treated.  See ct-eval/residualize and rt-eval/residualize.
-
-;;; Initial mode sets
-;;;
-;;; when compiling a file:
-;;;
-;;;     initial ctem: (L C)
-;;;
-;;;     initial rtem: (L)
-;;;
-;;; when not compiling a file:
-;;;
-;;;     initial ctem: (E)
-;;;
-;;;     initial rtem: (E)
-;;;
-;;;
-;;; This means that top-level syntactic definitions are evaluated
-;;; immediately after they are expanded, and the expanded definitions
-;;; are also residualized into the object file if we are compiling
-;;; a file.
-
-
-
-;;; AZIZ
-;;; (set! sc-expand
-;;;   (let ((ctem '(E)) (rtem '(E)))
-;;;     (lambda (x)
-;;;       (let ((env (interaction-environment)))
-;;;         (if (and (pair? x) (equal? (car x) noexpand))
-;;;             (cadr x)
-;;;             (chi-top* x null-env
-;;;               (env-wrap env)
-;;;               ctem rtem #f
-;;;               (env-top-ribcage env)))))))
-;;; 
-
-(primitive-set! 'expand-mode
-  (make-parameter
-    'eval
-    (lambda (x)
-      (unless (memq x '(eval compile bootstrap))
-        (error 'expand-mode "~s is not a valid mode" x))
-      x)))
-
-(primitive-set! 'sc-expand
-  (let ()
-    (define get-modes
-      (lambda ()
-        (case (expand-mode)
-          [(eval)      (values '(E)   '(E))]
-          [(compile)   (values '(L C) '(L))]
-          [(bootstrap) (values '(L)   '(L))])))
-    (lambda (x)
-      (let ((env (interaction-environment)))
-        (let-values ([(ctem rtem) (get-modes)])
-          (if (and (pair? x) (equal? (car x) noexpand))
-              (cadr x)
-              (chi-top* x null-env
-                (env-wrap env)
-                ctem rtem #f
-                (env-top-ribcage env))))))))
-
-(primitive-set! 'current-expand
-  (make-parameter
-    sc-expand
-    (lambda (x)
-      (unless (procedure? x)
-        (error 'current-expand "~s is not a procedure" x))
-      x)))
-
-(primitive-set! 'expand
-  (lambda (x)
-    ((current-expand) x)))
-
-(primitive-set! '$make-environment
-  (lambda (token mutable?)
-    (let ((top-ribcage (make-top-ribcage token mutable?)))
-      (make-env
-        top-ribcage
-        (make-wrap
-          (wrap-marks top-wrap)
-          (cons top-ribcage (wrap-subst top-wrap)))))))
-
-(primitive-set! 'environment?
-  (lambda (x)
-    (env? x)))
-
-
-;;; AZIZ
-;;; (primitive-set! 'interaction-environment
-;;;   (let ((e ($make-environment '*top* #t)))
-;;;     (lambda () e)))
-
-(primitive-set! 'interaction-environment
-  (make-parameter
-    ($make-environment '*top* #t)
-    (lambda (x)
-      (if (environment? x)
-          x
-          (error 'interaction-environment "~s is not an environment" x)))))
-
-
-(primitive-set! 'identifier?
-  (lambda (x)
-    (nonsymbol-id? x)))
-
-(primitive-set! 'datum->syntax-object
-  (lambda (id datum)
-    (arg-check nonsymbol-id? id 'datum->syntax-object)
-    (make-syntax-object
-      datum
-      (syntax-object-wrap id))))
-
-(primitive-set! 'syntax->list
-  (lambda (orig-ls)
-    (let f ((ls orig-ls))
-      (syntax-case ls ()
-        (() '())
-        ((x . r) (cons #'x (f #'r)))
-        (_ (error 'syntax->list "invalid argument ~s" orig-ls))))))
-
-(primitive-set! 'syntax->vector
-  (lambda (v)
-    (syntax-case v ()
-      (#(x ...) (apply vector (syntax->list #'(x ...))))
-      (_ (error 'syntax->vector "invalid argument ~s" v)))))
-
-(primitive-set! 'syntax-object->datum
-  ; accepts any object, since syntax objects may consist partially
-  ; or entirely of unwrapped, nonsymbolic data
-  (lambda (x)
-    (strip x empty-wrap)))
-
-(primitive-set! 'generate-temporaries
-  (lambda (ls)
-    (arg-check list? ls 'generate-temporaries)
-    (map (lambda (x) (wrap (gensym-hook) top-wrap)) ls)))
-
-(primitive-set! 'free-identifier=?
-   (lambda (x y)
-      (arg-check nonsymbol-id? x 'free-identifier=?)
-      (arg-check nonsymbol-id? y 'free-identifier=?)
-      (free-id=? x y)))
-
-(primitive-set! 'bound-identifier=?
-   (lambda (x y)
-      (arg-check nonsymbol-id? x 'bound-identifier=?)
-      (arg-check nonsymbol-id? y 'bound-identifier=?)
-      (bound-id=? x y)))
-
-(primitive-set! 'literal-identifier=?
-  (lambda (x y)
-    (arg-check nonsymbol-id? x 'literal-identifier=?)
-    (arg-check nonsymbol-id? y 'literal-identifier=?)
-    (literal-id=? x y)))
-
-(primitive-set! 'syntax-error
-  (lambda (object . messages)
-    (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
-    (let ((message (if (null? messages)
-                       "invalid syntax"
-                       (apply string-append messages))))
-      (error-hook #f message (strip object empty-wrap)))))
-
-;;; syntax-dispatch expects an expression and a pattern.  If the expression
-;;; matches the pattern a list of the matching expressions for each
-;;; "any" is returned.  Otherwise, #f is returned.  (This use of #f will
-;;; not work on r4rs implementations that violate the ieee requirement
-;;; that #f and () be distinct.)
-
-;;; The expression is matched with the pattern as follows:
-
-;;; p in pattern:                        matches:
-;;;   ()                                 empty list
-;;;   any                                anything
-;;;   (p1 . p2)                          pair (list)
-;;;   #(free-id <key>)                   <key> with literal-identifier=?
-;;;   each-any                           any proper list
-;;;   #(each p)                          (p*)
-;;;   #(each+ p1 (p2_1 ...p2_n) p3)      (p1* (p2_n ... p2_1) . p3)
-;;;   #(vector p)                        (list->vector p)
-;;;   #(atom <object>)                   <object> with "equal?"
-
-;;; Vector cops out to pair under assumption that vectors are rare.  If
-;;; not, should convert to:
-;;;   #(vector p)                        #(p*)
-
-(let ()
-
-(define match-each
-  (lambda (e p w)
-    (cond
-      ((annotation? e)
-       (match-each (annotation-expression e) p w))
-      ((pair? e)
-       (let ((first (match (car e) p w '())))
-         (and first
-              (let ((rest (match-each (cdr e) p w)))
-                 (and rest (cons first rest))))))
-      ((null? e) '())
-      ((syntax-object? e)
-       (match-each (syntax-object-expression e)
-                   p
-                   (join-wraps w (syntax-object-wrap e))))
-      (else #f))))
-
-(define match-each+
-  (lambda (e x-pat y-pat z-pat w r)
-    (let f ((e e) (w w))
-      (cond
-        ((pair? e)
-         (let-values (((xr* y-pat r) (f (cdr e) w)))
-           (if r
-               (if (null? y-pat)
-                   (let ((xr (match (car e) x-pat w '())))
-                     (if xr
-                         (values (cons xr xr*) y-pat r)
-                         (values #f #f #f)))
-                   (values '() (cdr y-pat) (match (car e) (car y-pat) w r)))
-               (values #f #f #f))))
-        ((annotation? e) (f (annotation-expression e) w))
-        ((syntax-object? e) (f (syntax-object-expression e)
-                               (join-wraps w (syntax-object-wrap e))))
-        (else (values '() y-pat (match e z-pat w r)))))))
-
-(define match-each-any
-  (lambda (e w)
-    (cond
-      ((annotation? e)
-       (match-each-any (annotation-expression e) w))
-      ((pair? e)
-       (let ((l (match-each-any (cdr e) w)))
-         (and l (cons (wrap (car e) w) l))))
-      ((null? e) '())
-      ((syntax-object? e)
-       (match-each-any (syntax-object-expression e)
-                       (join-wraps w (syntax-object-wrap e))))
-      (else #f))))
-
-(define match-empty
-  (lambda (p r)
-    (cond
-      ((null? p) r)
-      ((eq? p 'any) (cons '() r))
-      ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
-      ((eq? p 'each-any) (cons '() r))
-      (else
-       (case (vector-ref p 0)
-         ((each) (match-empty (vector-ref p 1) r))
-         ((each+) (match-empty (vector-ref p 1)
-                    (match-empty (reverse (vector-ref p 2))
-                      (match-empty (vector-ref p 3) r))))
-         ((free-id atom) r)
-         ((vector) (match-empty (vector-ref p 1) r)))))))
-
-(define combine
-  (lambda (r* r)
-    (if (null? (car r*))
-        r
-        (cons (map car r*) (combine (map cdr r*) r)))))
-
-(define match*
-  (lambda (e p w r)
-    (cond
-      ((null? p) (and (null? e) r))
-      ((pair? p)
-       (and (pair? e) (match (car e) (car p) w
-                        (match (cdr e) (cdr p) w r))))
-      ((eq? p 'each-any)
-       (let ((l (match-each-any e w))) (and l (cons l r))))
-      (else
-       (case (vector-ref p 0)
-         ((each)
-          (if (null? e)
-              (match-empty (vector-ref p 1) r)
-              (let ((r* (match-each e (vector-ref p 1) w)))
-                (and r* (combine r* r)))))
-         ((free-id) (and (id? e) (literal-id=? (wrap e w) (vector-ref p 1)) r))
-         ((each+)
-          (let-values (((xr* y-pat r)
-                        (match-each+ e (vector-ref p 1) (vector-ref p 2)
-                          (vector-ref p 3) w r)))
-            (and r (null? y-pat)
-              (if (null? xr*)
-                  (match-empty (vector-ref p 1) r)
-                  (combine xr* r)))))
-         ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
-         ((vector)
-          (and (vector? e)
-               (match (vector->list e) (vector-ref p 1) w r))))))))
-
-(define match
-  (lambda (e p w r)
-    (cond
-      ((not r) #f)
-      ((eq? p 'any) (cons (wrap e w) r))
-      ((syntax-object? e)
-       (match*
-         (unannotate (syntax-object-expression e))
-         p
-         (join-wraps w (syntax-object-wrap e))
-         r))
-      (else (match* (unannotate e) p w r)))))
-
-(primitive-set! '$syntax-dispatch
-  (lambda (e p)
-    (cond
-      ((eq? p 'any) (list e))
-      ((syntax-object? e)
-       (match* (unannotate (syntax-object-expression e))
-         p (syntax-object-wrap e) '()))
-      (else (match* (unannotate e) p empty-wrap '())))))
-))
-
-
-(define-syntax with-syntax
-   (lambda (x)
-      (syntax-case x ()
-         ((_ () e1 e2 ...)
-          (syntax (begin e1 e2 ...)))
-         ((_ ((out in)) e1 e2 ...)
-          (syntax (syntax-case in () (out (begin e1 e2 ...)))))
-         ((_ ((out in) ...) e1 e2 ...)
-          (syntax (syntax-case (list in ...) ()
-                     ((out ...) (begin e1 e2 ...))))))))
-
-(define-syntax with-implicit
-  (syntax-rules ()
-    ((_ (tid id ...) e1 e2 ...)
-     (andmap identifier? (syntax (tid id ...)))
-     (begin
-       (unless (identifier? (syntax tid))
-         (syntax-error (syntax tid) "non-identifier with-implicit template"))
-       (with-syntax ((id (datum->syntax-object (syntax tid) 'id)) ...)
-         e1 e2 ...)))))
-
-(define-syntax datum
-  (syntax-rules ()
-    ((_ x) (syntax-object->datum (syntax x)))))
-
-(define-syntax syntax-rules
-  (lambda (x)
-    (define clause
-      (lambda (y)
-        (syntax-case y ()
-          (((keyword . pattern) template)
-           (syntax ((dummy . pattern) (syntax template))))
-          (((keyword . pattern) fender template)
-           (syntax ((dummy . pattern) fender (syntax template))))
-          (_ (syntax-error x)))))
-    (syntax-case x ()
-      ((_ (k ...) cl ...)
-       (andmap identifier? (syntax (k ...)))
-       (with-syntax (((cl ...) (map clause (syntax (cl ...)))))
-         (syntax (lambda (x) (syntax-case x (k ...) cl ...))))))))
-
-(define-syntax or
-   (lambda (x)
-      (syntax-case x ()
-         ((_) (syntax #f))
-         ((_ e) (syntax e))
-         ((_ e1 e2 e3 ...)
-          (syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))
-
-(define-syntax and
-   (lambda (x)
-      (syntax-case x ()
-         ((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f)))
-         ((_ e) (syntax e))
-         ((_) (syntax #t)))))
-
-(define-syntax let
-   (lambda (x)
-      (syntax-case x ()
-         ((_ ((x v) ...) e1 e2 ...)
-          (andmap identifier? (syntax (x ...)))
-          (syntax ((lambda (x ...) e1 e2 ...) v ...)))
-         ((_ f ((x v) ...) e1 e2 ...)
-          (andmap identifier? (syntax (f x ...)))
-          (syntax ((letrec ((f (lambda (x ...) e1 e2 ...))) f)
-                    v ...))))))
-
-(define-syntax let*
-  (lambda (x)
-    (syntax-case x ()
-      ((let* ((x v) ...) e1 e2 ...)
-       (andmap identifier? (syntax (x ...)))
-       (let f ((bindings (syntax ((x v)  ...))))
-         (if (null? bindings)
-             (syntax (let () e1 e2 ...))
-             (with-syntax ((body (f (cdr bindings)))
-                           (binding (car bindings)))
-               (syntax (let (binding) body)))))))))
-
-(define-syntax cond
-  (lambda (x)
-    (syntax-case x ()
-      ((_ m1 m2 ...)
-       (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
-         (if (null? clauses)
-             (syntax-case clause (else =>)
-               ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
-               ((e0) (syntax (let ((t e0)) (if t t))))
-               ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t)))))
-               ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...))))
-               (_ (syntax-error x)))
-             (with-syntax ((rest (f (car clauses) (cdr clauses))))
-               (syntax-case clause (else =>)
-                 ((e0) (syntax (let ((t e0)) (if t t rest))))
-                 ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t) rest))))
-                 ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...) rest)))
-                 (_ (syntax-error x))))))))))
-
-(define-syntax do
-   (lambda (orig-x)
-      (syntax-case orig-x ()
-         ((_ ((var init . step) ...) (e0 e1 ...) c ...)
-          (with-syntax (((step ...)
-                         (map (lambda (v s)
-                                 (syntax-case s ()
-                                    (() v)
-                                    ((e) (syntax e))
-                                    (_ (syntax-error orig-x))))
-                              (syntax (var ...))
-                              (syntax (step ...)))))
-             (syntax-case (syntax (e1 ...)) ()
-                (() (syntax (let do ((var init) ...)
-                               (if (not e0)
-                                   (begin c ... (do step ...))))))
-                ((e1 e2 ...)
-                 (syntax (let do ((var init) ...)
-                            (if e0
-                                (begin e1 e2 ...)
-                                (begin c ... (do step ...))))))))))))
-
-(define-syntax quasiquote
-   (letrec
-     ; these are here because syntax-case uses literal-identifier=?,
-     ; and we want the more precise free-identifier=?
-      ((isquote? (lambda (x)
-                   (and (identifier? x)
-                        (free-identifier=? x (syntax quote)))))
-       (islist? (lambda (x)
-                  (and (identifier? x)
-                       (free-identifier=? x (syntax list)))))
-       (iscons? (lambda (x)
-                  (and (identifier? x)
-                       (free-identifier=? x (syntax cons)))))
-       (quote-nil? (lambda (x)
-                    (syntax-case x ()
-                      ((quote? ()) (isquote? (syntax quote?)))
-                      (_ #f))))
-       (quasilist*
-        (lambda (x y)
-          (let f ((x x))
-            (if (null? x)
-                y
-                (quasicons (car x) (f (cdr x)))))))
-       (quasicons
-        (lambda (x y)
-          (with-syntax ((x x) (y y))
-            (syntax-case (syntax y) ()
-              ((quote? dy)
-               (isquote? (syntax quote?))
-               (syntax-case (syntax x) ()
-                 ((quote? dx)
-                  (isquote? (syntax quote?))
-                  (syntax (quote (dx . dy))))
-                 (_ (if (null? (syntax dy))
-                        (syntax (list x))
-                        (syntax (cons x y))))))
-              ((listp . stuff)
-               (islist? (syntax listp))
-               (syntax (list x . stuff)))
-              (else (syntax (cons x y)))))))
-       (quasiappend
-        (lambda (x y)
-          (let ((ls (let f ((x x))
-                      (if (null? x)
-                          (if (quote-nil? y)
-                              '()
-                              (list y))
-                          (if (quote-nil? (car x))
-                              (f (cdr x))
-                              (cons (car x) (f (cdr x))))))))
-            (cond
-              ((null? ls) (syntax (quote ())))
-              ((null? (cdr ls)) (car ls))
-              (else (with-syntax (((p ...) ls))
-                      (syntax (append p ...))))))))
-       (quasivector
-        (lambda (x)
-          (with-syntax ((pat-x x))
-            (syntax-case (syntax pat-x) ()
-              ((quote? (x ...))
-               (isquote? (syntax quote?))
-               (syntax (quote #(x ...))))
-              (_ (let f ((x x) (k (lambda (ls) `(,(syntax vector) ,@ls))))
-                   (syntax-case x ()
-                     ((quote? (x ...))
-                      (isquote? (syntax quote?))
-                      (k (syntax ((quote x) ...))))
-                     ((listp x ...)
-                      (islist? (syntax listp))
-                      (k (syntax (x ...))))
-                     ((cons? x y)
-                      (iscons? (syntax cons?))
-                      (f (syntax y) (lambda (ls) (k (cons (syntax x) ls)))))
-                     (else
-                      (syntax (list->vector pat-x))))))))))
-       (vquasi
-        (lambda (p lev)
-           (syntax-case p ()
-              ((p . q)
-               (syntax-case #'p (unquote unquote-splicing)
-                 ((unquote p ...)
-                  (if (fx= lev 0)
-                      (quasilist* (syntax (p ...)) (vquasi (syntax q) lev))
-                      (quasicons (quasicons (syntax (quote unquote))
-                                            (quasi (syntax (p ...)) (fx- lev 1)))
-                                 (vquasi (syntax q) lev))))
-                 ((unquote-splicing p ...)
-                  (if (fx= lev 0)
-                      (quasiappend (syntax (p ...)) (vquasi (syntax q) lev))
-                      (quasicons (quasicons (syntax (quote unquote-splicing))
-                                            (quasi (syntax (p ...)) (fx- lev 1)))
-                                 (vquasi (syntax q) lev))))
-                 (p (quasicons (quasi (syntax p) lev) (vquasi (syntax q) lev)))))
-              (() (syntax (quote ()))))))
-       (quasi
-        (lambda (p lev)
-           (syntax-case p (unquote unquote-splicing quasiquote)
-              ((unquote p)
-               (if (fx= lev 0)
-                   (syntax p)
-                   (quasicons (syntax (quote unquote))
-                              (quasi (syntax (p)) (fx- lev 1)))))
-              (((unquote p ...) . q)
-               (if (fx= lev 0)
-                   (quasilist* (syntax (p ...)) (quasi (syntax q) lev))
-                   (quasicons (quasicons (syntax (quote unquote))
-                                         (quasi (syntax (p ...)) (fx- lev 1)))
-                              (quasi (syntax q) lev))))
-              (((unquote-splicing p ...) . q)
-               (if (fx= lev 0)
-                   (quasiappend (syntax (p ...)) (quasi (syntax q) lev))
-                   (quasicons (quasicons (syntax (quote unquote-splicing))
-                                         (quasi (syntax (p ...)) (fx- lev 1)))
-                              (quasi (syntax q) lev))))
-              ((quasiquote p)
-               (quasicons (syntax (quote quasiquote))
-                          (quasi (syntax (p)) (fx+ lev 1))))
-              ((p . q)
-               (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
-              (#(x ...) (quasivector (vquasi (syntax (x ...)) lev)))
-              (p (syntax (quote p)))))))
-    (lambda (x)
-       (syntax-case x ()
-          ((_ e) (quasi (syntax e) 0))))))
-
-(define-syntax unquote
-  (lambda (x)
-    (syntax-error x "misplaced")))
-
-(define-syntax unquote-splicing
-  (lambda (x)
-    (syntax-error x "misplaced")))
-
-(define-syntax quasisyntax
-  (lambda (x)
-    (define (qs q n b* k)
-      (syntax-case q (quasisyntax unsyntax unsyntax-splicing)
-        ((quasisyntax . d)
-         (qs #'d (fx+ n 1) b*
-           (lambda (b* dnew)
-             (k b*
-                (if (eq? dnew #'d)
-                    q
-                    (with-syntax ((d dnew)) #'(quasisyntax . d)))))))
-        ((unsyntax . d)
-         (not (fx= n 0))
-         (qs #'d (fx- n 1) b*
-           (lambda (b* dnew)
-             (k b*
-                (if (eq? dnew #'d)
-                    q
-                    (with-syntax ((d dnew)) #'(unsyntax . d)))))))
-        ((unsyntax-splicing . d)
-         (not (fx= n 0))
-         (qs #'d (fx- n 1) b*
-           (lambda (b* dnew)
-             (k b*
-                (if (eq? dnew #'d)
-                    q
-                    (with-syntax ((d dnew)) #'(unsyntax-splicing . d)))))))
-        ((unsyntax q)
-         (fx= n 0)
-         (with-syntax (((t) (generate-temporaries #'(q))))
-           (k (cons #'(t q) b*) #'t)))
-        (((unsyntax q ...) . d)
-         (fx= n 0)
-         (qs #'d n b*
-           (lambda (b* dnew)
-             (with-syntax (((t ...) (generate-temporaries #'(q ...))))
-               (k (append #'((t q) ...) b*)
-                  (with-syntax ((d dnew)) #'(t ... . d)))))))
-        (((unsyntax-splicing q ...) . d)
-         (fx= n 0)
-         (qs #'d n b*
-           (lambda (b* dnew)
-             (with-syntax (((t ...) (generate-temporaries #'(q ...))))
-               (k (append #'(((t (... ...)) q) ...) b*)
-                  (with-syntax ((((m ...) ...) #'((t (... ...)) ...)))
-                    (with-syntax ((d dnew)) #'(m ... ... . d))))))))
-        ((a . d)
-         (qs #'a n b*
-           (lambda (b* anew)
-             (qs #'d n b*
-               (lambda (b* dnew)
-                 (k b*
-                    (if (and (eq? anew #'a) (eq? dnew #'d))
-                        q
-                        (with-syntax ((a anew) (d dnew)) #'(a . d)))))))))
-        (#(x ...)
-         (vqs #'(x ...) n b*
-           (lambda (b* xnew*)
-             (k b*
-                (if (let same? ((x* #'(x ...)) (xnew* xnew*))
-                      (if (null? x*)
-                          (null? xnew*)
-                          (and (not (null? xnew*))
-                               (eq? (car x*) (car xnew*))
-                               (same? (cdr x*) (cdr xnew*)))))
-                    q
-                    (with-syntax (((x ...) xnew*)) #'#(x ...)))))))
-        (_ (k b* q))))
-    (define (vqs x* n b* k)
-      (if (null? x*)
-          (k b* '())
-          (vqs (cdr x*) n b*
-            (lambda (b* xnew*)
-              (syntax-case (car x*) (unsyntax unsyntax-splicing)
-                ((unsyntax q ...)
-                 (fx= n 0)
-                 (with-syntax (((t ...) (generate-temporaries #'(q ...))))
-                   (k (append #'((t q) ...) b*)
-                      (append #'(t ...) xnew*))))
-                ((unsyntax-splicing q ...)
-                 (fx= n 0)
-                 (with-syntax (((t ...) (generate-temporaries #'(q ...))))
-                   (k (append #'(((t (... ...)) q) ...) b*)
-                      (with-syntax ((((m ...) ...) #'((t (... ...)) ...)))
-                        (append #'(m ... ...) xnew*)))))
-                (_ (qs (car x*) n b*
-                     (lambda (b* xnew)
-                       (k b* (cons xnew xnew*))))))))))
-    (syntax-case x ()
-      ((_ x)
-       (qs #'x 0 '()
-         (lambda (b* xnew)
-           (if (eq? xnew #'x)
-               #'(syntax x)
-               (with-syntax (((b ...) b*) (x xnew))
-                 #'(with-syntax (b ...) (syntax x))))))))))
-
-(define-syntax unsyntax
-  (lambda (x)
-    (syntax-error x "misplaced")))
-
-(define-syntax unsyntax-splicing
-  (lambda (x)
-    (syntax-error x "misplaced")))
-
-(define-syntax include
-  (lambda (x)
-    (define read-file
-      (lambda (fn k)
-        (let ((p (open-input-file fn)))
-          (let f ()
-            (let ((x (read p)))
-              (if (eof-object? x)
-                  (begin (close-input-port p) '())
-                  (cons (datum->syntax-object k x) (f))))))))
-    (syntax-case x ()
-      ((k filename)
-       (let ((fn (syntax-object->datum (syntax filename))))
-         (with-syntax (((exp ...) (read-file fn (syntax k))))
-           (syntax (begin exp ...))))))))
-
-(define-syntax case
-  (lambda (x)
-    (syntax-case x ()
-      ((_ e m1 m2 ...)
-       (with-syntax
-         ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
-                  (if (null? clauses)
-                      (syntax-case clause (else)
-                        ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
-                        (((k ...) e1 e2 ...)
-                         (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
-                        (_ (syntax-error x)))
-                      (with-syntax ((rest (f (car clauses) (cdr clauses))))
-                        (syntax-case clause (else)
-                          (((k ...) e1 e2 ...)
-                           (syntax (if (memv t '(k ...))
-                                       (begin e1 e2 ...)
-                                       rest)))
-                          (_ (syntax-error x))))))))
-         (syntax (let ((t e)) body)))))))
-
-(define-syntax identifier-syntax
-  (syntax-rules (set!)
-    ((_ e)
-     (lambda (x)
-       (syntax-case x ()
-         (id (identifier? (syntax id)) (syntax e))
-         ((_ x (... ...)) (syntax (e x (... ...)))))))
-    ((_ (id exp1) ((set! var val) exp2))
-     (and (identifier? (syntax id)) (identifier? (syntax var)))
-     (cons 'macro!
-       (lambda (x)
-         (syntax-case x (set!)
-           ((set! var val) (syntax exp2))
-           ((id x (... ...)) (syntax (exp1 x (... ...))))
-           (id (identifier? (syntax id)) (syntax exp1))))))))
-
-(define-syntax parameterize
-  (lambda (x)
-    (syntax-case x ()
-      [(_ () b b* ...) #'(let () b b* ...)]
-      [(_ ([olhs* orhs*] ...) b b* ...)
-       (with-syntax ([(lhs* ...) (generate-temporaries #'(olhs* ...))]
-                     [(rhs* ...) (generate-temporaries #'(orhs* ...))])
-        #'(let ([lhs* olhs*] ...
-                [rhs* orhs*] ...)
-            (let ([swap
-                   (lambda ()
-                     (let ([t (lhs*)])
-                       (lhs* rhs*)
-                       (set! rhs* t)) ...)])
-              (dynamic-wind
-                swap
-                (lambda () b b* ...)
-                swap))))])))
-
-(define-syntax when
-  (syntax-rules ()
-    [(_ test b b* ...)
-     (if test 
-         (begin b b* ...)
-         (void))]))
-
-(define-syntax unless
-  (syntax-rules ()
-    [(_ test b b* ...)
-     (if test 
-         (void)
-         (begin b b* ...))]))
-
-(define-syntax let-values
-  (lambda (x)
-    (define (bindem n** v**)
-      (syntax-case n** ()
-        [() #'()]
-        [((n* ...) . n**)
-         (syntax-case v** ()
-          [((v* ...) . v**)
-           (with-syntax ([rest (bindem #'n** #'v**)])
-             #'([n* v*] ... . rest))])]))
-    (syntax-case x ()
-      [(_ ([(name** ...) v*] ...) b b* ...)
-       (let ([n**
-              (let f ([n** #'((name** ...) ...)])
-                (syntax-case n** ()
-                  [() #'()]
-                  [(n* . n**)
-                   (with-syntax ([n* (generate-temporaries #'n*)]
-                                 [n** (f #'n**)])
-                     #'(n* . n**))]))])
-         (let f ([t** n**] [v* #'(v* ...)])
-           (syntax-case t** ()
-             [((t* ...) . t**) 
-              (syntax-case v* ()
-                [(v . v*)
-                 (with-syntax ([body (f #'t** #'v*)])
-                   #'(call-with-values
-                       (lambda () v)
-                       (lambda (t* ...) body)))])]
-             [() 
-              (with-syntax ([bind* (bindem #'((name** ...) ...) n**)])
-                #'(let bind* b b* ...))])))])))
-
-
-
-(define-syntax define-record
-  (lambda (x)
-    (syntax-case x ()
-      [(_ name (field* ...)) 
-       (let* ([namestr (symbol->string (syntax-object->datum #'name))]
-              [fields (syntax-object->datum #'(field* ...))]
-              [fieldstr* (map symbol->string fields)]
-              [rtd (make-record-type namestr fields)])
-         (with-syntax ([constr 
-                        (datum->syntax-object #'name
-                          (string->symbol
-                            (string-append "make-" namestr)))]
-                       [pred 
-                        (datum->syntax-object #'name
-                          (string->symbol
-                            (string-append namestr "?")))]
-                       [(i ...)
-                        (datum->syntax-object #'name
-                          (let f ([i 0] [f* fieldstr*])
-                            (cond
-                              [(null? f*) '()]
-                              [else (cons i (f (fxadd1 i) (cdr f*)))])))]
-                       [(getters ...)
-                        (datum->syntax-object #'name
-                          (map (lambda (x)
-                                 (string->symbol 
-                                   (string-append namestr "-" x)))
-                               fieldstr*))]
-                       [(setters ...)
-                        (datum->syntax-object #'name
-                          (map (lambda (x) 
-                                 (string->symbol
-                                   (string-append "set-" namestr "-" x "!")))
-                               fieldstr*))]
-                       [rtd rtd])
-            #'(begin
-                (define-syntax name (cons '$rtd 'rtd))
-                (define constr 
-                  (lambda (field* ...)
-                    ($record 'rtd field* ...)))
-                (define pred
-                  (lambda (x) ($record/rtd? x 'rtd)))
-                (define getters 
-                  (lambda (x)
-                    (if ($record/rtd? x 'rtd) 
-                        ($record-ref x i)
-                        (error 'getters
-                               "~s is not a record of type ~s" x 'rtd)))) ...
-                (define setters 
-                  (lambda (x v)
-                    (if ($record/rtd? x 'rtd) 
-                        ($record-set! x i v)
-                        (error 'setters
-                               "~s is not a record of type ~s" x 'rtd)))) ...
-                )))])))
-
-
-(define-syntax $define-record-syntax
-  (lambda (x)
-    (syntax-case x ()
-      [(_ name (field* ...)) 
-       (let* ([namestr (symbol->string (syntax-object->datum #'name))]
-              [fields (syntax-object->datum #'(field* ...))]
-              [fieldstr* (map symbol->string fields)]
-              [rtd (make-record-type namestr fields)])
-         (with-syntax ([constr 
-                        (datum->syntax-object #'name
-                          (string->symbol
-                            (string-append "make-" namestr)))]
-                       [pred 
-                        (datum->syntax-object #'name
-                          (string->symbol
-                            (string-append namestr "?")))]
-                       [(i ...)
-                        (datum->syntax-object #'name
-                          (let f ([i 0] [f* fieldstr*])
-                            (cond
-                              [(null? f*) '()]
-                              [else (cons i (f (fxadd1 i) (cdr f*)))])))]
-                       [(getters ...)
-                        (datum->syntax-object #'name
-                          (map (lambda (x)
-                                 (string->symbol 
-                                   (string-append namestr "-" x)))
-                               fieldstr*))]
-                       [(setters ...)
-                        (datum->syntax-object #'name
-                          (map (lambda (x) 
-                                 (string->symbol
-                                   (string-append "set-" namestr "-" x "!")))
-                               fieldstr*))]
-                       [rtd rtd])
-            #'(begin
-                (define-syntax name (cons '$rtd 'rtd))
-                (define-syntax constr
-                  (syntax-rules ()
-                    [(_ field* ...) ($record 'rtd field* ...)]))
-                (define-syntax pred
-                  (syntax-rules ()
-                    [(_ x) ($record/rtd? x 'rtd)]))
-                (define-syntax getters 
-                  (syntax-rules ()
-                    [(_ x) ($record-ref x i)])) ...
-                (define-syntax setters 
-                  (syntax-rules ()
-                    [(_ x v) ($record-set! x i v)])) ...
-                )))])))
-
-(define-syntax trace
-  (lambda (x)
-    (syntax-case x ()
-      [(_ id) (identifier? #'id)
-       #'(trace-symbol! 'id)])))
-
-
-(define-syntax untrace
-  (lambda (x)
-    (syntax-case x ()
-      [(_ id) (identifier? #'id)
-       #'(untrace-symbol! 'id)])))
-
-
-(define-syntax trace-lambda
-  (lambda (x)
-    (syntax-case x ()
-      [(_ name args body body* ...)
-       #'(make-traced-procedure 'name (lambda args body body* ...))])))
-
diff --git a/src/psyntax-7.1-9.0.ss b/src/psyntax-7.1-9.0.ss
deleted file mode 100644
index b403dd7..0000000
--- a/src/psyntax-7.1-9.0.ss
+++ /dev/null
@@ -1,4711 +0,0 @@
-;;; Portable implementation of syntax-case
-;;; Extracted from Chez Scheme Version 7.1 (Aug 01, 2006)
-;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
-
-;;; Copyright (c) 1992-2002 Cadence Research Systems
-;;; Permission to copy this software, in whole or in part, to use this
-;;; software for any lawful purpose, and to redistribute this software
-;;; is granted subject to the restriction that all copies made of this
-;;; software must include this copyright notice in full.  This software
-;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
-;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
-;;; OR FITNESS FOR ANY PARTICULAR PURPOSE.  IN NO EVENT SHALL THE
-;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
-;;; NATURE WHATSOEVER.
-
-;;; Before attempting to port this code to a new implementation of
-;;; Scheme, please read the notes below carefully.
-
-;;; This file defines the syntax-case expander, sc-expand, and a set
-;;; of associated syntactic forms and procedures.  Of these, the
-;;; following are documented in The Scheme Programming Language,
-;;; Third Edition (R. Kent Dybvig, MIT Press, 2003), which can be
-;;; found online at http://www.scheme.com/tspl3/.  Most are also documented
-;;; in the R4RS and draft R5RS.
-;;;
-;;;   bound-identifier=?
-;;;   datum->syntax-object
-;;;   define-syntax
-;;;   fluid-let-syntax
-;;;   free-identifier=?
-;;;   generate-temporaries
-;;;   identifier?
-;;;   identifier-syntax
-;;;   let-syntax
-;;;   letrec-syntax
-;;;   syntax
-;;;   syntax-case
-;;;   syntax-object->datum
-;;;   syntax-rules
-;;;   with-syntax
-;;;
-;;; All standard Scheme syntactic forms are supported by the expander
-;;; or syntactic abstractions defined in this file.  Only the R4RS
-;;; delay is omitted, since its expansion is implementation-dependent.
-
-;;; Also defined are three forms that support modules: module, import,
-;;; and import-only.  These are documented in the Chez Scheme User's
-;;; Guide (R. Kent Dybvig, Cadence Research Systems, 1998), which can
-;;; also be found online at http://www.scheme.com/csug/.  They are
-;;; described briefly here as well.
-    
-;;; All are definitions and may appear where and only where other
-;;; definitions may appear.  modules may be named:
-;;;
-;;;   (module id (ex ...) defn ... init ...)
-;;;
-;;; or anonymous:
-;;;
-;;;   (module (ex ...) defn ... init ...)
-;;;
-;;; The latter form is semantically equivalent to:
-;;;
-;;;   (module T (ex ...) defn ... init ...)
-;;;   (import T)
-;;;
-;;; where T is a fresh identifier.
-;;;
-;;; In either form, each of the exports in (ex ...) is either an
-;;; identifier or of the form (id ex ...).  In the former case, the
-;;; single identifier ex is exported.  In the latter, the identifier
-;;; id is exported and the exports ex ... are "implicitly" exported.
-;;; This listing of implicit exports is useful only when id is a
-;;; keyword bound to a transformer that expands into references to
-;;; the listed implicit exports.  In the present implementation,
-;;; listing of implicit exports is necessary only for top-level
-;;; modules and allows the implementation to avoid placing all
-;;; identifiers into the top-level environment where subsequent passes
-;;; of the compiler will be unable to deal effectively with them.
-;;;
-;;; Named modules may be referenced in import statements, which
-;;; always take one of the forms:
-;;;
-;;;   (import id)
-;;;   (import-only id)
-;;;
-;;; id must name a module.  Each exported identifier becomes visible
-;;; within the scope of the import form.  In the case of import-only,
-;;; all other identifiers become invisible in the scope of the
-;;; import-only form, except for those established by definitions
-;;; that appear textually after the import-only form.
-
-;;; import and import-only also support a variety of identifier
-;;; selection and renaming forms: only, except, add-prefix,
-;;; drop-prefix, rename, and alias.
-;;;
-;;;   (import (only m x y))
-;;; 
-;;; imports x and y (and nothing else) from m.
-;;;
-;;;   (import (except m x y))
-;;; 
-;;; imports all of m's imports except for x and y.
-;;;
-;;;   (import (add-prefix (only m x y) m:))
-;;; 
-;;; imports x and y as m:x and m:y.
-;;;
-;;;   (import (drop-prefix m foo:))
-;;; 
-;;; imports all of m's imports, dropping the common foo: prefix
-;;; (which must appear on all of m's exports).
-;;; 
-;;;   (import (rename (except m a b) (m-c c) (m-d d)))
-;;; 
-;;; imports all of m's imports except for x and y, renaming c
-;;; m-c and d m-d.
-;;; 
-;;;   (import (alias (except m a b) (m-c c) (m-d d)))
-;;; 
-;;; imports all of m's imports except for x and y, with additional
-;;; aliases m-c for c and m-d for d.
-;;; 
-;;; multiple imports may be specified with one import form:
-;;; 
-;;;   (import (except m1 x) (only m2 x))
-;;; 
-;;; imports all of m1's exports except for x plus x from m2.
-
-;;; Another form, meta, may be used as a prefix for any definition and
-;;; causes any resulting variable bindings to be created at expansion
-;;; time.  Meta variables (variables defined using meta) are available
-;;; only at expansion time.  Meta definitions are often used to create
-;;; data and helpers that can be shared by multiple macros, for example:
-
-;;; (module (alpha beta)
-;;;   (meta define key-error
-;;;     (lambda (key)
-;;;       (syntax-error key "invalid key")))
-;;;   (meta define parse-keys
-;;;     (lambda (keys)
-;;;       (let f ((keys keys) (c #'white) (s 10))
-;;;         (syntax-case keys (color size)
-;;;           (() (list c s))
-;;;           (((color c) . keys) (f #'keys #'c s))
-;;;           (((size s) . keys) (f #'keys c #'s))
-;;;           ((k . keys) (key-error #'k))))))
-;;;   (define-syntax alpha
-;;;     (lambda (x)
-;;;       (syntax-case x ()
-;;;         ((_ (k ...) <other stuff>)
-;;;          (with-syntax (((c s) (parse-keys (syntax (k ...)))))
-;;;            ---)))))
-;;;   (define-syntax beta
-;;;     (lambda (x)
-;;;       (syntax-case x ()
-;;;         ((_ (k ...) <other stuff>)
-;;;          (with-syntax (((c s) (parse-keys (syntax (k ...)))))
-;;;            ---))))))
-
-;;; As with define-syntax rhs expressions, meta expressions can evaluate
-;;; references only to identifiers whose values are (already) available
-;;; in the compile-time environment, e.g., macros and meta variables.
-;;; They can, however, like define-syntax rhs expressions, build syntax
-;;; objects containing occurrences of any identifiers in their scope.
-
-;;; meta definitions propagate through macro expansion, so one can write,
-;;; for example:
-;;; 
-;;;   (module (a)
-;;;     (meta define-structure (foo x))
-;;;     (define-syntax a
-;;;       (let ((q (make-foo (syntax 'q))))
-;;;         (lambda (x)
-;;;           (foo-x q)))))
-;;;   a -> q
-;;; 
-;;; where define-record is a macro that expands into a set of defines.
-;;; 
-;;; It is also sometimes convenient to write
-;;; 
-;;;   (meta begin defn ...)
-;;; 
-;;; or
-;;; 
-;;;   (meta module {exports} defn ...)
-;;; 
-;;; to create groups of meta bindings.
-
-;;; Another form, alias, is used to create aliases from one identifier
-;;; to another.  This is used primarily to support the extended import
-;;; syntaxes (add-prefix, drop-prefix, rename, and alias).
-
-;;; (let ((x 3)) (alias y x) y) -> 3
-
-;;; The remaining exports are listed below.  sc-expand, eval-when, and
-;;; syntax-error are described in the Chez Scheme User's Guide.
-;;;
-;;;   (sc-expand datum)
-;;;      if datum represents a valid expression, sc-expand returns an
-;;;      expanded version of datum in a core language that includes no
-;;;      syntactic abstractions.  The core language includes begin,
-;;;      define, if, lambda, letrec, quote, and set!.
-;;;   (eval-when situations expr ...)
-;;;      conditionally evaluates expr ... at compile-time or run-time
-;;;      depending upon situations
-;;;   (syntax-error object message)
-;;;      used to report errors found during expansion
-;;;   ($syntax-dispatch e p)
-;;;      used by expanded code to handle syntax-case matching
-;;;   ($sc-put-cte symbol val top-token)
-;;;      used to establish top-level compile-time (expand-time) bindings.
-
-;;; The following nonstandard procedures must be provided by the
-;;; implementation for this code to run.
-;;;
-;;; (void)
-;;; returns the implementation's cannonical "unspecified value".  The
-;;; following usually works:
-;;;
-;;; (define void (lambda () (if #f #f))).
-;;;
-;;; (andmap proc list1 list2 ...)
-;;; returns true if proc returns true when applied to each element of list1
-;;; along with the corresponding elements of list2 ....  The following
-;;; definition works but does no error checking:
-;;;
-;;; (define andmap
-;;;   (lambda (f first . rest)
-;;;     (or (null? first)
-;;;         (if (null? rest)
-;;;             (let andmap ((first first))
-;;;               (let ((x (car first)) (first (cdr first)))
-;;;                 (if (null? first)
-;;;                     (f x)
-;;;                     (and (f x) (andmap first)))))
-;;;             (let andmap ((first first) (rest rest))
-;;;               (let ((x (car first))
-;;;                     (xr (map car rest))
-;;;                     (first (cdr first))
-;;;                     (rest (map cdr rest)))
-;;;                 (if (null? first)
-;;;                     (apply f (cons x xr))
-;;;                     (and (apply f (cons x xr)) (andmap first rest)))))))))
-;;;
-;;; (ormap proc list1)
-;;; returns the first non-false return result of proc applied to
-;;; the elements of list1 or false if none.  The following definition
-;;; works but does no error checking:
-;;;
-;;; (define ormap
-;;;   (lambda (proc list1)
-;;;     (and (not (null? list1))
-;;;          (or (proc (car list1)) (ormap proc (cdr list1))))))
-;;;
-;;; The following nonstandard procedures must also be provided by the
-;;; implementation for this code to run using the standard portable
-;;; hooks and output constructors.  They are not used by expanded code,
-;;; and so need be present only at expansion time.
-;;;
-;;; (eval x)
-;;; where x is always in the form ("noexpand" expr).
-;;; returns the value of expr.  the "noexpand" flag is used to tell the
-;;; evaluator/expander that no expansion is necessary, since expr has
-;;; already been fully expanded to core forms.
-;;;
-;;; eval will not be invoked during the loading of psyntax.pp.  After
-;;; psyntax.pp has been loaded, the expansion of any macro definition,
-;;; whether local or global, results in a call to eval.  If, however,
-;;; sc-expand has already been registered as the expander to be used
-;;; by eval, and eval accepts one argument, nothing special must be done
-;;; to support the "noexpand" flag, since it is handled by sc-expand.
-;;;
-;;; (error who format-string why what)
-;;; where who is either a symbol or #f, format-string is always "~a ~s",
-;;; why is always a string, and what may be any object.  error should
-;;; signal an error with a message something like
-;;;
-;;;    "error in <who>: <why> <what>"
-;;;
-;;; (gensym)
-;;; returns a unique symbol each time it's called.  In Chez Scheme, gensym
-;;; returns a symbol with a "globally" unique name so that gensyms that
-;;; end up in the object code of separately compiled files cannot conflict.
-;;; This is necessary only if you intend to support compiled files.
-;;;
-;;; (gensym? x)
-;;; returns #t if x is a gensym, otherwise false.
-;;;
-;;; (putprop symbol key value)
-;;; (getprop symbol key)
-;;; (remprop symbol key)
-;;; key is always a symbol; value may be any object.  putprop should
-;;; associate the given value with the given symbol and key in some way
-;;; that it can be retrieved later with getprop.  getprop should return
-;;; #f if no value is associated with the given symbol and key.  remprop
-;;; should remove the association between the given symbol and key.
-
-;;; When porting to a new Scheme implementation, you should define the
-;;; procedures listed above, load the expanded version of psyntax.ss
-;;; (psyntax.pp, which should be available whereever you found
-;;; psyntax.ss), and register sc-expand as the current expander (how
-;;; you do this depends upon your implementation of Scheme).  You may
-;;; change the hooks and constructors defined toward the beginning of
-;;; the code below, but to avoid bootstrapping problems, do so only
-;;; after you have a working version of the expander.
-
-;;; Chez Scheme allows the syntactic form (syntax <template>) to be
-;;; abbreviated to #'<template>, just as (quote <datum>) may be
-;;; abbreviated to '<datum>.  The #' syntax makes programs written
-;;; using syntax-case shorter and more readable and draws out the
-;;; intuitive connection between syntax and quote.  If you have access
-;;; to the source code of your Scheme system's reader, you might want
-;;; to implement this extension.
-
-;;; If you find that this code loads or runs slowly, consider
-;;; switching to faster hardware or a faster implementation of
-;;; Scheme.  In Chez Scheme on a 200Mhz Pentium Pro, expanding,
-;;; compiling (with full optimization), and loading this file takes
-;;; between one and two seconds.
-
-;;; In the expander implementation, we sometimes use syntactic abstractions
-;;; when procedural abstractions would suffice.  For example, we define
-;;; top-wrap and top-marked? as
-;;;   (define-syntax top-wrap (identifier-syntax '((top))))
-;;;   (define-syntax top-marked?
-;;;     (syntax-rules ()
-;;;       ((_ w) (memq 'top (wrap-marks w)))))
-;;; rather than
-;;;   (define top-wrap '((top)))
-;;;   (define top-marked?
-;;;     (lambda (w) (memq 'top (wrap-marks w))))
-;;; On ther other hand, we don't do this consistently; we define make-wrap,
-;;; wrap-marks, and wrap-subst simply as
-;;;   (define make-wrap cons)
-;;;   (define wrap-marks car)
-;;;   (define wrap-subst cdr)
-;;; In Chez Scheme, the syntactic and procedural forms of these
-;;; abstractions are equivalent, since the optimizer consistently
-;;; integrates constants and small procedures.  Some Scheme
-;;; implementations, however, may benefit from more consistent use
-;;; of one form or the other.
-
-
-;;; Implementation notes:
-
-;;; "begin" is treated as a splicing construct at top level and at
-;;; the beginning of bodies.  Any sequence of expressions that would
-;;; be allowed where the "begin" occurs is allowed.
-
-;;; "let-syntax" and "letrec-syntax" are also treated as splicing
-;;; constructs, in violation of the R5RS.  A consequence is that let-syntax
-;;; and letrec-syntax do not create local contours, as do let and letrec.
-;;; Although the functionality is greater as it is presently implemented,
-;;; we will probably change it to conform to the R5RS.  modules provide
-;;; similar functionality to nonsplicing letrec-syntax when the latter is
-;;; used as a definition.
-
-;;; Objects with no standard print syntax, including objects containing
-;;; cycles and syntax objects, are allowed in quoted data as long as they
-;;; are contained within a syntax form or produced by datum->syntax-object.
-;;; Such objects are never copied.
-
-;;; When the expander encounters a reference to an identifier that has
-;;; no global or lexical binding, it treats it as a global-variable
-;;; reference.  This allows one to write mutually recursive top-level
-;;; definitions, e.g.:
-;;;
-;;;   (define f (lambda (x) (g x)))
-;;;   (define g (lambda (x) (f x)))
-;;;
-;;; but may not always yield the intended when the variable in question
-;;; is later defined as a keyword.
-
-;;; Top-level variable definitions of syntax keywords are permitted.
-;;; In order to make this work, top-level define not only produces a
-;;; top-level definition in the core language, but also modifies the
-;;; compile-time environment (using $sc-put-cte) to record the fact
-;;; that the identifier is a variable.
-
-;;; Top-level definitions of macro-introduced identifiers are visible
-;;; only in code produced by the macro.  That is, a binding for a
-;;; hidden (generated) identifier is created instead, and subsequent
-;;; references within the macro output are renamed accordingly.  For
-;;; example:
-;;;
-;;; (define-syntax a
-;;;   (syntax-rules ()
-;;;     ((_ var exp)
-;;;      (begin
-;;;        (define secret exp)
-;;;        (define var
-;;;          (lambda ()
-;;;            (set! secret (+ secret 17))
-;;;            secret))))))
-;;; (a x 0)
-;;; (x) => 17
-;;; (x) => 34
-;;; secret => Error: variable secret is not bound
-;;;
-;;; The definition above would fail if the definition for secret
-;;; were placed after the definition for var, since the expander would
-;;; encounter the references to secret before the definition that
-;;; establishes the compile-time map from the identifier secret to
-;;; the generated identifier.
-
-;;; Identifiers and syntax objects are implemented as vectors for
-;;; portability.  As a result, it is possible to "forge" syntax
-;;; objects.
-
-;;; The input to sc-expand may contain "annotations" describing, e.g., the
-;;; source file and character position from where each object was read if
-;;; it was read from a file.  These annotations are handled properly by
-;;; sc-expand only if the annotation? hook (see hooks below) is implemented
-;;; properly and the operators annotation-expression and annotation-stripped
-;;; are supplied.  If annotations are supplied, the proper annotated
-;;; expression is passed to the various output constructors, allowing
-;;; implementations to accurately correlate source and expanded code.
-;;; Contact one of the authors for details if you wish to make use of
-;;; this feature.
-
-;;; Implementation of modules:
-;;;
-;;; The implementation of modules requires that implicit top-level exports
-;;; be listed with the exported macro at some level where both are visible,
-;;; e.g.,
-;;;
-;;;   (module M (alpha (beta b))
-;;;     (module ((alpha a) b)
-;;;       (define-syntax alpha (identifier-syntax a))
-;;;       (define a 'a)
-;;;       (define b 'b))
-;;;     (define-syntax beta (identifier-syntax b)))
-;;;
-;;; Listing of implicit imports is not needed for macros that do not make
-;;; it out to top level, including all macros that are local to a "body".
-;;; (They may be listed in this case, however.)  We need this information
-;;; for top-level modules since a top-level module expands into a letrec
-;;; for non-top-level variables and top-level definitions (assignments) for
-;;; top-level variables.  Because of the general nature of macro
-;;; transformers, we cannot determine the set of implicit exports from the
-;;; transformer code, so without the user's help, we'd have to put all
-;;; variables at top level.
-;;;
-;;; Each such top-level identifier is given a generated name (gensym).
-;;; When a top-level module is imported at top level, a compile-time
-;;; alias is established from the top-level name to the generated name.
-;;; The expander follows these aliases transparently.  When any module is
-;;; imported anywhere other than at top level, the id-var-name of the
-;;; import identifier is set to the id-var-name of the export identifier.
-;;; Since we can't determine the actual labels for identifiers defined in
-;;; top-level modules until we determine which are placed in the letrec
-;;; and which make it to top level, we give each an "indirect" label---a
-;;; pair whose car will eventually contain the actual label.  Import does
-;;; not follow the indirect, but id-var-name does.
-;;;
-;;; All identifiers defined within a local module are folded into the
-;;; letrec created for the enclosing body.  Visibility is controlled in
-;;; this case and for nested top-level modules by introducing a new wrap
-;;; for each module.
-
-
-;;; Bootstrapping:
-
-;;; When changing syntax-object representations, it is necessary to support
-;;; both old and new syntax-object representations in id-var-name.  It
-;;; should be sufficient to redefine syntax-object-expression to work for
-;;; both old and new representations and syntax-object-wrap to return the
-;;; empty-wrap for old representations.
-
-
-;;; The following set of definitions establishes bindings for the
-;;; top-level variables assigned values in the let expression below.
-;;; Uncomment them here and copy them to the front of psyntax.pp if
-;;; required by your system.
-
-; (define $sc-put-cte #f)
-; (define sc-expand #f)
-; (define $make-environment #f)
-; (define environment? #f)
-; (define interaction-environment #f)
-; (define identifier? #f)
-; (define syntax->list #f)
-; (define syntax-object->datum #f)
-; (define datum->syntax-object #f)
-; (define generate-temporaries #f)
-; (define free-identifier=? #f)
-; (define bound-identifier=? #f)
-; (define literal-identifier=? #f)
-; (define syntax-error #f)
-; (define $syntax-dispatch #f)
-
-
-(let ()
-
-(define-syntax when
-  (syntax-rules ()
-    ((_ test e1 e2 ...) (if test (begin e1 e2 ...)))))
-(define-syntax unless
-  (syntax-rules ()
-    ((_ test e1 e2 ...) (when (not test) (begin e1 e2 ...)))))
-(define-syntax define-structure
-  (lambda (x)
-    (define construct-name
-      (lambda (template-identifier . args)
-        (datum->syntax-object
-          template-identifier
-          (string->symbol
-            (apply string-append
-                   (map (lambda (x)
-                          (if (string? x)
-                              x
-                              (symbol->string (syntax-object->datum x))))
-                        args))))))
-    (syntax-case x ()
-      ((_ (name id1 ...))
-       (andmap identifier? (syntax (name id1 ...)))
-       (with-syntax
-         ((constructor (construct-name (syntax name) "make-" (syntax name)))
-          (predicate (construct-name (syntax name) (syntax name) "?"))
-          ((access ...)
-           (map (lambda (x) (construct-name x (syntax name) "-" x))
-                (syntax (id1 ...))))
-          ((assign ...)
-           (map (lambda (x)
-                  (construct-name x "set-" (syntax name) "-" x "!"))
-                (syntax (id1 ...))))
-          (structure-length
-           (fx+ (length (syntax (id1 ...))) 1))
-          ((index ...)
-           (let f ((i 1) (ids (syntax (id1 ...))))
-              (if (null? ids)
-                  '()
-                  (cons i (f (fx+ i 1) (cdr ids)))))))
-         (syntax (begin
-                   (define constructor
-                     (lambda (id1 ...)
-                       (vector 'name id1 ... )))
-                   (define predicate
-                     (lambda (x)
-                       (and (vector? x)
-                            (fx= (vector-length x) structure-length)
-                            (eq? (vector-ref x 0) 'name))))
-                   (define access
-                     (lambda (x)
-                       (vector-ref x index)))
-                   ...
-                   (define assign
-                     (lambda (x update)
-                       (vector-set! x index update)))
-                   ...)))))))
-
-(define-syntax let-values ; impoverished one-clause version
-  (syntax-rules ()
-    ((_ ((formals expr)) form1 form2 ...)
-     (call-with-values (lambda () expr) (lambda formals form1 form2 ...)))))
-
-(define noexpand "noexpand")
-
-(define-structure (syntax-object expression wrap))
-
-;;; hooks to nonportable run-time helpers
-(begin
-;(define-syntax fx+ (identifier-syntax +))
-;(define-syntax fx- (identifier-syntax -))
-;(define-syntax fx= (identifier-syntax =))
-;(define-syntax fx< (identifier-syntax <))
-;(define-syntax fx> (identifier-syntax >))
-;(define-syntax fx<= (identifier-syntax <=))
-;(define-syntax fx>= (identifier-syntax >=))
-
-(define annotation? (lambda (x) #f))
-(define annotation-expression 
-  (lambda (x) (error 'annotation-expression "not yet")))
-(define annotation-stripped 
-  (lambda (x) (error 'annotation-stripped "not yet")))
-
-; top-level-eval-hook is used to create "permanent" code (e.g., top-level
-; transformers), so it might be a good idea to compile it
-(define top-level-eval-hook
-  (lambda (x)
-    (eval `(,noexpand ,x))))
-
-; local-eval-hook is used to create "temporary" code (e.g., local
-; transformers), so it might be a good idea to interpret it
-(define local-eval-hook
-  (lambda (x)
-    (eval `(,noexpand ,x))))
-
-(define define-top-level-value-hook
-  (lambda (sym val)
-    (top-level-eval-hook
-      (build-global-definition no-source sym
-        (build-data no-source val)))))
-
-(define error-hook
-  (lambda (who why what)
-    (error who "~a ~s" why what)))
-
-(define-syntax gensym-hook
-  (syntax-rules ()
-    ((_) (gensym))))
-
-;;; AZIZ
-;;; (define put-cte-hook
-;;;   (lambda (symbol val)
-;;;     ($sc-put-cte symbol val '*top*)))
-
-(define put-cte-hook
-  (lambda (symbol val)
-    ($sc-put-cte symbol val '*top*)))
-
-(define get-global-definition-hook
-  (lambda (symbol)
-    (getprop symbol '*sc-expander*)))
-
-(define put-global-definition-hook
-  (lambda (symbol x)
-    (if (not x)
-        (remprop symbol '*sc-expander*)
-        (putprop symbol '*sc-expander* x))))
-
-; if you treat certain bindings (say from environments like ieee or r5rs)
-; read-only, this should return #t for those bindings
-(define read-only-binding?
-  (lambda (symbol)
-    #f))
-
-; should return #f if symbol has no binding for token
-(define get-import-binding
-  (lambda (symbol token)
-    (getprop symbol token)))
-
-; remove binding if x is false
-(define put-import-binding
-  (lambda (symbol token x)
-    (if (not x)
-        (remprop symbol token)
-        (putprop symbol token x))))
-
-;;; generate-id ideally produces globally unique symbols, i.e., symbols
-;;; unique across system runs, to support separate compilation/expansion.
-;;; Use gensym-hook if you do not need to support separate compilation/
-;;; expansion or if your system's gensym creates globally unique
-;;; symbols (as in Chez Scheme).  Otherwise, use the following code
-;;; as a starting point.  session-key should be a unique string for each
-;;; system run to support separate compilation; the default value given
-;;; is satisfactory during initial development only.
-;(define generate-id
-;  (let ((digits "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!$%&*/:<=>?~_^.+-"))
-;    (let ((base (string-length digits)) (session-key "_"))
-;      (define make-digit (lambda (x) (string-ref digits x)))
-;      (define fmt
-;        (lambda (n)
-;          (let fmt ((n n) (a '()))
-;            (if (< n base)
-;                (list->string (cons (make-digit n) a))
-;                (let ((r (modulo n base)) (rest (quotient n base)))
-;                  (fmt rest (cons (make-digit r) a)))))))
-;      (let ((n -1))
-;        (lambda (name) ; name is #f or a symbol
-;          (set! n (+ n 1))
-;          (string->symbol (string-append session-key (fmt n))))))))
-;;; AZIZ
-(define generate-id
-  (lambda (name)
-    (if name (gensym name) (gensym))))
-)
-
-
-
-;;; output constructors
-(begin
-(define-syntax build-application
-  (syntax-rules ()
-    ((_ ae fun-exp arg-exps)
-     `(,fun-exp . ,arg-exps))))
-
-(define-syntax build-conditional
-  (syntax-rules ()
-    ((_ ae test-exp then-exp else-exp)
-     `(if ,test-exp ,then-exp ,else-exp))))
-
-(define-syntax build-lexical-reference
-  (syntax-rules ()
-    ((_ type ae var)
-     var)))
-
-(define-syntax build-lexical-assignment
-  (syntax-rules ()
-    ((_ ae var exp)
-     `(set! ,var ,exp))))
-
-;;; AZIZ
-;;; (define-syntax build-global-reference
-;;;   (syntax-rules ()
-;;;     ((_ ae var)
-;;;      var)))
-(define-syntax build-global-reference
-  (syntax-rules ()
-    [(_ ae var)
-     `(top-level-value ',var)]))
-
-;;; AZIZ
-;;; (define-syntax build-global-assignment
-;;;   (syntax-rules ()
-;;;     ((_ ae var exp)
-;;;      `(set! ,var ,exp))))
-(define-syntax build-global-assignment
-  (syntax-rules ()
-    [(_ ae var exp)
-     `(set-top-level-value! ',var ,exp)]))
-
-;;; AZIZ
-;;; (define-syntax build-global-definition
-;;;   (syntax-rules ()
-;;;     ((_ ae var exp)
-;;;      `(define ,var ,exp))))
-(define-syntax build-global-definition
-  (syntax-rules ()
-    [(_ ae var exp)
-     (build-global-assignment ae var exp)]))
-
-
-(define-syntax build-cte-install
- ; should build a call that has the same effect as calling put-cte-hook
-  (syntax-rules ()
-    ((_ sym exp token) 
-     `(#%$sc-put-cte ',sym ,exp ',token))))
-
-(define-syntax build-visit-only
- ; should mark the result as "visit only" for compile-file
- ; in implementations that support visit/revisit
-  (syntax-rules ()
-    ((_ exp) exp)))
-
-(define-syntax build-revisit-only
- ; should mark the result as "revisit only" for compile-file,
- ; in implementations that support visit/revisit
-  (syntax-rules ()
-    ((_ exp) exp)))
-
-;;; AZIZ
-;;; (define-syntax build-lambda
-;;;   (syntax-rules ()
-;;;     ((_ ae vars exp)
-;;;      `(lambda ,vars ,exp))))
-(define-syntax build-lambda
-  (syntax-rules ()
-    [(_ ae vars exp)
-     `(case-lambda [,vars ,exp])]))
-
-(define build-case-lambda
-  (lambda (ae vars* exp*)
-    `(case-lambda . ,(map list vars* exp*))))
-
-;;; AZIZ
-;;; (define built-lambda?
-;;;   (lambda (x)
-;;;     (and (pair? x) (eq? (car x) 'lambda))))
-(define built-lambda?
-  (lambda (x)
-    (and (pair? x) (eq? (car x) 'case-lambda))))
-
-;;; AZIZ
-;;; (define-syntax build-primref
-;;;   (syntax-rules ()
-;;;     ((_ ae name) name)
-;;;     ((_ ae level name) name)))
-(define-syntax build-primref
-  (syntax-rules ()
-    [(_ ae name)   (build-primref ae 1 name)]
-    [(_ ae level name)
-     `(|#primitive| ,name)]))
-
-
-;;; AZIZ
-(define-syntax build-foreign-call
-  (syntax-rules ()
-    [(_ ae name arg*) `(foreign-call ,name . ,arg*)]))
-(define-syntax build-$apply
-  (syntax-rules ()
-    [(_ ae proc arg*) `($apply ,proc . ,arg*)]))
-
-(define-syntax build-data
-  (syntax-rules ()
-    ((_ ae exp) `',exp)))
-
-(define build-sequence
-  (lambda (ae exps)
-    (let loop ((exps exps))
-      (if (null? (cdr exps))
-          (car exps)
-         ; weed out leading void calls, assuming ordinary list representation
-          (if (equal? (car exps) '(#%void))
-              (loop (cdr exps))
-              `(begin ,@exps))))))
-
-(define build-letrec
-  (lambda (ae vars val-exps body-exp)
-    (if (null? vars)
-        body-exp
-        `(letrec ,(map list vars val-exps) ,body-exp))))
-
-
-(define build-body
-  (lambda (ae vars val-exps body-exp)
-    (build-letrec ae vars val-exps body-exp)))
-
-(define build-top-module
- ; each type is either global (exported) or local (not exported)
- ; we produce global definitions and assignments for globals and
- ; letrec bindings for locals.  if you don't need the definitions,
- ; (just assignments) you can eliminate them.  if you wish to
- ; have your module definitions ordered from left-to-right (ala
- ; letrec*), you can replace the global var-exps with dummy vars
- ; and global val-exps with global assignments, and produce a letrec*
- ; in place of a letrec.
-  (lambda (ae types vars val-exps body-exp)
-    (let-values (((vars defns sets)
-                  (let f ((types types) (vars vars))
-                    (if (null? types)
-                        (values '() '() '())
-                        (let ((var (car vars)))
-                          (let-values (((vars defns sets) (f (cdr types) (cdr vars))))
-                            (if (eq? (car types) 'global)
-                                (let ((x (build-lexical-var no-source var)))
-                                  (values
-                                    (cons x vars)
-                                    (cons (build-global-definition no-source var (chi-void)) defns)
-                                    (cons (build-global-assignment no-source var (build-lexical-reference 'value no-source x)) sets)))
-                                (values (cons var vars) defns sets))))))))
-      (if (null? defns)
-          (build-letrec ae vars val-exps body-exp)
-          (build-sequence no-source
-            (append defns
-              (list
-                (build-letrec ae vars val-exps
-                  (build-sequence no-source (append sets (list body-exp)))))))))))
-
-(define-syntax build-lexical-var
-  (syntax-rules ()
-    ((_ ae id) (gensym))))
-
-(define-syntax lexical-var? gensym?)
-
-(define-syntax self-evaluating?
-  (syntax-rules ()
-    ((_ e)
-     (let ((x e))
-       (or (boolean? x) (fixnum? x) (string? x) (char? x) (null? x))))))
-)
-
-(define-syntax unannotate
-  (syntax-rules ()
-    ((_ x)
-     (let ((e x))
-       (if (annotation? e)
-           (annotation-expression e)
-           e)))))
-
-(define-syntax no-source (identifier-syntax #f))
-
-(define-syntax arg-check
-  (syntax-rules ()
-    ((_ pred? e who)
-     (let ((x e))
-       (if (not (pred? x)) (error-hook who "invalid argument" x))))))
-
-;;; compile-time environments
-
-;;; wrap and environment comprise two level mapping.
-;;;   wrap : id --> label
-;;;   env : label --> <element>
-
-;;; environments are represented in two parts: a lexical part and a global
-;;; part.  The lexical part is a simple list of associations from labels
-;;; to bindings.  The global part is implemented by
-;;; {put,get}-global-definition-hook and associates symbols with
-;;; bindings.
-
-;;; global (assumed global variable) and displaced-lexical (see below)
-;;; do not show up in any environment; instead, they are fabricated by
-;;; lookup when it finds no other bindings.
-
-;;; <environment>              ::= ((<label> . <binding>)*)
-
-;;; identifier bindings include a type and a value
-
-;;; <binding> ::= <procedure>                     macro keyword
-;;;               (macro . <procedure>)           macro keyword
-;;;               (deferred . <thunk>)            macro keyword w/lazily evaluated transformer
-;;;               (macro! . <procedure>)          extended identifier macro keyword
-;;;               (core . <procedure>)            core keyword
-;;;               (begin)                         begin keyword
-;;;               (define)                        define keyword
-;;;               (define-syntax)                 define-syntax keyword
-;;;               (local-syntax . <boolean>)      let-syntax (#f)/letrec-syntax (#t) keyword
-;;;               (eval-when)                     eval-when keyword
-;;;               (set!)                          set! keyword
-;;;               (meta)                          meta keyword
-;;;               ($module-key)                   $module keyword
-;;;               ($import)                       $import keyword
-;;;               ($module . <interface>)         modules
-;;;               (syntax . (<var> . <level>))    pattern variables
-;;;               (global . <symbol>)             assumed global variable
-;;;               (meta-variable . <symbol>)      meta variable
-;;;               (lexical . <var>)               lexical variables
-;;;               (displaced-lexical . #f)        id-var-name not found in store
-;;; <level>   ::= <nonnegative integer>
-;;; <var>     ::= variable returned by build-lexical-var
-
-;;; a macro is a user-defined syntactic-form.  a core is a system-defined
-;;; syntactic form.  begin, define, define-syntax, let-syntax, letrec-syntax,
-;;; eval-when, and meta are treated specially since they are sensitive to
-;;; whether the form is at top-level and can denote valid internal
-;;; definitions.
-
-;;; a pattern variable is a variable introduced by syntax-case and can
-;;; be referenced only within a syntax form.
-
-;;; any identifier for which no top-level syntax definition or local
-;;; binding of any kind has been seen is assumed to be a global
-;;; variable.
-
-;;; a lexical variable is a lambda- or letrec-bound variable.
-
-;;; a displaced-lexical identifier is a lexical identifier removed from
-;;; it's scope by the return of a syntax object containing the identifier.
-;;; a displaced lexical can also appear when a letrec-syntax-bound
-;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
-;;; a displaced lexical should never occur with properly written macros.
-
-(define sanitize-binding
-  (lambda (b)
-    (cond
-      ((procedure? b) (make-binding 'macro b))
-      ((binding? b)
-       (and (case (binding-type b)
-              ((core macro macro! deferred)
-               (and (procedure? (binding-value b))))
-              (($module) (interface? (binding-value b)))
-              ((lexical) (lexical-var? (binding-value b)))
-              ((global meta-variable) (symbol? (binding-value b)))
-              ((syntax) (let ((x (binding-value b)))
-                          (and (pair? x)
-                               (lexical-var? (car x))
-                               (let ((n (cdr x)))
-                                 (and (fixnum? n) (fx>= n 0))))))
-              ((begin define define-syntax set! $module-key $import eval-when meta) (null? (binding-value b)))
-              ((local-syntax) (boolean? (binding-value b)))
-              ((displaced-lexical) (eq? (binding-value b) #f))
-              (else #t))
-            b))
-      (else #f))))
-
-(define-syntax make-binding
-  (syntax-rules (quote)
-    ((_ 'type #f) '(type . #f))
-    ((_ type value) (cons type value))))
-
-(define binding-type car)
-(define binding-value cdr)
-(define set-binding-type! set-car!)
-(define set-binding-value! set-cdr!)
-(define binding? (lambda (x) (and (pair? x) (symbol? (car x)))))
-
-(define-syntax null-env (identifier-syntax '()))
-
-(define extend-env
-  (lambda (label binding r)
-    (cons (cons label binding) r)))
-
-(define extend-env*
-  (lambda (labels bindings r)
-    (if (null? labels)
-        r
-        (extend-env* (cdr labels) (cdr bindings)
-          (extend-env (car labels) (car bindings) r)))))
-
-(define extend-var-env*
-  ; variant of extend-env* that forms "lexical" binding
-  (lambda (labels vars r)
-    (if (null? labels)
-        r
-        (extend-var-env* (cdr labels) (cdr vars)
-          (extend-env (car labels) (make-binding 'lexical (car vars)) r)))))
-
-(define (displaced-lexical? id r)
-  (let ((n (id-var-name id empty-wrap)))
-    (and n
-         (let ((b (lookup n r)))
-           (eq? (binding-type b) 'displaced-lexical)))))
-
-(define displaced-lexical-error
-  (lambda (id)
-    (syntax-error id
-      (if (id-var-name id empty-wrap)
-          "identifier out of context"
-          "identifier not visible"))))
-
-(define lookup*
-  ; x may be a label or a symbol
-  ; although symbols are usually global, we check the environment first
-  ; anyway because a temporary binding may have been established by
-  ; fluid-let-syntax
-  (lambda (x r)
-    (cond
-      ((assq x r) => cdr)
-      ((symbol? x)
-       (or (get-global-definition-hook x) (make-binding 'global x)))
-      (else (make-binding 'displaced-lexical #f)))))
-
-(define lookup
-  (lambda (x r)
-    (define whack-binding!
-      (lambda (b *b)
-        (set-binding-type! b (binding-type *b))
-        (set-binding-value! b (binding-value *b))))
-    (let ((b (lookup* x r)))
-      (when (eq? (binding-type b) 'deferred)
-        (whack-binding! b (make-transformer-binding ((binding-value b)))))
-      b)))
-
-(define make-transformer-binding
-  (lambda (b)
-    (or (sanitize-binding b)
-        (syntax-error b "invalid transformer"))))
-
-(define defer-or-eval-transformer
-  (lambda (eval x)
-    (if (built-lambda? x)
-        (make-binding 'deferred (lambda () (eval x)))
-        (make-transformer-binding (eval x)))))
-
-(define global-extend
-  (lambda (type sym val)
-    (put-cte-hook sym (make-binding type val))))
-
-
-;;; Conceptually, identifiers are always syntax objects.  Internally,
-;;; however, the wrap is sometimes maintained separately (a source of
-;;; efficiency and confusion), so that symbols are also considered
-;;; identifiers by id?.  Externally, they are always wrapped.
-
-(define nonsymbol-id?
-  (lambda (x)
-    (and (syntax-object? x)
-         (symbol? (unannotate (syntax-object-expression x))))))
-
-(define id?
-  (lambda (x)
-    (cond
-      ((symbol? x) #t)
-      ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
-      ((annotation? x) (symbol? (annotation-expression x)))
-      (else #f))))
-
-(define-syntax id-sym-name
-  (syntax-rules ()
-    ((_ e)
-     (let ((x e))
-       (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))
-
-(define id-marks
-  (lambda (id)
-    (if (syntax-object? id)
-        (wrap-marks (syntax-object-wrap id))
-        (wrap-marks top-wrap))))
-
-(define id-subst
-  (lambda (id)
-    (if (syntax-object? id)
-        (wrap-subst (syntax-object-wrap id))
-        (wrap-marks top-wrap))))
-
-(define id-sym-name&marks
-  (lambda (x w)
-    (if (syntax-object? x)
-        (values
-          (unannotate (syntax-object-expression x))
-          (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
-        (values (unannotate x) (wrap-marks w)))))
-
-;;; syntax object wraps
-
-;;;         <wrap>     ::= ((<mark> ...) . (<subst> ...))
-;;;        <subst>     ::= <ribcage> | <shift>
-;;;      <ribcage>     ::= #((<ex-symname> ...) (<mark> ...) (<label> ...)) ; extensible, for chi-internal/external
-;;;                      | #(#(<symname> ...) #(<mark> ...) #(<label> ...)) ; nonextensible
-;;;   <ex-symname>     ::= <symname> | <import token> | <barrier>
-;;;        <shift>     ::= shift
-;;;      <barrier>     ::= #f                                               ; inserted by import-only
-;;; <import interface> ::= #<import-interface interface new-marks>
-;;;        <token>     ::= <generated id>
-
-(define make-wrap cons)
-(define wrap-marks car)
-(define wrap-subst cdr)
-
-
-(define-syntax empty-wrap (identifier-syntax '(())))
-
-(define-syntax top-wrap (identifier-syntax '((top))))
-
-(define-syntax top-marked?
-  (syntax-rules ()
-    ((_ w) (memq 'top (wrap-marks w)))))
-
-(define-syntax only-top-marked?
-  (syntax-rules ()
-    ((_ id) (same-marks? (wrap-marks (syntax-object-wrap id)) (wrap-marks top-wrap)))))
-
-;;; labels
-
-;;; simple labels must be comparable with "eq?" and distinct from symbols
-;;; and pairs.
-
-;;; indirect labels, which are implemented as pairs, are used to support
-;;; import aliasing for identifiers exported (explictly or implicitly) from
-;;; top-level modules.  chi-external creates an indirect label for each
-;;; defined identifier, import causes the pair to be shared with aliases it
-;;; establishes, and chi-top-module whacks the pair to hold the top-level
-;;; identifier name (symbol) if the id is to be placed at top level, before
-;;; expanding the right-hand sides of the definitions in the module.
-
-(module (gen-indirect-label indirect-label? get-indirect-label set-indirect-label!)
-  (define-structure (indirect-label label))
-  (define gen-indirect-label
-    (lambda ()
-      (make-indirect-label (gen-label))))
-  (define get-indirect-label (lambda (x) (indirect-label-label x)))
-  (define set-indirect-label! (lambda (x v) (set-indirect-label-label! x v))))
-
-(define gen-label
-  (lambda () (string #\i)))
-(define label?
-  (lambda (x)
-    (or (string? x) ; normal lexical labels
-        (symbol? x) ; global labels (symbolic names)
-        (indirect-label? x))))
-
-(define gen-labels
-  (lambda (ls)
-    (if (null? ls)
-        '()
-        (cons (gen-label) (gen-labels (cdr ls))))))
-
-(define-structure (ribcage symnames marks labels))
-(define-structure (top-ribcage key mutable?))
-(define-structure (import-interface interface new-marks))
-(define-structure (env top-ribcage wrap))
-
-;;; Marks must be comparable with "eq?" and distinct from pairs and
-;;; the symbol top.  We do not use integers so that marks will remain
-;;; unique even across file compiles.
-
-(define-syntax the-anti-mark (identifier-syntax #f))
-
-(define anti-mark
-  (lambda (w)
-    (make-wrap (cons the-anti-mark (wrap-marks w))
-               (cons 'shift (wrap-subst w)))))
-
-(define-syntax new-mark
-  (syntax-rules ()
-    ((_) (string #\m))))
-
-(define barrier-marker #f)
-
-;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
-;;; internal definitions, in which the ribcages are built incrementally
-(define-syntax make-empty-ribcage
-  (syntax-rules ()
-    ((_) (make-ribcage '() '() '()))))
-
-(define extend-ribcage!
- ; must receive ids with complete wraps
- ; ribcage guaranteed to be list-based
-  (lambda (ribcage id label)
-    (set-ribcage-symnames! ribcage
-      (cons (unannotate (syntax-object-expression id))
-            (ribcage-symnames ribcage)))
-    (set-ribcage-marks! ribcage
-      (cons (wrap-marks (syntax-object-wrap id))
-            (ribcage-marks ribcage)))
-    (set-ribcage-labels! ribcage
-      (cons label (ribcage-labels ribcage)))))
-
-(define import-extend-ribcage!
- ; must receive ids with complete wraps
- ; ribcage guaranteed to be list-based
-  (lambda (ribcage new-marks id label)
-    (set-ribcage-symnames! ribcage
-      (cons (unannotate (syntax-object-expression id))
-            (ribcage-symnames ribcage)))
-    (set-ribcage-marks! ribcage
-      (cons (join-marks new-marks (wrap-marks (syntax-object-wrap id)))
-            (ribcage-marks ribcage)))
-    (set-ribcage-labels! ribcage
-      (cons label (ribcage-labels ribcage)))))
-
-(define extend-ribcage-barrier!
- ; must receive ids with complete wraps
- ; ribcage guaranteed to be list-based
-  (lambda (ribcage killer-id)
-    (extend-ribcage-barrier-help! ribcage (syntax-object-wrap killer-id))))
-
-(define extend-ribcage-barrier-help!
-  (lambda (ribcage wrap)
-    (set-ribcage-symnames! ribcage
-      (cons barrier-marker (ribcage-symnames ribcage)))
-    (set-ribcage-marks! ribcage
-      (cons (wrap-marks wrap) (ribcage-marks ribcage)))))
-
-(define extend-ribcage-subst!
- ; ribcage guaranteed to be list-based
-  (lambda (ribcage import-iface)
-    (set-ribcage-symnames! ribcage
-      (cons import-iface (ribcage-symnames ribcage)))))
-
-(define lookup-import-binding-name
-  (lambda (sym marks token new-marks)
-    (let ((new (get-import-binding sym token)))
-      (and new
-           (let f ((new new))
-             (cond
-               ((pair? new) (or (f (car new)) (f (cdr new))))
-               ((symbol? new)
-                (and (same-marks? marks (join-marks new-marks (wrap-marks top-wrap))) new))
-               ((same-marks? marks (join-marks new-marks (wrap-marks (syntax-object-wrap new)))) new)
-               (else #f)))))))
-  
-(define store-import-binding
-  (lambda (id token new-marks)
-    (define cons-id
-      (lambda (id x)
-        (if (not x) id (cons id x))))
-    (define weed ; remove existing binding for id, if any
-      (lambda (marks x)
-        (if (pair? x)
-            (if (same-marks? (id-marks (car x)) marks)
-                (weed marks (cdr x))
-                (cons-id (car x) (weed marks (cdr x))))
-            (and x (not (same-marks? (id-marks x) marks)) x))))
-    (let ((id (if (null? new-marks)
-                  id
-                  (make-syntax-object (id-sym-name id)
-                    (make-wrap
-                      (join-marks new-marks (id-marks id))
-                      (id-subst id))))))
-      (let ((sym (id-sym-name id)))
-       ; no need to record bindings mapping symbol to self, since this   
-       ; assumed by default.
-        (unless (eq? id sym)
-          (let ((marks (id-marks id)))
-            (let ((x (weed marks (get-import-binding sym token))))
-              (put-import-binding sym token
-                (cons-id
-                  (if (same-marks? marks (wrap-marks top-wrap))
-                     ; need full id only if more than top-marked.
-                      (resolved-id-var-name id)
-                      id)
-                  x)))))))))
-
-;;; make-binding-wrap creates vector-based ribcages
-(define make-binding-wrap
-  (lambda (ids labels w)
-    (if (null? ids)
-        w
-        (make-wrap
-          (wrap-marks w)
-          (cons
-            (let ((labelvec (list->vector labels)))
-              (let ((n (vector-length labelvec)))
-                (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
-                  (let f ((ids ids) (i 0))
-                    (unless (null? ids)
-                      (let-values (((symname marks) (id-sym-name&marks (car ids) w)))
-                        (vector-set! symnamevec i symname)
-                        (vector-set! marksvec i marks)
-                        (f (cdr ids) (fx+ i 1)))))
-                  (make-ribcage symnamevec marksvec labelvec))))
-            (wrap-subst w))))))
-
-;;; resolved ids contain no unnecessary substitutions or marks.  they are
-;;; used essentially as indirects or aliases in modules interfaces.
-(define make-resolved-id
-  (lambda (fromsym marks tosym)
-    (make-syntax-object fromsym
-      (make-wrap marks
-        (list (make-ribcage (vector fromsym) (vector marks) (vector tosym)))))))
-
-(define id->resolved-id
-  (lambda (id)
-    (let-values (((tosym marks) (id-var-name&marks id empty-wrap)))
-      (unless tosym
-        (syntax-error id "identifier not visible for export"))
-      (make-resolved-id (id-sym-name id) marks tosym))))
-
-(define resolved-id-var-name
-  (lambda (id)
-    (vector-ref
-      (ribcage-labels (car (wrap-subst (syntax-object-wrap id))))
-      0)))
-
-;;; Scheme's append should not copy the first argument if the second is
-;;; nil, but it does, so we define a smart version here.
-(define smart-append
-  (lambda (m1 m2)
-    (if (null? m2)
-        m1
-        (append m1 m2))))
-
-(define join-wraps
-  (lambda (w1 w2)
-    (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
-      (if (null? m1)
-          (if (null? s1)
-              w2
-              (make-wrap
-                (wrap-marks w2)
-                (join-subst s1 (wrap-subst w2))))
-          (make-wrap
-            (join-marks m1 (wrap-marks w2))
-            (join-subst s1 (wrap-subst w2)))))))
-
-(define join-marks
-  (lambda (m1 m2)
-    (smart-append m1 m2)))
-
-(define join-subst
-  (lambda (s1 s2)
-    (smart-append s1 s2)))
-
-(define same-marks?
-  (lambda (x y)
-    (or (eq? x y)
-        (and (not (null? x))
-             (not (null? y))
-             (eq? (car x) (car y))
-             (same-marks? (cdr x) (cdr y))))))
-
-(define diff-marks
-  (lambda (m1 m2)
-    (let ((n1 (length m1)) (n2 (length m2)))
-      (let f ((n1 n1) (m1 m1))
-        (cond
-          ((fx> n1 n2) (cons (car m1) (f (fx- n1 1) (cdr m1))))
-          ((equal? m1 m2) '())
-          (else (error 'sc-expand
-                  "internal error in diff-marks: ~s is not a tail of ~s"
-                  m1 m2)))))))
-
-(module (top-id-bound-var-name top-id-free-var-name)
-  ;; top-id-bound-var-name is used to look up or establish new top-level
-  ;; substitutions, while top-id-free-var-name is used to look up existing
-  ;; (possibly implicit) substitutions.  Implicit substitutions exist
-  ;; for top-marked names in all environments, but we represent them
-  ;; explicitly only on demand.
-  ;;
-  ;; In both cases, we first look for an existing substitution for sym
-  ;; and the given marks.  If we find one, we return it.  Otherwise, we
-  ;; extend the appropriate top-level environment
-  ;;
-  ;; For top-id-bound-var-name, we extend the environment with a substition
-  ;; keyed by the given marks, so that top-level definitions introduced by
-  ;; a macro are distinct from other top-level definitions for the same
-  ;; name.  For example, if macros a and b both introduce definitions and
-  ;; bound references to identifier x, the two x's should be different,
-  ;; i.e., keyed by their own marks.
-  ;;
-  ;; For top-id-free-var-name, we extend the environment with a substition
-  ;; keyed by the top marks, since top-level free identifier references
-  ;; should refer to the existing implicit (top-marked) substitution.  For
-  ;; example, if macros a and b both introduce free references to identifier
-  ;; x, they should both refer to the same (global, unmarked) x.
-  ;;
- ;; If the environment is *top*, we map a symbol to itself
-
- (define leave-implicit? (lambda (token) (eq? token '*top*)))
-
-  (define new-binding
-    (lambda (sym marks token)
-      (let ((loc (if (and (leave-implicit? token)
-                          (same-marks? marks (wrap-marks top-wrap)))
-                     sym
-                     (generate-id sym))))
-        (let ((id (make-resolved-id sym marks loc)))
-          (store-import-binding id token '())
-          (values loc id)))))
-
-  (define top-id-bound-var-name
-   ; should be called only when top-ribcage is mutable
-    (lambda (sym marks top-ribcage)
-      (let ((token (top-ribcage-key top-ribcage)))
-        (cond
-          ((lookup-import-binding-name sym marks token '()) =>
-           (lambda (id)
-             (if (symbol? id) ; symbol iff marks == (wrap-marks top-wrap)
-                 (if (read-only-binding? id)
-                     (new-binding sym marks token)
-                     (values id (make-resolved-id sym marks id)))
-                 (values (resolved-id-var-name id) id))))
-          (else (new-binding sym marks token))))))
-
-  (define top-id-free-var-name
-    (lambda (sym marks top-ribcage)
-      (let ((token (top-ribcage-key top-ribcage)))
-        (cond
-          ((lookup-import-binding-name sym marks token '()) =>
-           (lambda (id) (if (symbol? id) id (resolved-id-var-name id))))
-          ((and (top-ribcage-mutable? top-ribcage)
-                (same-marks? marks (wrap-marks top-wrap)))
-           (let-values (((sym id) (new-binding sym (wrap-marks top-wrap) token)))
-             sym))
-          (else #f))))))
-
-(define id-var-name-loc&marks
-  (lambda (id w)
-    (define search
-      (lambda (sym subst marks)
-        (if (null? subst)
-            (values #f marks)
-            (let ((fst (car subst)))
-               (cond
-                 ((eq? fst 'shift) (search sym (cdr subst) (cdr marks)))
-                 ((ribcage? fst)
-                  (let ((symnames (ribcage-symnames fst)))
-                    (if (vector? symnames)
-                        (search-vector-rib sym subst marks symnames fst)
-                        (search-list-rib sym subst marks symnames fst))))
-                 ((top-ribcage? fst)
-                  (cond
-                    ((top-id-free-var-name sym marks fst) =>
-                     (lambda (var-name) (values var-name marks)))
-                    (else (search sym (cdr subst) marks))))
-                 (else
-                  (error 'sc-expand
-                    "internal error in id-var-name-loc&marks: improper subst ~s"
-                    subst)))))))
-    (define search-list-rib
-      (lambda (sym subst marks symnames ribcage)
-        (let f ((symnames symnames) (i 0))
-          (if (null? symnames)
-              (search sym (cdr subst) marks)
-              (let ((x (car symnames)))
-                (cond
-                  ((and (eq? x sym)
-                        (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
-                   (values (list-ref (ribcage-labels ribcage) i) marks))
-                  ((import-interface? x)
-                   (let ((iface (import-interface-interface x))
-                         (new-marks (import-interface-new-marks x)))
-                     (cond
-                       ((interface-token iface) =>
-                        (lambda (token)
-                          (cond
-                            ((lookup-import-binding-name sym marks token new-marks) =>
-                             (lambda (id)
-                               (values
-                                 (if (symbol? id) id (resolved-id-var-name id))
-                                 marks)))
-                            (else (f (cdr symnames) i)))))
-                       (else
-                        (let* ((ie (interface-exports iface))
-                               (n (vector-length ie)))
-                          (let g ((j 0))
-                            (if (fx= j n)
-                                (f (cdr symnames) i)
-                                (let ((id (vector-ref ie j)))
-                                  (let ((id.sym (id-sym-name id))
-                                        (id.marks (join-marks new-marks (id-marks id))))
-                                    (if (help-bound-id=? id.sym id.marks sym marks)
-                                        (values (lookup-import-label id) marks)
-                                        (g (fx+ j 1))))))))))))
-                  ((and (eq? x barrier-marker)
-                        (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
-                   (values #f marks))
-                  (else (f (cdr symnames) (fx+ i 1)))))))))
-    (define search-vector-rib
-      (lambda (sym subst marks symnames ribcage)
-        (let ((n (vector-length symnames)))
-          (let f ((i 0))
-            (cond
-              ((fx= i n) (search sym (cdr subst) marks))
-              ((and (eq? (vector-ref symnames i) sym)
-                    (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
-               (values (vector-ref (ribcage-labels ribcage) i) marks))
-              (else (f (fx+ i 1))))))))
-    (cond
-      ((symbol? id) (search id (wrap-subst w) (wrap-marks w)))
-      ((syntax-object? id)
-       (let ((sym (unannotate (syntax-object-expression id)))
-             (w1 (syntax-object-wrap id)))
-         (let-values (((name marks) (search sym (wrap-subst w)
-                                      (join-marks
-                                        (wrap-marks w)
-                                        (wrap-marks w1)))))
-           (if name
-               (values name marks)
-               (search sym (wrap-subst w1) marks)))))
-      ((annotation? id) (search (unannotate id) (wrap-subst w) (wrap-marks w)))
-      (else (error-hook 'id-var-name "invalid id" id)))))
-
-(define id-var-name&marks
- ; this version follows indirect labels
-  (lambda (id w)
-    (let-values (((label marks) (id-var-name-loc&marks id w)))
-      (values (if (indirect-label? label) (get-indirect-label label) label) marks))))
-
-(define id-var-name-loc
- ; this version doesn't follow indirect labels
-  (lambda (id w)
-    (let-values (((label marks) (id-var-name-loc&marks id w)))
-      label)))
-
-(define id-var-name
- ; this version follows indirect labels
-  (lambda (id w)
-    (let-values (((label marks) (id-var-name-loc&marks id w)))
-      (if (indirect-label? label) (get-indirect-label label) label))))
-
-;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
-;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
-
-(define free-id=?
-  (lambda (i j)
-    (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
-         (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
-
-(define literal-id=?
-  (lambda (id literal)
-    (and (eq? (id-sym-name id) (id-sym-name literal))
-         (let ((n-id (id-var-name id empty-wrap))
-               (n-literal (id-var-name literal empty-wrap)))
-           (or (eq? n-id n-literal)
-               (and (or (not n-id) (symbol? n-id))
-                    (or (not n-literal) (symbol? n-literal))))))))
-
-;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
-;;; long as the missing portion of the wrap is common to both of the ids
-;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
-
-(define help-bound-id=?
-  (lambda (i.sym i.marks j.sym j.marks)
-    (and (eq? i.sym j.sym)
-         (same-marks? i.marks j.marks))))
-   
-(define bound-id=?
-  (lambda (i j)
-    (help-bound-id=? (id-sym-name i) (id-marks i) (id-sym-name j) (id-marks j))))
-
-;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
-;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
-;;; as long as the missing portion of the wrap is common to all of the
-;;; ids.
-
-(define valid-bound-ids?
-  (lambda (ids)
-     (and (let all-ids? ((ids ids))
-            (or (null? ids)
-                (and (id? (car ids))
-                     (all-ids? (cdr ids)))))
-          (distinct-bound-ids? ids))))
-
-;;; distinct-bound-ids? expects a list of ids and returns #t if there are
-;;; no duplicates.  It is quadratic on the length of the id list; long
-;;; lists could be sorted to make it more efficient.  distinct-bound-ids?
-;;; may be passed unwrapped (or partially wrapped) ids as long as the
-;;; missing portion of the wrap is common to all of the ids.
-
-(define distinct-bound-ids?
-  (lambda (ids)
-    (let distinct? ((ids ids))
-      (or (null? ids)
-          (and (not (bound-id-member? (car ids) (cdr ids)))
-               (distinct? (cdr ids)))))))
-
-(define invalid-ids-error
- ; find first bad one and complain about it
-  (lambda (ids exp class)
-    (let find ((ids ids) (gooduns '()))
-      (if (null? ids)
-          (syntax-error exp) ; shouldn't happen
-          (if (id? (car ids))
-              (if (bound-id-member? (car ids) gooduns)
-                  (syntax-error (car ids) "duplicate " class)
-                  (find (cdr ids) (cons (car ids) gooduns)))
-              (syntax-error (car ids) "invalid " class))))))
-
-(define bound-id-member?
-   (lambda (x list)
-      (and (not (null? list))
-           (or (bound-id=? x (car list))
-               (bound-id-member? x (cdr list))))))
-
-;;; wrapping expressions and identifiers
-
-(define wrap
-  (lambda (x w)
-    (cond
-      ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
-      ((syntax-object? x)
-       (make-syntax-object
-         (syntax-object-expression x)
-         (join-wraps w (syntax-object-wrap x))))
-      ((null? x) x)
-      (else (make-syntax-object x w)))))
-
-(define source-wrap
-  (lambda (x w ae)
-    (wrap (if (annotation? ae)
-              (begin
-                (unless (eq? (annotation-expression ae) x)
-                  (error 'sc-expand "internal error in source-wrap: ae/x mismatch"))
-                ae)
-              x)
-          w)))
-
-;;; expanding
-
-(define chi-when-list
-  (lambda (when-list w)
-    ; when-list is syntax'd version of list of situations
-    (map (lambda (x)
-           (cond
-             ((literal-id=? x (syntax compile)) 'compile)
-             ((literal-id=? x (syntax load)) 'load)
-             ((literal-id=? x (syntax visit)) 'visit)
-             ((literal-id=? x (syntax revisit)) 'revisit)
-             ((literal-id=? x (syntax eval)) 'eval)
-             (else (syntax-error (wrap x w) "invalid eval-when situation"))))
-         when-list)))
-
-;;; syntax-type returns five values: type, value, e, w, and ae.  The first
-;;; two are described in the table below.
-;;;
-;;;    type                   value         explanation
-;;;    -------------------------------------------------------------------
-;;;    alias                  none          alias keyword
-;;;    alias-form             none          alias expression
-;;;    begin                  none          begin keyword
-;;;    begin-form             none          begin expression
-;;;    call                   none          any other call
-;;;    constant               none          self-evaluating datum
-;;;    core                   procedure     core form (including singleton)
-;;;    define                 none          define keyword
-;;;    define-form            none          variable definition
-;;;    define-syntax          none          define-syntax keyword
-;;;    define-syntax-form     none          syntax definition
-;;;    displaced-lexical      none          displaced lexical identifier
-;;;    eval-when              none          eval-when keyword
-;;;    eval-when-form         none          eval-when form
-;;;    global                 name          global variable reference
-;;;    $import                none          $import keyword
-;;;    $import-form           none          $import form
-;;;    lexical                name          lexical variable reference
-;;;    lexical-call           name          call to lexical variable
-;;;    local-syntax           rec?          letrec-syntax/let-syntax keyword
-;;;    local-syntax-form      rec?          syntax definition
-;;;    meta                   none          meta keyword
-;;;    meta-form              none          meta form
-;;;    meta-variable          name          meta variable
-;;;    $module                none          $module keyword
-;;;    $module-form           none          $module definition
-;;;    syntax                 level         pattern variable
-;;;    other                  none          anything else
-;;;
-;;; For all forms, e is the form, w is the wrap for e. and ae is the
-;;; (possibly) source-annotated form.
-;;;
-;;; syntax-type expands macros and unwraps as necessary to get to
-;;; one of the forms above.
-
-(define syntax-type
-  (lambda (e r w ae rib)
-    (cond
-      ((symbol? e)
-       (let* ((n (id-var-name e w))
-              (b (lookup n r))
-              (type (binding-type b)))
-         (case type
-           ((macro macro!) (syntax-type (chi-macro (binding-value b) e r w ae rib) r empty-wrap #f rib))
-           (else (values type (binding-value b) e w ae)))))
-      ((pair? e)
-       (let ((first (car e)))
-         (if (id? first)
-             (let* ((n (id-var-name first w))
-                    (b (lookup n r))
-                    (type (binding-type b)))
-               (case type
-                 ((lexical) (values 'lexical-call (binding-value b) e w ae))
-                 ((macro macro!)
-                  (syntax-type (chi-macro (binding-value b) e r w ae rib)
-                    r empty-wrap #f rib))
-                 ((core) (values type (binding-value b) e w ae))
-                 ((begin) (values 'begin-form #f e w ae))
-                 ((alias) (values 'alias-form #f e w ae))
-                 ((define) (values 'define-form #f e w ae))
-                 ((define-syntax) (values 'define-syntax-form #f e w ae))
-                 ((set!) (chi-set! e r w ae rib))
-                 (($module-key) (values '$module-form #f e w ae))
-                 (($import) (values '$import-form #f e w ae))
-                 ((eval-when) (values 'eval-when-form #f e w ae))
-                 ((meta) (values 'meta-form #f e w ae))
-                 ((local-syntax)
-                  (values 'local-syntax-form (binding-value b) e w ae))
-                 (else (values 'call #f e w ae))))
-             (values 'call #f e w ae))))
-      ((syntax-object? e)
-       (syntax-type (syntax-object-expression e)
-                    r
-                    (join-wraps w (syntax-object-wrap e))
-                    #f rib))
-      ((annotation? e)
-       (syntax-type (annotation-expression e) r w e rib))
-      ((self-evaluating? e) (values 'constant #f e w ae))
-      (else (values 'other #f e w ae)))))
-
-(define chi-top*
-  (lambda (e r w ctem rtem meta? top-ribcage)
-    (let ((meta-residuals '()))
-      (define meta-residualize!
-        (lambda (x)
-          (set! meta-residuals
-            (cons x meta-residuals))))
-      (let ((e (chi-top e r w ctem rtem meta? top-ribcage meta-residualize! #f)))
-        (build-sequence no-source
-          (reverse (cons e meta-residuals)))))))
-
-(define chi-top-sequence
-  (lambda (body r w ae ctem rtem meta? ribcage meta-residualize!)
-    (build-sequence ae
-      (let dobody ((body body))
-        (if (null? body)
-            '()
-            (let ((first (chi-top (car body) r w ctem rtem meta? ribcage meta-residualize! #f)))
-              (cons first (dobody (cdr body)))))))))
-
-(define chi-top
-  (lambda (e r w ctem rtem meta? top-ribcage meta-residualize! meta-seen?)
-    (let-values (((type value e w ae) (syntax-type e r w no-source top-ribcage)))
-      (case type
-        ((begin-form)
-         (let ((forms (parse-begin e w ae #t)))
-           (if (null? forms)
-               (chi-void)
-               (chi-top-sequence forms r w ae ctem rtem meta? top-ribcage meta-residualize!))))
-        ((local-syntax-form)
-         (let-values (((forms r mr w ae) (chi-local-syntax value e r r w ae)))
-          ; mr should be same as r here
-           (chi-top-sequence forms r w ae ctem rtem meta? top-ribcage meta-residualize!)))
-        ((eval-when-form)
-         (let-values (((when-list forms) (parse-eval-when e w ae)))
-           (let ((ctem (update-mode-set when-list ctem))
-                 (rtem (update-mode-set when-list rtem)))
-             (if (and (null? ctem) (null? rtem))
-                 (chi-void)
-                 (chi-top-sequence forms r w ae ctem rtem meta? top-ribcage meta-residualize!)))))
-        ((meta-form) (chi-top (parse-meta e w ae) r w ctem rtem #t top-ribcage meta-residualize! #t))
-        ((define-syntax-form)
-         (let-values (((id rhs w) (parse-define-syntax e w ae)))
-           (let ((id (wrap id w)))
-             (when (displaced-lexical? id r) (displaced-lexical-error id))
-             (unless (top-ribcage-mutable? top-ribcage)
-               (syntax-error (source-wrap e w ae)
-                 "invalid definition in read-only environment"))
-             (let ((sym (id-sym-name id)))
-               (let-values (((valsym bound-id) (top-id-bound-var-name sym (wrap-marks (syntax-object-wrap id)) top-ribcage)))
-                 (unless (eq? (id-var-name id empty-wrap) valsym)
-                   (syntax-error (source-wrap e w ae)
-                     "definition not permitted"))
-                 (when (read-only-binding? valsym)
-                   (syntax-error (source-wrap e w ae)
-                     "invalid definition of read-only identifier"))
-                 (ct-eval/residualize2 ctem
-                   (lambda ()
-                     (build-cte-install
-                       bound-id
-                       (chi rhs r r w #t)
-                       (top-ribcage-key top-ribcage)))))))))
-        ((define-form)
-         (let-values (((id rhs w) (parse-define e w ae)))
-           (let ((id (wrap id w)))
-             (when (displaced-lexical? id r) (displaced-lexical-error id))
-             (unless (top-ribcage-mutable? top-ribcage)
-               (syntax-error (source-wrap e w ae)
-                 "invalid definition in read-only environment"))
-             (let ((sym (id-sym-name id)))
-               (let-values (((valsym bound-id) (top-id-bound-var-name sym (wrap-marks (syntax-object-wrap id)) top-ribcage)))
-                 (unless (eq? (id-var-name id empty-wrap) valsym)
-                   (syntax-error (source-wrap e w ae)
-                     "definition not permitted"))
-                 (when (read-only-binding? valsym)
-                   (syntax-error (source-wrap e w ae)
-                     "invalid definition of read-only identifier"))
-                 (if meta?
-                     (ct-eval/residualize2 ctem
-                       (lambda ()
-                         (build-sequence no-source
-                           (list
-                             (build-cte-install bound-id
-                               (build-data no-source (make-binding 'meta-variable valsym))
-                               (top-ribcage-key top-ribcage))
-                             (build-global-definition ae valsym (chi rhs r r w #t))))))
-                    ; make sure compile-time definitions occur before we
-                    ; expand the run-time code
-                     (let ((x (ct-eval/residualize2 ctem
-                                (lambda ()
-                                  (build-cte-install
-                                    bound-id
-                                    (build-data no-source (make-binding 'global valsym))
-                                    (top-ribcage-key top-ribcage))))))
-                       (build-sequence no-source
-                         (list
-                           x
-                           (rt-eval/residualize rtem
-                             (lambda ()
-                               (build-global-definition ae valsym (chi rhs r r w #f)))))))))
-             ))))
-        (($module-form)
-         (let ((ribcage (make-empty-ribcage)))
-           (let-values (((orig id exports forms)
-                         (parse-module e w ae
-                           (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))))
-             (when (displaced-lexical? id r) (displaced-lexical-error (wrap id w)))
-             (unless (top-ribcage-mutable? top-ribcage)
-               (syntax-error orig
-                 "invalid definition in read-only environment"))
-             (chi-top-module orig r r top-ribcage ribcage ctem rtem meta? id exports forms meta-residualize!))))
-        (($import-form)
-         (let-values (((orig only? mid) (parse-import e w ae)))
-           (unless (top-ribcage-mutable? top-ribcage)
-             (syntax-error orig
-               "invalid definition in read-only environment"))
-           (ct-eval/residualize2 ctem
-             (lambda ()
-               (let ((binding (lookup (id-var-name mid empty-wrap) null-env)))
-                 (case (binding-type binding)
-                   (($module) (do-top-import only? top-ribcage mid (interface-token (binding-value binding))))
-                   ((displaced-lexical) (displaced-lexical-error mid))
-                   (else (syntax-error mid "unknown module"))))))))
-        ((alias-form)
-         (let-values (((new-id old-id) (parse-alias e w ae)))
-           (let ((new-id (wrap new-id w)))
-             (when (displaced-lexical? new-id r) (displaced-lexical-error new-id))
-             (unless (top-ribcage-mutable? top-ribcage)
-               (syntax-error (source-wrap e w ae)
-                 "invalid definition in read-only environment"))
-             (let ((sym (id-sym-name new-id)))
-               (let-values (((valsym bound-id) (top-id-bound-var-name sym (wrap-marks (syntax-object-wrap new-id)) top-ribcage)))
-                 (unless (eq? (id-var-name new-id empty-wrap) valsym)
-                   (syntax-error (source-wrap e w ae)
-                     "definition not permitted"))
-                 (when (read-only-binding? valsym)
-                   (syntax-error (source-wrap e w ae)
-                     "invalid definition of read-only identifier"))
-                 (ct-eval/residualize2 ctem
-                   (lambda ()
-                     (build-cte-install
-                       (make-resolved-id sym (wrap-marks (syntax-object-wrap new-id)) (id-var-name old-id w))
-                       (build-data no-source (make-binding 'do-alias #f))
-                       (top-ribcage-key top-ribcage)))))))))
-        (else
-         (when meta-seen? (syntax-error (source-wrap e w ae) "invalid meta definition"))
-         (if meta?
-             (let ((x (chi-expr type value e r r w ae #t)))
-               (top-level-eval-hook x)
-               (ct-eval/residualize3 ctem void (lambda () x)))
-             (rt-eval/residualize rtem
-               (lambda ()
-                 (chi-expr type value e r r w ae #f)))))))))
-
-(define flatten-exports
-  (lambda (exports)
-    (let loop ((exports exports) (ls '()))
-      (if (null? exports)
-          ls
-          (loop (cdr exports)
-                (if (pair? (car exports))
-                    (loop (car exports) ls)
-                    (cons (car exports) ls)))))))
-
-
-(define-structure (interface marks exports token))
-
-;; leaves interfaces unresolved so that indirect labels can be followed.
-;; (can't resolve until indirect labels have their final value)
-(define make-unresolved-interface
- ; trim out implicit exports
-  (lambda (mid exports)
-    (make-interface
-      (wrap-marks (syntax-object-wrap mid))
-      (list->vector (map (lambda (x) (if (pair? x) (car x) x)) exports))
-      #f)))
-
-(define make-resolved-interface
- ; trim out implicit exports & resolve others to actual top-level symbol
-  (lambda (mid exports token)
-    (make-interface
-      (wrap-marks (syntax-object-wrap mid))
-      (list->vector (map (lambda (x) (id->resolved-id (if (pair? x) (car x) x))) exports))
-      token)))
-
-(define-structure (module-binding type id label imps val exported))
-(define create-module-binding
-  (lambda (type id label imps val)
-    (make-module-binding type id label imps val #f)))
-
-;;; frobs represent body forms
-(define-structure (frob e meta?))
-
-(define chi-top-module
-  (lambda (orig r mr top-ribcage ribcage ctem rtem meta? id exports forms meta-residualize!)
-    (let ((fexports (flatten-exports exports)))
-      (let-values (((r mr bindings inits)
-                    (chi-external ribcage orig
-                      (map (lambda (d) (make-frob d meta?)) forms) r mr ctem exports fexports
-                      meta-residualize!)))
-       ; identify exported identifiers, create ctdefs
-        (let process-exports ((fexports fexports) (ctdefs (lambda () '())))
-          (if (null? fexports)
-             ; remaining bindings are either identified global vars,
-             ; local vars, or local compile-time entities
-             ; dts: type (local/global)
-             ; dvs & des: define lhs & rhs
-              (let process-locals ((bs bindings) (r r) (dts '()) (dvs '()) (des '()))
-                (if (null? bs)
-                    (let ((des (chi-frobs des r mr #f))
-                          (inits (chi-frobs inits r mr #f)))
-                      (build-sequence no-source
-                        (append
-                         ; we wait to establish global compile-time definitions so that
-                         ; expansion of des use local versions of modules and macros
-                         ; in case ctem tells us not to eval ctdefs now.  this means that
-                         ; local code can use exported compile-time values (modules, macros,
-                         ; meta variables) just as it can unexported ones.
-                          (ctdefs)
-                          (list
-                            (ct-eval/residualize2 ctem
-                              (lambda ()
-                                (let ((sym (id-sym-name id)))
-                                  (let* ((token (generate-id sym))
-                                         (b (build-data no-source
-                                              (make-binding '$module
-                                                (make-resolved-interface id exports token)))))
-                                    (let-values (((valsym bound-id)
-                                                  (top-id-bound-var-name sym
-                                                    (wrap-marks (syntax-object-wrap id))
-                                                    top-ribcage)))
-                                      (unless (eq? (id-var-name id empty-wrap) valsym)
-                                        (syntax-error orig
-                                          "definition not permitted"))
-                                      (when (read-only-binding? valsym)
-                                        (syntax-error orig
-                                          "invalid definition of read-only identifier"))
-                                      (build-cte-install bound-id b
-                                        (top-ribcage-key top-ribcage)))))))
-                            (rt-eval/residualize rtem
-                              (lambda ()
-                                (build-top-module no-source dts dvs des
-                                  (if (null? inits)
-                                      (chi-void)
-                                      (build-sequence no-source
-                                        (append inits (list (chi-void))))))))))))
-                    (let ((b (car bs)) (bs (cdr bs)))
-                      (let ((t (module-binding-type b)))
-                        (case (module-binding-type b)
-                          ((define-form)
-                           (let ((label (get-indirect-label (module-binding-label b))))
-                             (if (module-binding-exported b)
-                                 (let ((var (module-binding-id b)))
-                                   (process-locals bs r (cons 'global dts) (cons label dvs)
-                                     (cons (module-binding-val b) des)))
-                                 (let ((var (gen-var (module-binding-id b))))
-                                   (process-locals bs
-                                    ; add lexical bindings only to run-time environment
-                                     (extend-env label (make-binding 'lexical var) r)
-                                     (cons 'local dts) (cons var dvs)
-                                     (cons (module-binding-val b) des))))))
-                          ((ctdefine-form define-syntax-form $module-form alias-form) (process-locals bs r dts dvs des))
-                          (else (error 'sc-expand-internal "unexpected module binding type ~s" t)))))))
-              (let ((id (car fexports)) (fexports (cdr fexports)))
-                (let loop ((bs bindings))
-                  (if (null? bs)
-                     ; must be rexport from an imported module
-                      (process-exports fexports ctdefs)
-                      (let ((b (car bs)) (bs (cdr bs)))
-                       ; following formerly used bound-id=?, but free-id=? can prevent false positives
-                       ; and is okay since the substitutions have already been applied
-                        (if (free-id=? (module-binding-id b) id)
-                            (if (module-binding-exported b)
-                                (process-exports fexports ctdefs)
-                                (let* ((t (module-binding-type b))
-                                       (label (module-binding-label b))
-                                       (imps (module-binding-imps b))
-                                       (fexports (append imps fexports)))
-                                  (set-module-binding-exported! b #t)
-                                  (case t
-                                    ((define-form)
-                                     (let ((sym (generate-id (id-sym-name id))))
-                                       (set-indirect-label! label sym)
-                                       (process-exports fexports ctdefs)))
-                                    ((ctdefine-form)
-                                     (let ((b (module-binding-val b)))
-                                       (process-exports fexports
-                                         (lambda ()
-                                           (let ((sym (binding-value b)))
-                                             (set-indirect-label! label sym)
-                                             (cons (ct-eval/residualize3 ctem
-                                                     (lambda () (put-cte-hook sym b))
-                                                     (lambda () (build-cte-install sym (build-data no-source b) #f)))
-                                                   (ctdefs)))))))
-                                    ((define-syntax-form)
-                                     (let ((sym (generate-id (id-sym-name id))))
-                                       (process-exports fexports
-                                         (lambda () 
-                                           (let ((local-label (get-indirect-label label)))
-                                             (set-indirect-label! label sym)
-                                             (cons
-                                               (ct-eval/residualize3 ctem
-                                                 (lambda () (put-cte-hook sym (car (module-binding-val b))))
-                                                 (lambda () (build-cte-install sym (cdr (module-binding-val b)) #f)))
-                                               (ctdefs)))))))
-                                    (($module-form)
-                                     (let ((sym (generate-id (id-sym-name id)))
-                                           (exports (module-binding-val b)))
-                                       (process-exports (append (flatten-exports exports) fexports)
-                                         (lambda ()
-                                           (set-indirect-label! label sym)
-                                           (let ((rest (ctdefs))) ; set indirect labels before resolving
-                                             (let ((x (make-binding '$module (make-resolved-interface id exports sym))))
-                                               (cons (ct-eval/residualize3 ctem
-                                                       (lambda () (put-cte-hook sym x))
-                                                       (lambda () (build-cte-install sym (build-data no-source x) #f)))
-                                                     rest)))))))
-                                    ((alias-form)
-                                     (process-exports
-                                       fexports
-                                       (lambda ()
-                                         (let ((rest (ctdefs))) ; set indirect labels before resolving
-                                           (when (indirect-label? label)
-                                             (unless (symbol? (get-indirect-label label))
-                                               (syntax-error (module-binding-id b) "unexported target of alias")))
-                                           rest))))
-                                    (else (error 'sc-expand-internal "unexpected module binding type ~s" t)))))
-                            (loop bs))))))))))))
-
-(define id-set-diff
-  (lambda (exports defs)
-    (cond
-      ((null? exports) '())
-      ((bound-id-member? (car exports) defs) (id-set-diff (cdr exports) defs))
-      (else (cons (car exports) (id-set-diff (cdr exports) defs))))))
-
-(define check-module-exports
-  ; After processing the definitions of a module this is called to verify that the
-  ; module has defined or imported each exported identifier.  Because ids in fexports are
-  ; wrapped with the given ribcage, they will contain substitutions for anything defined
-  ; or imported here.  These subsitutions can be used by do-import! and do-import-top! to
-  ; provide access to reexported bindings, for example.
-  (lambda (source-exp fexports ids)
-    (define defined?
-      (lambda (e ids)
-        (ormap (lambda (x)
-                 (if (import-interface? x)
-                     (let ((x.iface (import-interface-interface x))
-                           (x.new-marks (import-interface-new-marks x)))
-                       (cond
-                         ((interface-token x.iface) =>
-                          (lambda (token)
-                            (lookup-import-binding-name (id-sym-name e) (id-marks e) token x.new-marks)))
-                         (else
-                          (let ((v (interface-exports x.iface)))
-                            (let lp ((i (fx- (vector-length v) 1)))
-                              (and (fx>= i 0)
-                                   (or (let ((id (vector-ref v i)))
-                                         (help-bound-id=?
-                                           (id-sym-name id)
-                                           (join-marks x.new-marks (id-marks id))
-                                           (id-sym-name e) (id-marks e)))
-                                       (lp (fx- i 1)))))))))
-                     (bound-id=? e x)))
-               ids)))
-    (let loop ((fexports fexports) (missing '()))
-      (if (null? fexports)
-          (unless (null? missing)
-            (syntax-error (car missing)
-              (if (fx= (length missing) 1)
-                  "missing definition for export"
-                  "missing definition for multiple exports, including")))
-          (let ((e (car fexports)) (fexports (cdr fexports)))
-            (if (defined? e ids)
-                (loop fexports missing)
-                (loop fexports (cons e missing))))))))
-
-(define check-defined-ids
-  (lambda (source-exp ls)
-    (define vfold
-      (lambda (v p cls)
-        (let ((len (vector-length v)))
-          (let lp ((i 0) (cls cls))
-            (if (fx= i len)
-                cls
-                (lp (fx+ i 1) (p (vector-ref v i) cls)))))))
-    (define conflicts
-      (lambda (x y cls)
-        (if (import-interface? x)
-            (let ((x.iface (import-interface-interface x))
-                  (x.new-marks (import-interface-new-marks x)))
-              (if (import-interface? y)
-                  (let ((y.iface (import-interface-interface y))
-                        (y.new-marks (import-interface-new-marks y)))
-                    (let ((xe (interface-exports x.iface)) (ye (interface-exports y.iface)))
-                      (if (fx> (vector-length xe) (vector-length ye))
-                          (vfold ye
-                            (lambda (id cls)
-                              (id-iface-conflicts id y.new-marks x.iface x.new-marks cls)) cls)
-                          (vfold xe
-                            (lambda (id cls)
-                              (id-iface-conflicts id x.new-marks y.iface y.new-marks cls)) cls))))
-                  (id-iface-conflicts y '() x.iface x.new-marks cls)))
-            (if (import-interface? y)
-                (let ((y.iface (import-interface-interface y))
-                      (y.new-marks (import-interface-new-marks y)))
-                  (id-iface-conflicts x '() y.iface y.new-marks cls))
-                (if (bound-id=? x y) (cons x cls) cls)))))
-     (define id-iface-conflicts
-       (lambda (id id.new-marks iface iface.new-marks cls)
-         (let ((id.sym (id-sym-name id))
-               (id.marks (join-marks id.new-marks (id-marks id))))
-           (cond
-             ((interface-token iface) =>
-              (lambda (token)
-                (if (lookup-import-binding-name id.sym id.marks token iface.new-marks)
-                    (cons id cls)
-                    cls)))
-             (else
-              (vfold (interface-exports iface)
-                     (lambda (*id cls)
-                       (let ((*id.sym (id-sym-name *id))
-                             (*id.marks (join-marks iface.new-marks (id-marks *id))))
-                         (if (help-bound-id=? *id.sym *id.marks id.sym id.marks)
-                             (cons *id cls)
-                             cls)))
-                     cls))))))
-     (unless (null? ls)
-       (let lp ((x (car ls)) (ls (cdr ls)) (cls '()))
-         (if (null? ls)
-             (unless (null? cls)
-               (let ((cls (syntax-object->datum cls)))
-                 (syntax-error source-exp "duplicate definition for "
-                  (symbol->string (car cls))
-                   " in")))
-             (let lp2 ((ls2 ls) (cls cls))
-               (if (null? ls2)
-                   (lp (car ls) (cdr ls) cls)
-                   (lp2 (cdr ls2) (conflicts x (car ls2) cls)))))))))
-
-(define chi-external
-  (lambda (ribcage source-exp body r mr ctem exports fexports meta-residualize!)
-    (define return
-      (lambda (r mr bindings ids inits)
-        (check-defined-ids source-exp ids)
-        (check-module-exports source-exp fexports ids)
-        (values r mr bindings inits)))
-    (define get-implicit-exports
-      (lambda (id)
-        (let f ((exports exports))
-          (if (null? exports)
-              '()
-              (if (and (pair? (car exports)) (bound-id=? id (caar exports)))
-                  (flatten-exports (cdar exports))
-                  (f (cdr exports)))))))
-    (define update-imp-exports
-      (lambda (bindings exports)
-        (let ((exports (map (lambda (x) (if (pair? x) (car x) x)) exports)))
-          (map (lambda (b)
-                 (let ((id (module-binding-id b)))
-                   (if (not (bound-id-member? id exports))
-                       b
-                       (create-module-binding
-                         (module-binding-type b)
-                         id
-                         (module-binding-label b)
-                         (append (get-implicit-exports id) (module-binding-imps b))
-                         (module-binding-val b)))))
-               bindings))))
-    (let parse ((body body) (r r) (mr mr) (ids '()) (bindings '()) (inits '()) (meta-seen? #f))
-      (if (null? body)
-          (return r mr bindings ids inits)
-          (let* ((fr (car body)) (e (frob-e fr)) (meta? (frob-meta? fr)))
-            (let-values (((type value e w ae) (syntax-type e r empty-wrap no-source ribcage)))
-              (case type
-                ((define-form)
-                 (let-values (((id rhs w) (parse-define e w ae)))
-                   (let* ((id (wrap id w))
-                          (label (gen-indirect-label))
-                          (sym (generate-id (id-sym-name id)))
-                          (imps (get-implicit-exports id)))
-                     (extend-ribcage! ribcage id label)
-                     (cond
-                       (meta?
-                        (let* ((sym (generate-id (id-sym-name id)))
-                               (b (make-binding 'meta-variable sym)))
-                         ; add meta bindings only to meta environment
-                          (let ((mr (extend-env (get-indirect-label label) b mr)))
-                            (let ((exp (chi rhs mr mr w #t)))
-                              (define-top-level-value-hook sym (top-level-eval-hook exp))
-                              (meta-residualize!
-                                (ct-eval/residualize3 ctem
-                                  void
-                                  (lambda () (build-global-definition no-source sym exp))))
-                              (parse (cdr body) r mr
-                                (cons id ids)
-                                (cons (create-module-binding 'ctdefine-form id label imps b) bindings)
-                                inits
-                                #f)))))
-                       (else
-                        (parse (cdr body) r mr
-                          (cons id ids)
-                          (cons (create-module-binding type id label
-                                  imps (make-frob (wrap rhs w) meta?))
-                                bindings)
-                          inits
-                          #f))))))
-                ((define-syntax-form)
-                 (let-values (((id rhs w) (parse-define-syntax e w ae)))
-                   (let* ((id (wrap id w))
-                          (label (gen-indirect-label))
-                          (imps (get-implicit-exports id))
-                          (exp (chi rhs mr mr w #t)))
-                     (extend-ribcage! ribcage id label)
-                     (let ((l (get-indirect-label label)) (b (defer-or-eval-transformer top-level-eval-hook exp)))
-                       (parse (cdr body)
-                         (extend-env l b r)
-                         (extend-env l b mr)
-                         (cons id ids)
-                         (cons (create-module-binding type id label imps (cons b exp))
-                               bindings)
-                         inits
-                         #f)))))
-                (($module-form)
-                 (let* ((*ribcage (make-empty-ribcage))
-                        (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
-                   (let-values (((orig id *exports forms) (parse-module e w ae *w)))
-                     (let-values (((r mr *bindings *inits)
-                                   (chi-external *ribcage orig
-                                     (map (lambda (d) (make-frob d meta?)) forms)
-                                     r mr ctem *exports (flatten-exports *exports) meta-residualize!)))
-                       (let ((iface (make-unresolved-interface id *exports))
-                             (bindings (append *bindings bindings))
-                             (inits (append inits *inits))
-                             (label (gen-indirect-label))
-                             (imps (get-implicit-exports id)))
-                         (extend-ribcage! ribcage id label)
-                         (let ((l (get-indirect-label label)) (b (make-binding '$module iface)))
-                           (parse (cdr body)
-                             (extend-env l b r)
-                             (extend-env l b mr)
-                             (cons id ids)
-                             (cons (create-module-binding type id label imps *exports) bindings)
-                             inits
-                             #f)))))))
-               (($import-form)
-                (let-values (((orig only? mid) (parse-import e w ae)))
-                  (let ((mlabel (id-var-name mid empty-wrap)))
-                    (let ((binding (lookup mlabel r)))
-                      (case (binding-type binding)
-                        (($module)
-                         (let* ((iface (binding-value binding))
-                                (import-iface (make-import-interface iface (import-mark-delta mid iface))))
-                           (when only? (extend-ribcage-barrier! ribcage mid))
-                           (do-import! import-iface ribcage)
-                           (parse (cdr body) r mr
-                             (cons import-iface ids)
-                             (update-imp-exports bindings (vector->list (interface-exports iface)))
-                             inits
-                             #f)))
-                        ((displaced-lexical) (displaced-lexical-error mid))
-                        (else (syntax-error mid "unknown module")))))))
-               ((alias-form)
-                (let-values (((new-id old-id) (parse-alias e w ae)))
-                  (let* ((new-id (wrap new-id w))
-                         (label (id-var-name-loc old-id w))
-                         (imps (get-implicit-exports new-id)))
-                    (extend-ribcage! ribcage new-id label)
-                    (parse (cdr body) r mr
-                      (cons new-id ids)
-                      (cons (create-module-binding type new-id label imps #f)
-                            bindings)
-                      inits
-                      #f))))
-                ((begin-form)
-                 (parse (let f ((forms (parse-begin e w ae #t)))
-                          (if (null? forms)
-                              (cdr body)
-                              (cons (make-frob (wrap (car forms) w) meta?)
-                                    (f (cdr forms)))))
-                   r mr ids bindings inits #f))
-                ((eval-when-form)
-                 (let-values (((when-list forms) (parse-eval-when e w ae)))
-                    (parse (if (memq 'eval when-list) ; mode set is implicitly (E)
-                               (let f ((forms forms))
-                                 (if (null? forms)
-                                     (cdr body)
-                                     (cons (make-frob (wrap (car forms) w) meta?)
-                                           (f (cdr forms)))))
-                               (cdr body))
-                      r mr ids bindings inits #f)))
-                ((meta-form)
-                 (parse (cons (make-frob (wrap (parse-meta e w ae) w) #t)
-                              (cdr body))
-                   r mr ids bindings inits #t))
-                ((local-syntax-form)
-                 (let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
-                   (parse (let f ((forms forms))
-                            (if (null? forms)
-                                (cdr body)
-                                (cons (make-frob (wrap (car forms) w) meta?)
-                                      (f (cdr forms)))))
-                     r mr ids bindings inits #f)))
-                (else ; found an init expression
-                 (when meta-seen? (syntax-error (source-wrap e w ae) "invalid meta definition"))
-                 (let f ((body (cons (make-frob (source-wrap e w ae) meta?) (cdr body))))
-                   (if (or (null? body) (not (frob-meta? (car body))))
-                       (return r mr bindings ids (append inits body))
-                       (begin
-                        ; expand and eval meta inits for effect only
-                         (let ((x (chi-meta-frob (car body) mr)))
-                           (top-level-eval-hook x)
-                           (meta-residualize! (ct-eval/residualize3 ctem void (lambda () x))))
-                         (f (cdr body)))))))))))))
-
-(define vmap
-  (lambda (fn v)
-    (do ((i (fx- (vector-length v) 1) (fx- i 1))
-         (ls '() (cons (fn (vector-ref v i)) ls)))
-        ((fx< i 0) ls))))
-
-(define vfor-each
-  (lambda (fn v)
-    (let ((len (vector-length v)))
-      (do ((i 0 (fx+ i 1)))
-          ((fx= i len))
-        (fn (vector-ref v i))))))
-
-(define do-top-import
-  (lambda (import-only? top-ribcage mid token)
-   ; silently treat import-only like regular import at top level
-    (build-cte-install mid
-      (build-data no-source
-        (make-binding 'do-import token))
-      (top-ribcage-key top-ribcage))))
-
-(define update-mode-set
-  (let ((table
-         '((L (load . L) (compile . C) (visit . V) (revisit . R) (eval . -))
-           (C (load . -) (compile . -) (visit . -) (revisit . -) (eval . C))
-           (V (load . V) (compile . C) (visit . V) (revisit . -) (eval . -))
-           (R (load . R) (compile . C) (visit . -) (revisit . R) (eval . -))
-           (E (load . -) (compile . -) (visit . -) (revisit . -) (eval . E)))))
-    (lambda (when-list mode-set)
-      (define remq
-        (lambda (x ls)
-          (if (null? ls)
-              '()
-              (if (eq? (car ls) x)
-                  (remq x (cdr ls))
-                  (cons (car ls) (remq x (cdr ls)))))))
-      (remq '-
-        (apply append
-          (map (lambda (m)
-                 (let ((row (cdr (assq m table))))
-                   (map (lambda (s) (cdr (assq s row)))
-                        when-list)))
-               mode-set))))))
-
-(define initial-mode-set
-  (lambda (when-list compiling-a-file)
-    (apply append
-      (map (lambda (s)
-             (if compiling-a-file
-                 (case s
-                   ((compile) '(C))
-                   ((load) '(L))
-                   ((visit) '(V))
-                   ((revisit) '(R))
-                   (else '()))
-                 (case s
-                   ((eval) '(E))
-                   (else '()))))
-           when-list))))
-
-(define rt-eval/residualize
-  (lambda (rtem thunk)
-    (if (memq 'E rtem)
-        (thunk)
-        (let ((thunk (if (memq 'C rtem)
-                         (let ((x (thunk)))
-                           (top-level-eval-hook x)
-                           (lambda () x))
-                         thunk)))
-          (if (memq 'V rtem)
-              (if (or (memq 'L rtem) (memq 'R rtem))
-                  (thunk) ; visit-revisit
-                  (build-visit-only (thunk)))
-              (if (or (memq 'L rtem) (memq 'R rtem))
-                  (build-revisit-only (thunk))
-                  (chi-void)))))))
-
-(define ct-eval/residualize2
-  (lambda (ctem thunk)
-    (let ((t #f))
-      (ct-eval/residualize3 ctem
-        (lambda ()
-          (unless t (set! t (thunk)))
-          (top-level-eval-hook t))
-        (lambda () (or t (thunk)))))))
-
-(define ct-eval/residualize3
-  (lambda (ctem eval-thunk residualize-thunk)
-    (if (memq 'E ctem)
-        (begin (eval-thunk) (chi-void))
-        (begin
-          (when (memq 'C ctem) (eval-thunk))
-          (if (memq 'R ctem)
-              (if (or (memq 'L ctem) (memq 'V ctem))
-                  (residualize-thunk) ; visit-revisit
-                  (build-revisit-only (residualize-thunk)))
-              (if (or (memq 'L ctem) (memq 'V ctem))
-                  (build-visit-only (residualize-thunk))
-                  (chi-void)))))))
-
-(define chi-frobs
-  (lambda (frob* r mr m?)
-    (map (lambda (x) (chi (frob-e x) r mr empty-wrap m?)) frob*)))
-
-(define chi-meta-frob
-  (lambda (x mr)
-    (chi (frob-e x) mr mr empty-wrap #t)))
-
-(define chi-sequence
-  (lambda (body r mr w ae m?)
-    (build-sequence ae
-      (let dobody ((body body))
-        (if (null? body)
-            '()
-            (let ((first (chi (car body) r mr w m?)))
-              (cons first (dobody (cdr body)))))))))
-
-(define chi
-  (lambda (e r mr w m?)
-    (let-values (((type value e w ae) (syntax-type e r w no-source #f)))
-      (chi-expr type value e r mr w ae m?))))
-
-(define chi-expr
-  (lambda (type value e r mr w ae m?)
-    (case type
-      ((lexical)
-       (build-lexical-reference 'value ae value))
-      ;;; AZIZ
-      ((core-primitive)
-       (build-primref ae value))
-      ((core) (value e r mr w ae m?))
-      ((lexical-call)
-       (chi-application
-         (build-lexical-reference 'fun
-           (let ((x (car e)))
-             (if (syntax-object? x) (syntax-object-expression x) x))
-           value)
-         e r mr w ae m?))
-      ((constant) (build-data ae (strip (source-wrap e w ae) empty-wrap)))
-      ((global) (build-global-reference ae value))
-      ((meta-variable)
-       (if m?
-           (build-global-reference ae value)
-           (displaced-lexical-error (source-wrap e w ae))))
-      ((call) (chi-application (chi (car e) r mr w m?) e r mr w ae m?))
-      ((begin-form) (chi-sequence (parse-begin e w ae #f) r mr w ae m?))
-      ((local-syntax-form)
-       (let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
-         (chi-sequence forms r mr w ae m?)))
-      ((eval-when-form)
-       (let-values (((when-list forms) (parse-eval-when e w ae)))
-         (if (memq 'eval when-list) ; mode set is implicitly (E)
-             (chi-sequence forms r mr w ae m?)
-             (chi-void))))
-      ((meta-form)
-       (syntax-error (source-wrap e w ae) "invalid context for meta definition"))
-      ((define-form)
-       (parse-define e w ae)
-       (syntax-error (source-wrap e w ae) "invalid context for definition"))
-      ((define-syntax-form)
-       (parse-define-syntax e w ae)
-       (syntax-error (source-wrap e w ae) "invalid context for definition"))
-      (($module-form)
-       (let-values (((orig id exports forms) (parse-module e w ae w)))
-         (syntax-error orig "invalid context for definition")))
-      (($import-form)
-       (let-values (((orig only? mid) (parse-import e w ae)))
-         (syntax-error orig "invalid context for definition")))
-      ((alias-form)
-       (parse-alias e w ae)
-       (syntax-error (source-wrap e w ae) "invalid context for definition"))
-      ((syntax)
-       (syntax-error (source-wrap e w ae)
-         "reference to pattern variable outside syntax form"))
-      ((displaced-lexical) (displaced-lexical-error (source-wrap e w ae)))
-      (else (syntax-error (source-wrap e w ae))))))
-
-(define chi-application
-  (lambda (x e r mr w ae m?)
-    (syntax-case e ()
-      ((e0 e1 ...)
-       (build-application ae x
-         (map (lambda (e) (chi e r mr w m?)) (syntax (e1 ...)))))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define chi-set!
-  (lambda (e r w ae rib)
-    (syntax-case e ()
-      ((_ id val)
-       (id? (syntax id))
-       (let ((n (id-var-name (syntax id) w)))
-         (let ((b (lookup n r)))
-           (case (binding-type b)
-             ((macro!)
-              (let ((id (wrap (syntax id) w)) (val (wrap (syntax val) w)))
-                (syntax-type (chi-macro (binding-value b)
-                               `(,(syntax set!) ,id ,val)
-                               r empty-wrap #f rib) r empty-wrap #f rib)))
-             (else
-              (values 'core
-                (lambda (e r mr w ae m?)
-                 ; repeat lookup in case we were first expression (init) in
-                 ; module or lambda body.  we repeat id-var-name as well,
-                 ; although this is only necessary if we allow inits to
-                 ; preced definitions
-                  (let ((val (chi (syntax val) r mr w m?))
-                        (n (id-var-name (syntax id) w)))
-                    (let ((b (lookup n r)))
-                      (case (binding-type b)
-                        ((lexical) (build-lexical-assignment ae (binding-value b) val))
-                        ((global)
-                         (let ((sym (binding-value b)))
-                           (when (read-only-binding? n)
-                             (syntax-error (source-wrap e w ae)
-                               "invalid assignment to read-only variable"))
-                           (build-global-assignment ae sym val)))
-                        ((meta-variable)
-                         (if m?
-                             (build-global-assignment ae (binding-value b) val)
-                             (displaced-lexical-error (wrap (syntax id) w))))
-                        ((displaced-lexical)
-                         (displaced-lexical-error (wrap (syntax id) w)))
-                        (else (syntax-error (source-wrap e w ae)))))))
-                e w ae))))))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-
-
-
-(define chi-macro
-  (lambda (p e r w ae rib)
-    (define rebuild-macro-output
-      (lambda (x m)
-        (cond ((pair? x)
-               (cons (rebuild-macro-output (car x) m)
-                     (rebuild-macro-output (cdr x) m)))
-              ((syntax-object? x)
-               (let ((w (syntax-object-wrap x)))
-                 (let ((ms (wrap-marks w)) (s (wrap-subst w)))
-                   (make-syntax-object (syntax-object-expression x)
-                     (if (and (pair? ms) (eq? (car ms) the-anti-mark))
-                         (make-wrap (cdr ms) (cdr s))
-                         (make-wrap (cons m ms)
-                           (if rib
-                               (cons rib (cons 'shift s))
-                               (cons 'shift s))))))))
-              ((vector? x)
-               (let* ((n (vector-length x)) (v (make-vector n)))
-                 (do ((i 0 (fx+ i 1)))
-                     ((fx= i n) v)
-                     (vector-set! v i
-                       (rebuild-macro-output (vector-ref x i) m)))))
-              ((symbol? x)
-               (syntax-error (source-wrap e w ae)
-                 "encountered raw symbol "
-                (symbol->string x)
-                 " in output of macro"))
-              (else x))))
-    (rebuild-macro-output
-      (let ((out (p (source-wrap e (anti-mark w) ae))))
-        (if (procedure? out)
-            (out (lambda (id)
-                   (unless (identifier? id)
-                     (syntax-error id
-                       "environment argument is not an identifier"))
-                   (lookup (id-var-name id empty-wrap) r)))
-            out))
-      (new-mark))))
-
-(define chi-body
-  (lambda (body outer-form r mr w m?)
-    (let* ((ribcage (make-empty-ribcage))
-           (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))
-           (body (map (lambda (x) (make-frob (wrap x w) #f)) body)))
-      (let-values (((r mr exprs ids vars vals inits)
-                    (chi-internal ribcage outer-form body r mr m?)))
-        (when (null? exprs) (syntax-error outer-form "no expressions in body"))
-        (build-body no-source
-          (reverse vars) (chi-frobs (reverse vals) r mr m?)
-          (build-sequence no-source
-            (chi-frobs (append inits exprs) r mr m?)))))))
-
-(define chi-internal
-  ;; In processing the forms of the body, we create a new, empty wrap.
-  ;; This wrap is augmented (destructively) each time we discover that
-  ;; the next form is a definition.  This is done:
-  ;;
-  ;;   (1) to allow the first nondefinition form to be a call to
-  ;;       one of the defined ids even if the id previously denoted a
-  ;;       definition keyword or keyword for a macro expanding into a
-  ;;       definition;
-  ;;   (2) to prevent subsequent definition forms (but unfortunately
-  ;;       not earlier ones) and the first nondefinition form from
-  ;;       confusing one of the bound identifiers for an auxiliary
-  ;;       keyword; and
-  ;;   (3) so that we do not need to restart the expansion of the
-  ;;       first nondefinition form, which is problematic anyway
-  ;;       since it might be the first element of a begin that we
-  ;;       have just spliced into the body (meaning if we restarted,
-  ;;       we'd really need to restart with the begin or the macro
-  ;;       call that expanded into the begin, and we'd have to give
-  ;;       up allowing (begin <defn>+ <expr>+), which is itself
-  ;;       problematic since we don't know if a begin contains only
-  ;;       definitions until we've expanded it).
-  ;;
-  ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
-  ;; into the body.
-  ;;
-  ;; outer-form is fully wrapped w/source
-  (lambda (ribcage source-exp body r mr m?)
-    (define return
-      (lambda (r mr exprs ids vars vals inits)
-        (check-defined-ids source-exp ids)
-        (values r mr exprs ids vars vals inits)))
-    (let parse ((body body) (r r) (mr mr) (ids '()) (vars '()) (vals '()) (inits '()) (meta-seen? #f))
-      (if (null? body)
-          (return r mr body ids vars vals inits)
-          (let* ((fr (car body)) (e (frob-e fr)) (meta? (frob-meta? fr)))
-            (let-values (((type value e w ae) (syntax-type e r empty-wrap no-source ribcage)))
-              (case type
-                ((define-form)
-                 (let-values (((id rhs w) (parse-define e w ae)))
-                   (let ((id (wrap id w)) (label (gen-label)))
-                     (cond
-                       (meta?
-                        (let ((sym (generate-id (id-sym-name id))))
-                          (extend-ribcage! ribcage id label)
-                         ; add meta bindings only to meta environment
-                         ; so visible only to next higher level and beyond
-                          (let ((mr (extend-env label (make-binding 'meta-variable sym) mr)))
-                            (define-top-level-value-hook sym
-                              (top-level-eval-hook (chi rhs mr mr w #t)))
-                            (parse (cdr body) r mr (cons id ids) vars vals inits #f))))
-                       (else
-                        (let ((var (gen-var id)))
-                          (extend-ribcage! ribcage id label)
-                         ; add lexical bindings only to run-time environment
-                          (parse (cdr body)
-                            (extend-env label (make-binding 'lexical var) r)
-                            mr
-                            (cons id ids)
-                            (cons var vars)
-                            (cons (make-frob (wrap rhs w) meta?) vals)
-                            inits
-                            #f)))))))
-                ((define-syntax-form)
-                 (let-values (((id rhs w) (parse-define-syntax e w ae)))
-                   (let ((id (wrap id w))
-                         (label (gen-label))
-                         (exp (chi rhs mr mr w #t)))
-                     (extend-ribcage! ribcage id label)
-                     (let ((b (defer-or-eval-transformer local-eval-hook exp)))
-                       (parse (cdr body)
-                         (extend-env label b r) (extend-env label b mr)
-                         (cons id ids) vars vals inits #f)))))
-                (($module-form)
-                 (let* ((*ribcage (make-empty-ribcage))
-                        (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
-                   (let-values (((orig id exports forms) (parse-module e w ae *w)))
-                     (let-values (((r mr *body *ids *vars *vals *inits)
-                                   (chi-internal *ribcage orig
-                                     (map (lambda (d) (make-frob d meta?)) forms)
-                                     r mr m?)))
-                      ; valid bound ids checked already by chi-internal
-                       (check-module-exports source-exp (flatten-exports exports) *ids)
-                       (let ((iface (make-resolved-interface id exports #f))
-                             (vars (append *vars vars))
-                             (vals (append *vals vals))
-                             (inits (append inits *inits *body))
-                             (label (gen-label)))
-                         (extend-ribcage! ribcage id label)
-                         (let ((b (make-binding '$module iface)))
-                           (parse (cdr body)
-                             (extend-env label b r) (extend-env label b mr)
-                             (cons id ids) vars vals inits #f)))))))
-               (($import-form)
-                (let-values (((orig only? mid) (parse-import e w ae)))
-                  (let ((mlabel (id-var-name mid empty-wrap)))
-                    (let ((binding (lookup mlabel r)))
-                      (case (binding-type binding)
-                        (($module)
-                         (let* ((iface (binding-value binding))
-                                (import-iface (make-import-interface iface (import-mark-delta mid iface))))
-                           (when only? (extend-ribcage-barrier! ribcage mid))
-                           (do-import! import-iface ribcage)
-                           (parse (cdr body) r mr (cons import-iface ids) vars vals inits #f)))
-                        ((displaced-lexical) (displaced-lexical-error mid))
-                        (else (syntax-error mid "unknown module")))))))
-                ((alias-form)
-                 (let-values (((new-id old-id) (parse-alias e w ae)))
-                   (let ((new-id (wrap new-id w)))
-                     (extend-ribcage! ribcage new-id (id-var-name-loc old-id w))
-                     (parse (cdr body) r mr
-                       (cons new-id ids)
-                       vars
-                       vals
-                       inits
-                       #f))))
-                ((begin-form)
-                 (parse (let f ((forms (parse-begin e w ae #t)))
-                          (if (null? forms)
-                              (cdr body)
-                              (cons (make-frob (wrap (car forms) w) meta?)
-                                    (f (cdr forms)))))
-                   r mr ids vars vals inits #f))
-                ((eval-when-form)
-                 (let-values (((when-list forms) (parse-eval-when e w ae)))
-                   (parse (if (memq 'eval when-list) ; mode set is implicitly (E)
-                              (let f ((forms forms))
-                                (if (null? forms)
-                                    (cdr body)
-                                    (cons (make-frob (wrap (car forms) w) meta?)
-                                          (f (cdr forms)))))
-                              (cdr body))
-                     r mr ids vars vals inits #f)))
-                ((meta-form)
-                 (parse (cons (make-frob (wrap (parse-meta e w ae) w) #t)
-                              (cdr body))
-                   r mr ids vars vals inits #t))
-                ((local-syntax-form)
-                 (let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
-                   (parse (let f ((forms forms))
-                            (if (null? forms)
-                                (cdr body)
-                                (cons (make-frob (wrap (car forms) w) meta?)
-                                      (f (cdr forms)))))
-                     r mr ids vars vals inits #f)))
-                (else ; found a non-definition
-                 (when meta-seen? (syntax-error (source-wrap e w ae) "invalid meta definition"))
-                 (let f ((body (cons (make-frob (source-wrap e w ae) meta?) (cdr body))))
-                   (if (or (null? body) (not (frob-meta? (car body))))
-                       (return r mr body ids vars vals inits)
-                       (begin
-                        ; expand meta inits for effect only
-                         (top-level-eval-hook (chi-meta-frob (car body) mr))
-                         (f (cdr body)))))))))))))
-
-(define import-mark-delta
- ; returns list of marks layered on top of module id beyond those
- ; cached in the interface
-  (lambda (mid iface)
-    (diff-marks (id-marks mid) (interface-marks iface))))
-
-(define lookup-import-label
-  (lambda (id)
-    (let ((label (id-var-name-loc id empty-wrap)))
-      (unless label
-        (syntax-error id "exported identifier not visible"))
-      label)))
-  
-(define do-import!
-  (lambda (import-iface ribcage)
-    (let ((ie (interface-exports (import-interface-interface import-iface))))
-      (if (fx<= (vector-length ie) 20)
-          (let ((new-marks (import-interface-new-marks import-iface)))
-            (vfor-each
-              (lambda (id)
-                (import-extend-ribcage! ribcage new-marks id
-                  (lookup-import-label id)))
-              ie))
-          (extend-ribcage-subst! ribcage import-iface)))))
-
-(define parse-module
-  (lambda (e w ae *w)
-    (define listify
-      (lambda (exports)
-        (if (null? exports)
-            '()
-            (cons (syntax-case (car exports) ()
-                    ((ex ...) (listify (syntax (ex ...))))
-                    (x (if (id? (syntax x))
-                           (wrap (syntax x) *w)
-                           (syntax-error (source-wrap e w ae)
-                             "invalid exports list in"))))
-                  (listify (cdr exports))))))
-    (syntax-case e ()
-      ((_ orig mid (ex ...) form ...)
-       (id? (syntax mid))
-      ; id receives old wrap so it won't be confused with id of same name
-      ; defined within the module
-       (values (syntax orig) (wrap (syntax mid) w) (listify (syntax (ex ...))) (map (lambda (x) (wrap x *w)) (syntax (form ...)))))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-import
-  (lambda (e w ae)
-    (syntax-case e ()
-      ((_ orig #t mid)
-       (id? (syntax mid))
-       (values (syntax orig) #t (wrap (syntax mid) w)))
-      ((_ orig #f mid)
-       (id? (syntax mid))
-       (values (syntax orig) #f (wrap (syntax mid) w)))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-define
-  (lambda (e w ae)
-    (syntax-case e ()
-      ((_ name val)
-       (id? (syntax name))
-       (values (syntax name) (syntax val) w))
-      ((_ (name . args) e1 e2 ...)
-       (and (id? (syntax name))
-            (valid-bound-ids? (lambda-var-list (syntax args))))
-       (values (wrap (syntax name) w)
-               (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
-               empty-wrap))
-      ((_ name)
-       (id? (syntax name))
-       (values (wrap (syntax name) w) (syntax (void)) empty-wrap))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-define-syntax
-  (lambda (e w ae)
-    (syntax-case e ()
-      ((_ (name id) e1 e2 ...)
-       (and (id? (syntax name)) (id? (syntax id)))
-       (values (wrap (syntax name) w)
-               `(,(syntax lambda) ,(wrap (syntax (id)) w)
-                   ,@(wrap (syntax (e1 e2 ...)) w))
-               empty-wrap))
-      ((_ name val)
-       (id? (syntax name))
-       (values (syntax name) (syntax val) w))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-meta
-  (lambda (e w ae)
-    (syntax-case e ()
-      ((_ . form) (syntax form))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-eval-when
-  (lambda (e w ae)
-    (syntax-case e ()
-      ((_ (x ...) e1 e2 ...)
-       (values (chi-when-list (syntax (x ...)) w) (syntax (e1 e2 ...))))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-alias
-  (lambda (e w ae)
-    (syntax-case e ()
-      ((_ new-id old-id)
-       (and (id? (syntax new-id)) (id? (syntax old-id)))
-       (values (syntax new-id) (syntax old-id)))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-begin
-  (lambda (e w ae empty-okay?)
-    (syntax-case e ()
-      ((_) empty-okay? '())
-      ((_ e1 e2 ...) (syntax (e1 e2 ...)))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define chi-lambda-clause
-  (lambda (e c r mr w m?)
-    (syntax-case c ()
-      (((id ...) e1 e2 ...)
-       (let ((ids (syntax (id ...))))
-         (if (not (valid-bound-ids? ids))
-             (syntax-error e "invalid parameter list in")
-             (let ((labels (gen-labels ids))
-                   (new-vars (map gen-var ids)))
-               (values
-                 new-vars
-                 (chi-body (syntax (e1 e2 ...))
-                           e
-                           (extend-var-env* labels new-vars r)
-                           mr
-                           (make-binding-wrap ids labels w)
-                           m?))))))
-      ((ids e1 e2 ...)
-       (let ((old-ids (lambda-var-list (syntax ids))))
-         (if (not (valid-bound-ids? old-ids))
-             (syntax-error e "invalid parameter list in")
-             (let ((labels (gen-labels old-ids))
-                   (new-vars (map gen-var old-ids)))
-               (values
-                 (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
-                   (if (null? ls1)
-                       ls2
-                       (f (cdr ls1) (cons (car ls1) ls2))))
-                 (chi-body (syntax (e1 e2 ...))
-                           e
-                           (extend-var-env* labels new-vars r)
-                           mr
-                           (make-binding-wrap old-ids labels w)
-                           m?))))))
-      (_ (syntax-error e)))))
-
-(define chi-local-syntax
-  (lambda (rec? e r mr w ae)
-    (syntax-case e ()
-      ((_ ((id val) ...) e1 e2 ...)
-       (let ((ids (syntax (id ...))))
-         (if (not (valid-bound-ids? ids))
-             (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
-               (source-wrap e w ae)
-               "keyword")
-             (let ((labels (gen-labels ids)))
-               (let ((new-w (make-binding-wrap ids labels w)))
-                 (let ((b* (let ((w (if rec? new-w w)))
-                             (map (lambda (x)
-                                    (defer-or-eval-transformer
-                                      local-eval-hook
-                                      (chi x mr mr w #t)))
-                                  (syntax (val ...))))))
-                   (values
-                     (syntax (e1 e2 ...))
-                     (extend-env* labels b* r)
-                     (extend-env* labels b* mr)
-                     new-w
-                     ae)))))))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(define chi-void
-  (lambda ()
-    (build-application no-source (build-primref no-source 'void) '())))
-
-(define ellipsis?
-  (lambda (x)
-    (and (nonsymbol-id? x)
-         (literal-id=? x (syntax (... ...))))))
-
-;;; data
-
-;;; strips all annotations from potentially circular reader output.
-
-(define strip-annotation
-  (lambda (x)
-    (cond
-      ((pair? x)
-       (cons (strip-annotation (car x))
-             (strip-annotation (cdr x))))
-      ((annotation? x) (annotation-stripped x))
-      (else x))))
-
-;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
-;;; on an annotation, strips the annotation as well.
-;;; since only the head of a list is annotated by the reader, not each pair
-;;; in the spine, we also check for pairs whose cars are annotated in case
-;;; we've been passed the cdr of an annotated list
-
-(define strip*
-  (lambda (x w fn)
-    (if (top-marked? w)
-        (fn x)
-        (let f ((x x))
-          (cond
-            ((syntax-object? x)
-             (strip* (syntax-object-expression x) (syntax-object-wrap x) fn))
-            ((pair? x)
-             (let ((a (f (car x))) (d (f (cdr x))))
-               (if (and (eq? a (car x)) (eq? d (cdr x)))
-                   x
-                   (cons a d))))
-            ((vector? x)
-             (let ((old (vector->list x)))
-                (let ((new (map f old)))
-                   (if (andmap eq? old new) x (list->vector new)))))
-            (else x))))))
-
-(define strip
-  (lambda (x w)
-    (strip* x w
-      (lambda (x)
-        (if (or (annotation? x) (and (pair? x) (annotation? (car x))))
-            (strip-annotation x)
-            x)))))
-
-;;; lexical variables
-
-(define gen-var
-  (lambda (id)
-    (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
-      (if (annotation? id)
-          (build-lexical-var id (annotation-expression id))
-          (build-lexical-var id id)))))
-
-(define lambda-var-list
-  (lambda (vars)
-    (let lvl ((vars vars) (ls '()) (w empty-wrap))
-       (cond
-         ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w))
-         ((id? vars) (cons (wrap vars w) ls))
-         ((null? vars) ls)
-         ((syntax-object? vars)
-          (lvl (syntax-object-expression vars)
-               ls
-               (join-wraps w (syntax-object-wrap vars))))
-         ((annotation? vars)
-          (lvl (annotation-expression vars) ls w))
-       ; include anything else to be caught by subsequent error
-       ; checking
-         (else (cons vars ls))))))
-
-
-; must precede global-extends
-
-(primitive-set! '$sc-put-cte
-  (lambda (id b top-token)
-     (define sc-put-module
-       (lambda (exports token new-marks)
-         (vfor-each
-           (lambda (id) (store-import-binding id token new-marks))
-           exports)))
-     (define (put-cte id binding token)
-       (let ((sym (if (symbol? id) id (id-var-name id empty-wrap))))
-        (store-import-binding id token '())
-         (put-global-definition-hook sym
-          ; global binding is assumed; if global pass #f to remove existing binding, if any
-           (if (and (eq? (binding-type binding) 'global)
-                    (eq? (binding-value binding) sym))
-               #f
-               binding))))
-     (let ((binding (make-transformer-binding b)))
-       (case (binding-type binding)
-         (($module)
-          (let ((iface (binding-value binding)))
-            (sc-put-module (interface-exports iface) (interface-token iface) '()))
-          (put-cte id binding top-token))
-         ((do-alias) (store-import-binding id top-token '()))
-         ((do-import)
-          ; fake binding: id is module id binding-value is token
-          (let ((token (binding-value b)))
-             (let ((b (lookup (id-var-name id empty-wrap) null-env)))
-               (case (binding-type b)
-                 (($module)
-                  (let* ((iface (binding-value b))
-                         (exports (interface-exports iface)))
-                    (unless (eq? (interface-token iface) token)
-                      (syntax-error id "import mismatch for module"))
-                    (sc-put-module (interface-exports iface) top-token
-                      (import-mark-delta id iface))))
-                 (else (syntax-error id "unknown module"))))))
-         (else (put-cte id binding top-token))))
-     ))
-
-
-;;; core transformers
-
-(global-extend 'local-syntax 'letrec-syntax #t)
-(global-extend 'local-syntax 'let-syntax #f)
-
-
-(global-extend 'core 'fluid-let-syntax
-  (lambda (e r mr w ae m?)
-    (syntax-case e ()
-      ((_ ((var val) ...) e1 e2 ...)
-       (valid-bound-ids? (syntax (var ...)))
-       (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
-         (for-each
-           (lambda (id n)
-             (case (binding-type (lookup n r))
-               ((displaced-lexical) (displaced-lexical-error (wrap id w)))))
-           (syntax (var ...))
-           names)
-         (let ((b* (map (lambda (x)
-                          (defer-or-eval-transformer
-                            local-eval-hook
-                            (chi x mr mr w #t)))
-                        (syntax (val ...)))))
-           (chi-body
-             (syntax (e1 e2 ...))
-             (source-wrap e w ae)
-             (extend-env* names b* r)
-             (extend-env* names b* mr)
-             w
-             m?))))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-(global-extend 'core 'quote
-   (lambda (e r mr w ae m?)
-      (syntax-case e ()
-         ((_ e) (build-data ae (strip (syntax e) w)))
-         (_ (syntax-error (source-wrap e w ae))))))
-
-(global-extend 'core '|#primitive|
-   (lambda (e r mr w ae m?)
-      (syntax-case e ()
-         ((_ name) (id? #'name)
-          (let ([name (strip (syntax name) w)])
-            (if (or (memq name (public-primitives))
-                    (memq name (system-primitives)))
-                (build-primref ae name)
-                (syntax-error (source-wrap e w ae)))))
-         (_ (syntax-error (source-wrap e w ae))))))
-
-(global-extend 'core 'syntax
-  (let ()
-    (define gen-syntax
-      (lambda (src e r maps ellipsis? vec?)
-        (if (id? e)
-            (let ((label (id-var-name e empty-wrap)))
-              (let ((b (lookup label r)))
-                (if (eq? (binding-type b) 'syntax)
-                    (let-values (((var maps)
-                                  (let ((var.lev (binding-value b)))
-                                    (gen-ref src (car var.lev) (cdr var.lev) maps))))
-                      (values `(ref ,var) maps))
-                    (if (ellipsis? e)
-                        (syntax-error src "misplaced ellipsis in syntax form")
-                        (values `(quote ,e) maps)))))
-            (syntax-case e ()
-              ((dots e)
-               (ellipsis? (syntax dots))
-               (if vec?
-                   (syntax-error src "misplaced ellipsis in syntax template")
-                   (gen-syntax src (syntax e) r maps (lambda (x) #f) #f)))
-              ((x dots . y)
-               ; this could be about a dozen lines of code, except that we
-               ; choose to handle (syntax (x ... ...)) forms
-               (ellipsis? (syntax dots))
-               (let f ((y (syntax y))
-                       (k (lambda (maps)
-                            (let-values (((x maps)
-                                          (gen-syntax src (syntax x) r
-                                            (cons '() maps) ellipsis? #f)))
-                              (if (null? (car maps))
-                                  (syntax-error src
-                                    "extra ellipsis in syntax form")
-                                  (values (gen-map x (car maps))
-                                          (cdr maps)))))))
-                 (syntax-case y ()
-                   ((dots . y)
-                    (ellipsis? (syntax dots))
-                    (f (syntax y)
-                       (lambda (maps)
-                         (let-values (((x maps) (k (cons '() maps))))
-                           (if (null? (car maps))
-                               (syntax-error src
-                                 "extra ellipsis in syntax form")
-                               (values (gen-mappend x (car maps))
-                                       (cdr maps)))))))
-                   (_ (let-values (((y maps) (gen-syntax src y r maps ellipsis? vec?)))
-                        (let-values (((x maps) (k maps)))
-                          (values (gen-append x y) maps)))))))
-              ((x . y)
-               (let-values (((xnew maps) (gen-syntax src (syntax x) r maps ellipsis? #f)))
-                 (let-values (((ynew maps) (gen-syntax src (syntax y) r maps ellipsis? vec?)))
-                   (values (gen-cons e (syntax x) (syntax y) xnew ynew)
-                           maps))))
-              (#(x1 x2 ...)
-               (let ((ls (syntax (x1 x2 ...))))
-                 (let-values (((lsnew maps) (gen-syntax src ls r maps ellipsis? #t)))
-                   (values (gen-vector e ls lsnew) maps))))
-              (_ (values `(quote ,e) maps))))))
-
-    (define gen-ref
-      (lambda (src var level maps)
-        (if (fx= level 0)
-            (values var maps)
-            (if (null? maps)
-                (syntax-error src "missing ellipsis in syntax form")
-                (let-values (((outer-var outer-maps) (gen-ref src var (fx- level 1) (cdr maps))))
-                  (let ((b (assq outer-var (car maps))))
-                    (if b
-                        (values (cdr b) maps)
-                        (let ((inner-var (gen-var 'tmp)))
-                          (values inner-var
-                                  (cons (cons (cons outer-var inner-var)
-                                              (car maps))
-                                        outer-maps))))))))))
-
-    (define gen-append
-      (lambda (x y)
-        (if (equal? y '(quote ()))
-            x
-            `(append ,x ,y))))
-
-    (define gen-mappend
-      (lambda (e map-env)
-        `(apply (primitive append) ,(gen-map e map-env))))
-
-    (define gen-map
-      (lambda (e map-env)
-        (let ((formals (map cdr map-env))
-              (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
-          (cond
-            ((eq? (car e) 'ref)
-             ; identity map equivalence:
-             ; (map (lambda (x) x) y) == y
-             (car actuals))
-            ((andmap
-                (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
-                (cdr e))
-             ; eta map equivalence:
-             ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
-             `(map (primitive ,(car e))
-                   ,@(map (let ((r (map cons formals actuals)))
-                            (lambda (x) (cdr (assq (cadr x) r))))
-                          (cdr e))))
-            (else `(map (case-lambda [,formals ,e]) ,@actuals))))))
-
-   ; 12/12/00: semantic change: we now return original syntax object (e)
-   ; if no pattern variables were found within, to avoid dropping
-   ; source annotations prematurely.  the "syntax returns lists" for
-   ; lists in its input guarantee counts only for substructure that
-   ; contains pattern variables
-    (define gen-cons
-      (lambda (e x y xnew ynew)
-        (case (car ynew)
-          ((quote)
-           (if (eq? (car xnew) 'quote)
-               (let ((xnew (cadr xnew)) (ynew (cadr ynew)))
-                 (if (and (eq? xnew x) (eq? ynew y))
-                     `',e
-                     `'(,xnew . ,ynew)))
-               (if (eq? (cadr ynew) '()) `(list ,xnew) `(cons ,xnew ,ynew))))
-          ((list) `(list ,xnew ,@(cdr ynew)))
-          (else `(cons ,xnew ,ynew)))))
-
-    (define gen-vector
-      (lambda (e ls lsnew)
-        (cond
-          ((eq? (car lsnew) 'quote)
-           (if (eq? (cadr lsnew) ls)
-               `',e
-               `(quote #(,@(cadr lsnew)))))
-          ((eq? (car lsnew) 'list) `(vector ,@(cdr lsnew)))
-          (else `(list->vector ,lsnew)))))
-
-
-    (define regen
-      (lambda (x)
-        (case (car x)
-          ((ref) (build-lexical-reference 'value no-source (cadr x)))
-          ((primitive) (build-primref no-source (cadr x)))
-          ((quote) (build-data no-source (cadr x)))
-          ((lambda) 
-           (build-lambda no-source (cadr x) (regen (caddr x))))
-          ((case-lambda)
-           (let ([d (cdr x)])
-             (build-case-lambda no-source
-              (map car d)
-              (map (lambda (x) (regen (cadr x))) d))))
-          ((map) (let ((ls (map regen (cdr x))))
-                   (build-application no-source
-                     (if (fx= (length ls) 2)
-                         (build-primref no-source 'map)
-                        ; really need to do our own checking here
-                         (build-primref no-source 2 'map)) ; require error check
-                     ls)))
-          (else (build-application no-source
-                  (build-primref no-source (car x))
-                  (map regen (cdr x)))))))
-
-    (lambda (e r mr w ae m?)
-      (let ((e (source-wrap e w ae)))
-        (syntax-case e ()
-          ((_ x)
-           (let-values (((e maps) (gen-syntax e (syntax x) r '() ellipsis? #f)))
-             (regen e)))
-          (_ (syntax-error e)))))))
-
-
-(global-extend 'core 'lambda
-  (lambda (e r mr w ae m?)
-    (syntax-case e ()
-      ((_ . c)
-       (let-values (((vars body)
-                     (chi-lambda-clause 
-                       (source-wrap e w ae) 
-                       (syntax c) r mr w m?)))
-         (build-lambda ae vars body))))))
-
-;;; AZIZ
-(global-extend 'core 'case-lambda
-   (lambda (e r mr w ae m?)
-     (syntax-case e ()
-       [(_ c* ...)
-        (let-values ([(vars* body*)
-                      (let f ([c* #'(c* ...)])
-                        (syntax-case c* ()
-                          [() (values '() '())]
-                          [(c . c*) 
-                           (let-values ([(vars body)
-                                         (chi-lambda-clause
-                                           (source-wrap e w ae)
-                                           #'c r mr w m?)])
-                             (let-values ([(vars* body*) (f #'c*)])
-                               (values 
-                                 (cons vars vars*)
-                                 (cons body body*))))]))])
-           (build-case-lambda ae vars* body*))])))
-
-
-
-
-(global-extend 'core 'letrec
-  (lambda (e r mr w ae m?)
-    (syntax-case e ()
-      ((_ ((id val) ...) e1 e2 ...)
-       (let ((ids (syntax (id ...))))
-         (if (not (valid-bound-ids? ids))
-             (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
-               (source-wrap e w ae) "bound variable")
-             (let ((labels (gen-labels ids))
-                   (new-vars (map gen-var ids)))
-               (let ((w (make-binding-wrap ids labels w))
-                    (r (extend-var-env* labels new-vars r)))
-                 (build-letrec ae
-                   new-vars
-                   (map (lambda (x) (chi x r mr w m?)) (syntax (val ...)))
-                   (chi-body (syntax (e1 e2 ...)) (source-wrap e w ae) r mr w m?)))))))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-
-(global-extend 'core 'if
-   (lambda (e r mr w ae m?)
-      (syntax-case e ()
-         ((_ test then)
-          (build-conditional ae
-             (chi (syntax test) r mr w m?)
-             (chi (syntax then) r mr w m?)
-             (chi-void)))
-         ((_ test then else)
-          (build-conditional ae
-             (chi (syntax test) r mr w m?)
-             (chi (syntax then) r mr w m?)
-             (chi (syntax else) r mr w m?)))
-         (_ (syntax-error (source-wrap e w ae))))))
-
-;;; AZIZ
-(global-extend 'core 'foreign-call
-  (lambda (e r mr w ae m?)
-    (syntax-case e ()
-      [(_ proc arg* ...)
-       (build-foreign-call ae
-         (chi #'proc r mr w m?)
-         (let f ([arg* #'(arg* ...)])
-           (syntax-case arg* ()
-             [() '()]
-             [(a . arg*)
-              (cons (chi #'a r mr w m?)
-                    (f #'arg*))])))]
-      [_ (syntax-error (source-wrap e w ae))])))
-
-(global-extend 'core '$apply
-  (lambda (e r mr w ae m?)
-    (syntax-case e ()
-      [(_ proc arg* ...)
-       (build-$apply ae
-         (chi #'proc r mr w m?)
-         (let f ([arg* #'(arg* ...)])
-           (syntax-case arg* ()
-             [() '()]
-             [(a . arg*)
-              (cons (chi #'a r mr w m?)
-                    (f #'arg*))])))]
-      [_ (syntax-error (source-wrap e w ae))])))
-
-;;; AZIZ
-(global-extend 'core 'type-descriptor
-  (lambda (e r mr w ae m?)
-    (syntax-case e ()
-      ((_ id)
-       (id? (syntax id))
-       (let ((n (id-var-name (syntax id) w)))
-         (let ((b (lookup n r)))
-           (case (binding-type b)
-             (($rtd) 
-              (build-data ae (binding-value b)))
-             (else (syntax-error (source-wrap e w ae)))))))
-      (_ (syntax-error (source-wrap e w ae))))))
-
-
-(global-extend 'set! 'set! '())
-
-(global-extend 'alias 'alias '())
-(global-extend 'begin 'begin '())
-
-(global-extend '$module-key '$module '())
-(global-extend '$import '$import '())
-
-(global-extend 'define 'define '())
-
-(global-extend 'define-syntax 'define-syntax '())
-
-(global-extend 'eval-when 'eval-when '())
-
-(global-extend 'meta 'meta '())
-
-(global-extend 'core 'syntax-case
-  (let ()
-    (define convert-pattern
-      ; accepts pattern & keys
-      ; returns syntax-dispatch pattern & ids
-      (lambda (pattern keys)
-        (define cvt*
-          (lambda (p* n ids)
-            (if (null? p*)
-                (values '() ids)
-                (let-values (((y ids) (cvt* (cdr p*) n ids)))
-                  (let-values (((x ids) (cvt (car p*) n ids)))
-                    (values (cons x y) ids))))))
-        (define cvt
-          (lambda (p n ids)
-            (if (id? p)
-                (if (bound-id-member? p keys)
-                    (values (vector 'free-id p) ids)
-                    (values 'any (cons (cons p n) ids)))
-                (syntax-case p ()
-                  ((x dots)
-                   (ellipsis? (syntax dots))
-                   (let-values (((p ids) (cvt (syntax x) (fx+ n 1) ids)))
-                     (values (if (eq? p 'any) 'each-any (vector 'each p))
-                             ids)))
-                  ((x dots y ... . z)
-                   (ellipsis? (syntax dots))
-                   (let-values (((z ids) (cvt (syntax z) n ids)))
-                     (let-values (((y ids) (cvt* (syntax (y ...)) n ids)))
-                       (let-values (((x ids) (cvt (syntax x) (fx+ n 1) ids)))
-                         (values `#(each+ ,x ,(reverse y) ,z) ids)))))
-                  ((x . y)
-                   (let-values (((y ids) (cvt (syntax y) n ids)))
-                     (let-values (((x ids) (cvt (syntax x) n ids)))
-                       (values (cons x y) ids))))
-                  (() (values '() ids))
-                  (#(x ...)
-                   (let-values (((p ids) (cvt (syntax (x ...)) n ids)))
-                     (values (vector 'vector p) ids)))
-                  (x (values (vector 'atom (strip p empty-wrap)) ids))))))
-        (cvt pattern 0 '())))
-
-    (define build-dispatch-call
-      (lambda (pvars exp y r mr m?)
-        (let ((ids (map car pvars)) (levels (map cdr pvars)))
-          (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
-            (build-application no-source
-              (build-primref no-source 'apply)
-              (list (build-lambda no-source new-vars
-                      (chi exp
-                         (extend-env*
-                             labels
-                             (map (lambda (var level)
-                                    (make-binding 'syntax `(,var . ,level)))
-                                  new-vars
-                                  (map cdr pvars))
-                             r)
-                         mr
-                         (make-binding-wrap ids labels empty-wrap)
-                         m?))
-                    y))))))
-
-    (define gen-clause
-      (lambda (x keys clauses r mr m? pat fender exp)
-        (let-values (((p pvars) (convert-pattern pat keys)))
-          (cond
-            ((not (distinct-bound-ids? (map car pvars)))
-             (invalid-ids-error (map car pvars) pat "pattern variable"))
-            ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
-             (syntax-error pat
-               "misplaced ellipsis in syntax-case pattern"))
-            (else
-             (let ((y (gen-var 'tmp)))
-               ; fat finger binding and references to temp variable y
-               (build-application no-source
-                 (build-lambda no-source (list y)
-                   (let-syntax ((y (identifier-syntax
-                                     (build-lexical-reference 'value no-source y))))
-                     (build-conditional no-source
-                       (syntax-case fender ()
-                         (#t y)
-                         (_ (build-conditional no-source
-                              y
-                              (build-dispatch-call pvars fender y r mr m?)
-                              (build-data no-source #f))))
-                       (build-dispatch-call pvars exp y r mr m?)
-                       (gen-syntax-case x keys clauses r mr m?))))
-                 (list (if (eq? p 'any)
-                           (build-application no-source
-                             (build-primref no-source 'list)
-                             (list (build-lexical-reference no-source 'value x)))
-                           (build-application no-source
-                             (build-primref no-source '$syntax-dispatch)
-                             (list (build-lexical-reference no-source 'value x)
-                                   (build-data no-source p))))))))))))
-
-    (define gen-syntax-case
-      (lambda (x keys clauses r mr m?)
-        (if (null? clauses)
-            (build-application no-source
-              (build-primref no-source 'syntax-error)
-              (list (build-lexical-reference 'value no-source x)))
-            (syntax-case (car clauses) ()
-              ((pat exp)
-               (if (and (id? (syntax pat))
-                        (not (bound-id-member? (syntax pat) keys))
-                        (not (ellipsis? (syntax pat))))
-                   (let ((label (gen-label))
-                         (var (gen-var (syntax pat))))
-                     (build-application no-source
-                       (build-lambda no-source (list var)
-                         (chi (syntax exp)
-                              (extend-env label (make-binding 'syntax `(,var . 0)) r)
-                              mr
-                              (make-binding-wrap (syntax (pat))
-                                (list label) empty-wrap)
-                              m?))
-                       (list (build-lexical-reference 'value no-source x))))
-                   (gen-clause x keys (cdr clauses) r mr m?
-                     (syntax pat) #t (syntax exp))))
-              ((pat fender exp)
-               (gen-clause x keys (cdr clauses) r mr m?
-                 (syntax pat) (syntax fender) (syntax exp)))
-              (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
-
-    (lambda (e r mr w ae m?)
-      (let ((e (source-wrap e w ae)))
-        (syntax-case e ()
-          ((_ val (key ...) m ...)
-           (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
-                       (syntax (key ...)))
-               (let ((x (gen-var 'tmp)))
-                 ; fat finger binding and references to temp variable x
-                 (build-application ae
-                   (build-lambda no-source (list x)
-                     (gen-syntax-case x
-                       (syntax (key ...)) (syntax (m ...))
-                       r mr m?))
-                   (list (chi (syntax val) r mr empty-wrap m?))))
-               (syntax-error e "invalid literals list in"))))))))
-
-(put-cte-hook 'module
-  (lambda (x)
-    (define proper-export?
-      (lambda (e)
-        (syntax-case e ()
-          ((id e ...)
-           (and (identifier? (syntax id))
-                (andmap proper-export? (syntax (e ...)))))
-          (id (identifier? (syntax id))))))
-    (with-syntax ((orig x))
-      (syntax-case x ()
-        ((_ (e ...) d ...)
-         (if (andmap proper-export? (syntax (e ...)))
-             (syntax 
-               (begin 
-                 ($module orig anon (e ...) d ...)
-                 ($import orig #f anon)))
-             (syntax-error x "invalid exports list in")))
-        ((_ m (e ...) d ...)
-         (identifier? (syntax m))
-         (if (andmap proper-export? (syntax (e ...)))
-             (syntax 
-               ($module orig m (e ...) d ...))
-             (syntax-error x "invalid exports list in")))))))
-
-(let ()
-  (define $module-exports
-    (lambda (m r)
-      (let ((b (r m)))
-        (case (binding-type b)
-          (($module)
-           (let* ((interface (binding-value b))
-                  (new-marks (import-mark-delta m interface)))
-             (vmap (lambda (x)
-                     (let ((id (if (pair? x) (car x) x)))
-                       (make-syntax-object
-                         (syntax-object->datum id)
-                         (let ((marks (join-marks new-marks (wrap-marks (syntax-object-wrap id))))) 
-                           (make-wrap marks
-                                     ; the anti mark should always be present at the head
-                                     ; of new-marks, but we paranoically check anyway
-                                      (if (eq? (car marks) the-anti-mark)
-                                          (cons 'shift (wrap-subst top-wrap))
-                                          (wrap-subst top-wrap)))))))
-                   (interface-exports interface))))
-          ((displaced-lexical) (displaced-lexical-error m))
-          (else (syntax-error m "unknown module"))))))
-  (define $import-help
-    (lambda (orig import-only?)
-      (lambda (r)
-        (define difference
-          (lambda (ls1 ls2)
-            (if (null? ls1)
-                ls1
-                (if (bound-id-member? (car ls1) ls2)
-                    (difference (cdr ls1) ls2)
-                    (cons (car ls1) (difference (cdr ls1) ls2))))))
-        (define prefix-add
-          (lambda (prefix-id)
-            (let ((prefix (symbol->string (syntax-object->datum prefix-id))))
-              (lambda (id)
-                (datum->syntax-object id
-                  (string->symbol
-                    (string-append prefix
-                      (symbol->string (syntax-object->datum id)))))))))
-        (define prefix-drop
-          (lambda (prefix-id)
-            (let ((prefix (symbol->string (syntax-object->datum prefix-id))))
-              (lambda (id)
-                (let ((s (symbol->string (syntax-object->datum id))))
-                  (let ((np (string-length prefix)) (ns (string-length s)))
-                    (unless (and (fx>= ns np) (string=? (substring s 0 np) prefix))
-                      (syntax-error id (string-append "missing expected prefix " prefix)))
-                    (datum->syntax-object id
-                      (string->symbol (substring s np ns)))))))))
-        (define gen-mid
-          (lambda (mid)
-           ; introduced module ids must have same marks as original
-           ; for import-only, since the barrier carries the marks of
-           ; the module id
-            (datum->syntax-object mid (gensym-hook))))
-        (define (modspec m exports?)
-          (with-syntax ((orig orig) (import-only? import-only?))
-            (syntax-case m (only-for-syntax also-for-syntax
-                            only except
-                            add-prefix drop-prefix rename alias)
-              ((only m id ...)
-               (andmap identifier? (syntax (id ...)))
-               (let-values (((mid d exports) (modspec (syntax m) #f)))
-                 (with-syntax ((d d) (tmid (gen-mid mid)))
-                   (values mid
-                           (syntax (begin ($module orig tmid (id ...) d) ($import orig import-only? tmid)))
-                           (and exports? (syntax (id ...)))))))
-              ((except m id ...)
-               (andmap identifier? (syntax (id ...)))
-               (let-values (((mid d exports) (modspec (syntax m) #t)))
-                 (with-syntax ((d d)
-                               (tmid (gen-mid mid))
-                               ((id ...) (difference exports (syntax (id ...)))))
-                   (values mid
-                           (syntax (begin ($module orig tmid (id ...) d) ($import orig import-only? tmid)))
-                           (and exports? (syntax (id ...)))))))
-              ((add-prefix m prefix-id)
-               (identifier? (syntax prefix-id))
-               (let-values (((mid d exports) (modspec (syntax m) #t)))
-                 (with-syntax ((d d)
-                               (tmid (gen-mid mid))
-                               ((old-id ...) exports)
-                               ((tmp ...) (generate-temporaries exports))
-                               ((id ...) (map (prefix-add (syntax prefix-id)) exports)))
-                   (values mid
-                           (syntax (begin ($module orig tmid ((id tmp) ...)
-                                            ($module orig tmid ((tmp old-id) ...) d (alias tmp old-id) ...)
-                                            ($import orig import-only? tmid)
-                                            (alias id tmp) ...)
-                                          ($import orig import-only? tmid)))
-                           (and exports? (syntax (id ...)))))))
-              ((drop-prefix m prefix-id)
-               (identifier? (syntax prefix-id))
-               (let-values (((mid d exports) (modspec (syntax m) #t)))
-                 (with-syntax ((d d)
-                               (tmid (gen-mid mid))
-                               ((old-id ...) exports)
-                               ((tmp ...) (generate-temporaries exports))
-                               ((id ...) (map (prefix-drop (syntax prefix-id)) exports)))
-                   (values mid
-                           (syntax (begin ($module orig tmid ((id tmp) ...)
-                                            ($module orig tmid ((tmp old-id) ...) d (alias tmp old-id) ...)
-                                            ($import orig import-only? tmid)
-                                            (alias id tmp) ...)
-                                          ($import orig import-only? tmid)))
-                           (and exports? (syntax (id ...)))))))
-              ((rename m (new-id old-id) ...)
-               (and (andmap identifier? (syntax (new-id ...)))
-                    (andmap identifier? (syntax (old-id ...))))
-               (let-values (((mid d exports) (modspec (syntax m) #t)))
-                 (with-syntax ((d d)
-                               (tmid (gen-mid mid))
-                               ((tmp ...) (generate-temporaries (syntax (old-id ...))))
-                               ((other-id ...) (difference exports (syntax (old-id ...)))))
-                   (values mid
-                           (syntax (begin ($module orig tmid ((new-id tmp) ... other-id ...)
-                                            ($module orig tmid (other-id ... (tmp old-id) ...) d (alias tmp old-id) ...)
-                                            ($import orig import-only? tmid)
-                                            (alias new-id tmp) ...)
-                                          ($import orig import-only? tmid)))
-                           (and exports? (syntax (new-id ... other-id ...)))))))
-              ((alias m (new-id old-id) ...)
-               (and (andmap identifier? (syntax (new-id ...)))
-                    (andmap identifier? (syntax (old-id ...))))
-               (let-values (((mid d exports) (modspec (syntax m) #t)))
-                 (with-syntax ((d d)
-                               (tmid (gen-mid mid))
-                               ((other-id ...) exports))
-                   (values mid
-                           (syntax (begin ($module orig tmid ((new-id old-id) ... other-id ...) d (alias new-id old-id) ...)
-                                          ($import orig import-only? tmid)))
-                           (and exports? (syntax (new-id ... other-id ...)))))))
-             ; base cases
-              (mid
-               (identifier? (syntax mid))
-               (values (syntax mid)
-                       (syntax ($import orig import-only? mid))
-                       (and exports? ($module-exports (syntax mid) r))))
-              ((mid)
-               (identifier? (syntax mid))
-               (values (syntax mid)
-                       (syntax ($import orig import-only? mid))
-                       (and exports? ($module-exports (syntax mid) r))))
-            (_ (syntax-error m "invalid module specifier")))))
-        (define modspec*
-          (lambda (m)
-            (let-values (((mid d exports) (modspec m #f))) d)))
-        (syntax-case orig ()
-          ((_ m ...)
-           (with-syntax (((d ...) (map modspec* (syntax (m ...)))))
-             (syntax (begin d ...))))))))
-
-  (put-cte-hook 'import
-    (lambda (orig)
-      ($import-help orig #f)))
-  
-  (put-cte-hook 'import-only
-    (lambda (orig)
-      ($import-help orig #t)))
-)
-
-;;; To support eval-when, we maintain two mode sets:
-;;;
-;;; ctem (compile-time-expression mode)
-;;;   determines whether/when to evaluate compile-time expressions such
-;;;   as macro definitions, module definitions, and compile-time
-;;;   registration of variable definitions
-;;;
-;;; rtem (run-time-expression mode)
-;;;   determines whether/when to evaluate run-time expressions such
-;;;   as the actual assignment performed by a variable definition or
-;;;   arbitrary top-level expressions
-
-;;; Possible modes in the mode set are:
-;;;
-;;; L (load): evaluate at load time.  implies V for compile-time
-;;;     expressions and R for run-time expressions.
-;;;
-;;; C (compile): evaluate at compile (file) time
-;;;
-;;; E (eval): evaluate at evaluation (compile or interpret) time
-;;;
-;;; V (visit): evaluate at visit time
-;;;
-;;; R (revisit): evaluate at revisit time
-
-;;; The mode set for the body of an eval-when is determined by
-;;; translating each mode in the old mode set based on the situations
-;;; present in the eval-when form and combining these into a set,
-;;; using the following table.  See also update-mode-set.
-
-;;;      load  compile  visit  revisit  eval
-;;;
-;;; L     L      C        V       R      -
-;;;
-;;; C     -      -        -       -      C
-;;;
-;;; V     V      C        V       -      -
-;;;
-;;; R     R      C        -       R      -
-;;;
-;;; E     -      -        -       -      E
-
-;;; When we complete the expansion of a compile or run-time expression,
-;;; the current ctem or rtem determines how the expression will be
-;;; treated.  See ct-eval/residualize and rt-eval/residualize.
-
-;;; Initial mode sets
-;;;
-;;; when compiling a file:
-;;;
-;;;     initial ctem: (L C)
-;;;
-;;;     initial rtem: (L)
-;;;
-;;; when not compiling a file:
-;;;
-;;;     initial ctem: (E)
-;;;
-;;;     initial rtem: (E)
-;;;
-;;;
-;;; This means that top-level syntactic definitions are evaluated
-;;; immediately after they are expanded, and the expanded definitions
-;;; are also residualized into the object file if we are compiling
-;;; a file.
-
-
-
-;;; AZIZ
-;;; (set! sc-expand
-;;;   (let ((ctem '(E)) (rtem '(E)))
-;;;     (lambda (x)
-;;;       (let ((env (interaction-environment)))
-;;;         (if (and (pair? x) (equal? (car x) noexpand))
-;;;             (cadr x)
-;;;             (chi-top* x null-env
-;;;               (env-wrap env)
-;;;               ctem rtem #f
-;;;               (env-top-ribcage env)))))))
-;;; 
-
-(primitive-set! 'expand-mode
-  (make-parameter
-    'eval
-    (lambda (x)
-      (unless (memq x '(eval compile bootstrap))
-        (error 'expand-mode "~s is not a valid mode" x))
-      x)))
-
-(primitive-set! 'sc-expand
-  (let ()
-    (define get-modes
-      (lambda ()
-        (case (expand-mode)
-          [(eval)      (values '(E)   '(E))]
-          [(compile)   (values '(L C) '(L))]
-          [(bootstrap) (values '(L)   '(L))])))
-    (lambda (x)
-      (let ((env (interaction-environment)))
-        (let-values ([(ctem rtem) (get-modes)])
-          (if (and (pair? x) (equal? (car x) noexpand))
-              (cadr x)
-              (chi-top* x null-env
-                (env-wrap env)
-                ctem rtem #f
-                (env-top-ribcage env))))))))
-
-(primitive-set! 'current-expand
-  (make-parameter
-    sc-expand
-    (lambda (x)
-      (unless (procedure? x)
-        (error 'current-expand "~s is not a procedure" x))
-      x)))
-
-(primitive-set! 'expand
-  (lambda (x)
-    ((current-expand) x)))
-
-(primitive-set! '$make-environment
-  (lambda (token mutable?)
-    (let ((top-ribcage (make-top-ribcage token mutable?)))
-      (make-env
-        top-ribcage
-        (make-wrap
-          (wrap-marks top-wrap)
-          (cons top-ribcage (wrap-subst top-wrap)))))))
-
-(primitive-set! 'environment?
-  (lambda (x)
-    (env? x)))
-
-
-;;; AZIZ
-;;; (primitive-set! 'interaction-environment
-;;;   (let ((e ($make-environment '*top* #t)))
-;;;     (lambda () e)))
-
-(primitive-set! 'interaction-environment
-  (make-parameter
-    ($make-environment '*top* #t)
-    (lambda (x)
-      (if (environment? x)
-          x
-          (error 'interaction-environment "~s is not an environment" x)))))
-
-
-(primitive-set! 'identifier?
-  (lambda (x)
-    (nonsymbol-id? x)))
-
-(primitive-set! 'datum->syntax-object
-  (lambda (id datum)
-    (arg-check nonsymbol-id? id 'datum->syntax-object)
-    (make-syntax-object
-      datum
-      (syntax-object-wrap id))))
-
-(primitive-set! 'syntax->list
-  (lambda (orig-ls)
-    (let f ((ls orig-ls))
-      (syntax-case ls ()
-        (() '())
-        ((x . r) (cons #'x (f #'r)))
-        (_ (error 'syntax->list "invalid argument ~s" orig-ls))))))
-
-(primitive-set! 'syntax->vector
-  (lambda (v)
-    (syntax-case v ()
-      (#(x ...) (apply vector (syntax->list #'(x ...))))
-      (_ (error 'syntax->vector "invalid argument ~s" v)))))
-
-(primitive-set! 'syntax-object->datum
-  ; accepts any object, since syntax objects may consist partially
-  ; or entirely of unwrapped, nonsymbolic data
-  (lambda (x)
-    (strip x empty-wrap)))
-
-(primitive-set! 'generate-temporaries
-  (lambda (ls)
-    (arg-check list? ls 'generate-temporaries)
-    (map (lambda (x) (wrap (gensym-hook) top-wrap)) ls)))
-
-(primitive-set! 'free-identifier=?
-   (lambda (x y)
-      (arg-check nonsymbol-id? x 'free-identifier=?)
-      (arg-check nonsymbol-id? y 'free-identifier=?)
-      (free-id=? x y)))
-
-(primitive-set! 'bound-identifier=?
-   (lambda (x y)
-      (arg-check nonsymbol-id? x 'bound-identifier=?)
-      (arg-check nonsymbol-id? y 'bound-identifier=?)
-      (bound-id=? x y)))
-
-(primitive-set! 'literal-identifier=?
-  (lambda (x y)
-    (arg-check nonsymbol-id? x 'literal-identifier=?)
-    (arg-check nonsymbol-id? y 'literal-identifier=?)
-    (literal-id=? x y)))
-
-(primitive-set! 'syntax-error
-  (lambda (object . messages)
-    (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
-    (let ((message (if (null? messages)
-                       "invalid syntax"
-                       (apply string-append messages))))
-      (error-hook #f message (strip object empty-wrap)))))
-
-;;; syntax-dispatch expects an expression and a pattern.  If the expression
-;;; matches the pattern a list of the matching expressions for each
-;;; "any" is returned.  Otherwise, #f is returned.  (This use of #f will
-;;; not work on r4rs implementations that violate the ieee requirement
-;;; that #f and () be distinct.)
-
-;;; The expression is matched with the pattern as follows:
-
-;;; p in pattern:                        matches:
-;;;   ()                                 empty list
-;;;   any                                anything
-;;;   (p1 . p2)                          pair (list)
-;;;   #(free-id <key>)                   <key> with literal-identifier=?
-;;;   each-any                           any proper list
-;;;   #(each p)                          (p*)
-;;;   #(each+ p1 (p2_1 ...p2_n) p3)      (p1* (p2_n ... p2_1) . p3)
-;;;   #(vector p)                        (list->vector p)
-;;;   #(atom <object>)                   <object> with "equal?"
-
-;;; Vector cops out to pair under assumption that vectors are rare.  If
-;;; not, should convert to:
-;;;   #(vector p)                        #(p*)
-
-(let ()
-
-(define match-each
-  (lambda (e p w)
-    (cond
-      ((annotation? e)
-       (match-each (annotation-expression e) p w))
-      ((pair? e)
-       (let ((first (match (car e) p w '())))
-         (and first
-              (let ((rest (match-each (cdr e) p w)))
-                 (and rest (cons first rest))))))
-      ((null? e) '())
-      ((syntax-object? e)
-       (match-each (syntax-object-expression e)
-                   p
-                   (join-wraps w (syntax-object-wrap e))))
-      (else #f))))
-
-(define match-each+
-  (lambda (e x-pat y-pat z-pat w r)
-    (let f ((e e) (w w))
-      (cond
-        ((pair? e)
-         (let-values (((xr* y-pat r) (f (cdr e) w)))
-           (if r
-               (if (null? y-pat)
-                   (let ((xr (match (car e) x-pat w '())))
-                     (if xr
-                         (values (cons xr xr*) y-pat r)
-                         (values #f #f #f)))
-                   (values '() (cdr y-pat) (match (car e) (car y-pat) w r)))
-               (values #f #f #f))))
-        ((annotation? e) (f (annotation-expression e) w))
-        ((syntax-object? e) (f (syntax-object-expression e)
-                               (join-wraps w (syntax-object-wrap e))))
-        (else (values '() y-pat (match e z-pat w r)))))))
-
-(define match-each-any
-  (lambda (e w)
-    (cond
-      ((annotation? e)
-       (match-each-any (annotation-expression e) w))
-      ((pair? e)
-       (let ((l (match-each-any (cdr e) w)))
-         (and l (cons (wrap (car e) w) l))))
-      ((null? e) '())
-      ((syntax-object? e)
-       (match-each-any (syntax-object-expression e)
-                       (join-wraps w (syntax-object-wrap e))))
-      (else #f))))
-
-(define match-empty
-  (lambda (p r)
-    (cond
-      ((null? p) r)
-      ((eq? p 'any) (cons '() r))
-      ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
-      ((eq? p 'each-any) (cons '() r))
-      (else
-       (case (vector-ref p 0)
-         ((each) (match-empty (vector-ref p 1) r))
-         ((each+) (match-empty (vector-ref p 1)
-                    (match-empty (reverse (vector-ref p 2))
-                      (match-empty (vector-ref p 3) r))))
-         ((free-id atom) r)
-         ((vector) (match-empty (vector-ref p 1) r)))))))
-
-(define combine
-  (lambda (r* r)
-    (if (null? (car r*))
-        r
-        (cons (map car r*) (combine (map cdr r*) r)))))
-
-(define match*
-  (lambda (e p w r)
-    (cond
-      ((null? p) (and (null? e) r))
-      ((pair? p)
-       (and (pair? e) (match (car e) (car p) w
-                        (match (cdr e) (cdr p) w r))))
-      ((eq? p 'each-any)
-       (let ((l (match-each-any e w))) (and l (cons l r))))
-      (else
-       (case (vector-ref p 0)
-         ((each)
-          (if (null? e)
-              (match-empty (vector-ref p 1) r)
-              (let ((r* (match-each e (vector-ref p 1) w)))
-                (and r* (combine r* r)))))
-         ((free-id) (and (id? e) (literal-id=? (wrap e w) (vector-ref p 1)) r))
-         ((each+)
-          (let-values (((xr* y-pat r)
-                        (match-each+ e (vector-ref p 1) (vector-ref p 2)
-                          (vector-ref p 3) w r)))
-            (and r (null? y-pat)
-              (if (null? xr*)
-                  (match-empty (vector-ref p 1) r)
-                  (combine xr* r)))))
-         ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
-         ((vector)
-          (and (vector? e)
-               (match (vector->list e) (vector-ref p 1) w r))))))))
-
-(define match
-  (lambda (e p w r)
-    (cond
-      ((not r) #f)
-      ((eq? p 'any) (cons (wrap e w) r))
-      ((syntax-object? e)
-       (match*
-         (unannotate (syntax-object-expression e))
-         p
-         (join-wraps w (syntax-object-wrap e))
-         r))
-      (else (match* (unannotate e) p w r)))))
-
-(primitive-set! '$syntax-dispatch
-  (lambda (e p)
-    (cond
-      ((eq? p 'any) (list e))
-      ((syntax-object? e)
-       (match* (unannotate (syntax-object-expression e))
-         p (syntax-object-wrap e) '()))
-      (else (match* (unannotate e) p empty-wrap '())))))
-))
-
-
-(define-syntax with-syntax
-   (lambda (x)
-      (syntax-case x ()
-         ((_ () e1 e2 ...)
-          (syntax (begin e1 e2 ...)))
-         ((_ ((out in)) e1 e2 ...)
-          (syntax (syntax-case in () (out (begin e1 e2 ...)))))
-         ((_ ((out in) ...) e1 e2 ...)
-          (syntax (syntax-case (list in ...) ()
-                     ((out ...) (begin e1 e2 ...))))))))
-
-(define-syntax with-implicit
-  (syntax-rules ()
-    ((_ (tid id ...) e1 e2 ...)
-     (andmap identifier? (syntax (tid id ...)))
-     (begin
-       (unless (identifier? (syntax tid))
-         (syntax-error (syntax tid) "non-identifier with-implicit template"))
-       (with-syntax ((id (datum->syntax-object (syntax tid) 'id)) ...)
-         e1 e2 ...)))))
-
-(define-syntax datum
-  (syntax-rules ()
-    ((_ x) (syntax-object->datum (syntax x)))))
-
-(define-syntax syntax-rules
-  (lambda (x)
-    (define clause
-      (lambda (y)
-        (syntax-case y ()
-          (((keyword . pattern) template)
-           (syntax ((dummy . pattern) (syntax template))))
-          (((keyword . pattern) fender template)
-           (syntax ((dummy . pattern) fender (syntax template))))
-          (_ (syntax-error x)))))
-    (syntax-case x ()
-      ((_ (k ...) cl ...)
-       (andmap identifier? (syntax (k ...)))
-       (with-syntax (((cl ...) (map clause (syntax (cl ...)))))
-         (syntax (lambda (x) (syntax-case x (k ...) cl ...))))))))
-
-(define-syntax or
-   (lambda (x)
-      (syntax-case x ()
-         ((_) (syntax #f))
-         ((_ e) (syntax e))
-         ((_ e1 e2 e3 ...)
-          (syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))
-
-(define-syntax and
-   (lambda (x)
-      (syntax-case x ()
-         ((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f)))
-         ((_ e) (syntax e))
-         ((_) (syntax #t)))))
-
-(define-syntax let
-   (lambda (x)
-      (syntax-case x ()
-         ((_ ((x v) ...) e1 e2 ...)
-          (andmap identifier? (syntax (x ...)))
-          (syntax ((lambda (x ...) e1 e2 ...) v ...)))
-         ((_ f ((x v) ...) e1 e2 ...)
-          (andmap identifier? (syntax (f x ...)))
-          (syntax ((letrec ((f (lambda (x ...) e1 e2 ...))) f)
-                    v ...))))))
-
-(define-syntax let*
-  (lambda (x)
-    (syntax-case x ()
-      ((let* ((x v) ...) e1 e2 ...)
-       (andmap identifier? (syntax (x ...)))
-       (let f ((bindings (syntax ((x v)  ...))))
-         (if (null? bindings)
-             (syntax (let () e1 e2 ...))
-             (with-syntax ((body (f (cdr bindings)))
-                           (binding (car bindings)))
-               (syntax (let (binding) body)))))))))
-
-(define-syntax cond
-  (lambda (x)
-    (syntax-case x ()
-      ((_ m1 m2 ...)
-       (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
-         (if (null? clauses)
-             (syntax-case clause (else =>)
-               ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
-               ((e0) (syntax (let ((t e0)) (if t t))))
-               ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t)))))
-               ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...))))
-               (_ (syntax-error x)))
-             (with-syntax ((rest (f (car clauses) (cdr clauses))))
-               (syntax-case clause (else =>)
-                 ((e0) (syntax (let ((t e0)) (if t t rest))))
-                 ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t) rest))))
-                 ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...) rest)))
-                 (_ (syntax-error x))))))))))
-
-(define-syntax do
-   (lambda (orig-x)
-      (syntax-case orig-x ()
-         ((_ ((var init . step) ...) (e0 e1 ...) c ...)
-          (with-syntax (((step ...)
-                         (map (lambda (v s)
-                                 (syntax-case s ()
-                                    (() v)
-                                    ((e) (syntax e))
-                                    (_ (syntax-error orig-x))))
-                              (syntax (var ...))
-                              (syntax (step ...)))))
-             (syntax-case (syntax (e1 ...)) ()
-                (() (syntax (let do ((var init) ...)
-                               (if (not e0)
-                                   (begin c ... (do step ...))))))
-                ((e1 e2 ...)
-                 (syntax (let do ((var init) ...)
-                            (if e0
-                                (begin e1 e2 ...)
-                                (begin c ... (do step ...))))))))))))
-
-(define-syntax quasiquote
-   (letrec
-     ; these are here because syntax-case uses literal-identifier=?,
-     ; and we want the more precise free-identifier=?
-      ((isquote? (lambda (x)
-                   (and (identifier? x)
-                        (free-identifier=? x (syntax quote)))))
-       (islist? (lambda (x)
-                  (and (identifier? x)
-                       (free-identifier=? x (syntax list)))))
-       (iscons? (lambda (x)
-                  (and (identifier? x)
-                       (free-identifier=? x (syntax cons)))))
-       (quote-nil? (lambda (x)
-                    (syntax-case x ()
-                      ((quote? ()) (isquote? (syntax quote?)))
-                      (_ #f))))
-       (quasilist*
-        (lambda (x y)
-          (let f ((x x))
-            (if (null? x)
-                y
-                (quasicons (car x) (f (cdr x)))))))
-       (quasicons
-        (lambda (x y)
-          (with-syntax ((x x) (y y))
-            (syntax-case (syntax y) ()
-              ((quote? dy)
-               (isquote? (syntax quote?))
-               (syntax-case (syntax x) ()
-                 ((quote? dx)
-                  (isquote? (syntax quote?))
-                  (syntax (quote (dx . dy))))
-                 (_ (if (null? (syntax dy))
-                        (syntax (list x))
-                        (syntax (cons x y))))))
-              ((listp . stuff)
-               (islist? (syntax listp))
-               (syntax (list x . stuff)))
-              (else (syntax (cons x y)))))))
-       (quasiappend
-        (lambda (x y)
-          (let ((ls (let f ((x x))
-                      (if (null? x)
-                          (if (quote-nil? y)
-                              '()
-                              (list y))
-                          (if (quote-nil? (car x))
-                              (f (cdr x))
-                              (cons (car x) (f (cdr x))))))))
-            (cond
-              ((null? ls) (syntax (quote ())))
-              ((null? (cdr ls)) (car ls))
-              (else (with-syntax (((p ...) ls))
-                      (syntax (append p ...))))))))
-       (quasivector
-        (lambda (x)
-          (with-syntax ((pat-x x))
-            (syntax-case (syntax pat-x) ()
-              ((quote? (x ...))
-               (isquote? (syntax quote?))
-               (syntax (quote #(x ...))))
-              (_ (let f ((x x) (k (lambda (ls) `(,(syntax vector) ,@ls))))
-                   (syntax-case x ()
-                     ((quote? (x ...))
-                      (isquote? (syntax quote?))
-                      (k (syntax ((quote x) ...))))
-                     ((listp x ...)
-                      (islist? (syntax listp))
-                      (k (syntax (x ...))))
-                     ((cons? x y)
-                      (iscons? (syntax cons?))
-                      (f (syntax y) (lambda (ls) (k (cons (syntax x) ls)))))
-                     (else
-                      (syntax (list->vector pat-x))))))))))
-       (vquasi
-        (lambda (p lev)
-           (syntax-case p ()
-              ((p . q)
-               (syntax-case #'p (unquote unquote-splicing)
-                 ((unquote p ...)
-                  (if (fx= lev 0)
-                      (quasilist* (syntax (p ...)) (vquasi (syntax q) lev))
-                      (quasicons (quasicons (syntax (quote unquote))
-                                            (quasi (syntax (p ...)) (fx- lev 1)))
-                                 (vquasi (syntax q) lev))))
-                 ((unquote-splicing p ...)
-                  (if (fx= lev 0)
-                      (quasiappend (syntax (p ...)) (vquasi (syntax q) lev))
-                      (quasicons (quasicons (syntax (quote unquote-splicing))
-                                            (quasi (syntax (p ...)) (fx- lev 1)))
-                                 (vquasi (syntax q) lev))))
-                 (p (quasicons (quasi (syntax p) lev) (vquasi (syntax q) lev)))))
-              (() (syntax (quote ()))))))
-       (quasi
-        (lambda (p lev)
-           (syntax-case p (unquote unquote-splicing quasiquote)
-              ((unquote p)
-               (if (fx= lev 0)
-                   (syntax p)
-                   (quasicons (syntax (quote unquote))
-                              (quasi (syntax (p)) (fx- lev 1)))))
-              (((unquote p ...) . q)
-               (if (fx= lev 0)
-                   (quasilist* (syntax (p ...)) (quasi (syntax q) lev))
-                   (quasicons (quasicons (syntax (quote unquote))
-                                         (quasi (syntax (p ...)) (fx- lev 1)))
-                              (quasi (syntax q) lev))))
-              (((unquote-splicing p ...) . q)
-               (if (fx= lev 0)
-                   (quasiappend (syntax (p ...)) (quasi (syntax q) lev))
-                   (quasicons (quasicons (syntax (quote unquote-splicing))
-                                         (quasi (syntax (p ...)) (fx- lev 1)))
-                              (quasi (syntax q) lev))))
-              ((quasiquote p)
-               (quasicons (syntax (quote quasiquote))
-                          (quasi (syntax (p)) (fx+ lev 1))))
-              ((p . q)
-               (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
-              (#(x ...) (quasivector (vquasi (syntax (x ...)) lev)))
-              (p (syntax (quote p)))))))
-    (lambda (x)
-       (syntax-case x ()
-          ((_ e) (quasi (syntax e) 0))))))
-
-(define-syntax unquote
-  (lambda (x)
-    (syntax-error x "misplaced")))
-
-(define-syntax unquote-splicing
-  (lambda (x)
-    (syntax-error x "misplaced")))
-
-(define-syntax quasisyntax
-  (lambda (x)
-    (define (qs q n b* k)
-      (syntax-case q (quasisyntax unsyntax unsyntax-splicing)
-        ((quasisyntax . d)
-         (qs #'d (fx+ n 1) b*
-           (lambda (b* dnew)
-             (k b*
-                (if (eq? dnew #'d)
-                    q
-                    (with-syntax ((d dnew)) #'(quasisyntax . d)))))))
-        ((unsyntax . d)
-         (not (fx= n 0))
-         (qs #'d (fx- n 1) b*
-           (lambda (b* dnew)
-             (k b*
-                (if (eq? dnew #'d)
-                    q
-                    (with-syntax ((d dnew)) #'(unsyntax . d)))))))
-        ((unsyntax-splicing . d)
-         (not (fx= n 0))
-         (qs #'d (fx- n 1) b*
-           (lambda (b* dnew)
-             (k b*
-                (if (eq? dnew #'d)
-                    q
-                    (with-syntax ((d dnew)) #'(unsyntax-splicing . d)))))))
-        ((unsyntax q)
-         (fx= n 0)
-         (with-syntax (((t) (generate-temporaries #'(q))))
-           (k (cons #'(t q) b*) #'t)))
-        (((unsyntax q ...) . d)
-         (fx= n 0)
-         (qs #'d n b*
-           (lambda (b* dnew)
-             (with-syntax (((t ...) (generate-temporaries #'(q ...))))
-               (k (append #'((t q) ...) b*)
-                  (with-syntax ((d dnew)) #'(t ... . d)))))))
-        (((unsyntax-splicing q ...) . d)
-         (fx= n 0)
-         (qs #'d n b*
-           (lambda (b* dnew)
-             (with-syntax (((t ...) (generate-temporaries #'(q ...))))
-               (k (append #'(((t (... ...)) q) ...) b*)
-                  (with-syntax ((((m ...) ...) #'((t (... ...)) ...)))
-                    (with-syntax ((d dnew)) #'(m ... ... . d))))))))
-        ((a . d)
-         (qs #'a n b*
-           (lambda (b* anew)
-             (qs #'d n b*
-               (lambda (b* dnew)
-                 (k b*
-                    (if (and (eq? anew #'a) (eq? dnew #'d))
-                        q
-                        (with-syntax ((a anew) (d dnew)) #'(a . d)))))))))
-        (#(x ...)
-         (vqs #'(x ...) n b*
-           (lambda (b* xnew*)
-             (k b*
-                (if (let same? ((x* #'(x ...)) (xnew* xnew*))
-                      (if (null? x*)
-                          (null? xnew*)
-                          (and (not (null? xnew*))
-                               (eq? (car x*) (car xnew*))
-                               (same? (cdr x*) (cdr xnew*)))))
-                    q
-                    (with-syntax (((x ...) xnew*)) #'#(x ...)))))))
-        (_ (k b* q))))
-    (define (vqs x* n b* k)
-      (if (null? x*)
-          (k b* '())
-          (vqs (cdr x*) n b*
-            (lambda (b* xnew*)
-              (syntax-case (car x*) (unsyntax unsyntax-splicing)
-                ((unsyntax q ...)
-                 (fx= n 0)
-                 (with-syntax (((t ...) (generate-temporaries #'(q ...))))
-                   (k (append #'((t q) ...) b*)
-                      (append #'(t ...) xnew*))))
-                ((unsyntax-splicing q ...)
-                 (fx= n 0)
-                 (with-syntax (((t ...) (generate-temporaries #'(q ...))))
-                   (k (append #'(((t (... ...)) q) ...) b*)
-                      (with-syntax ((((m ...) ...) #'((t (... ...)) ...)))
-                        (append #'(m ... ...) xnew*)))))
-                (_ (qs (car x*) n b*
-                     (lambda (b* xnew)
-                       (k b* (cons xnew xnew*))))))))))
-    (syntax-case x ()
-      ((_ x)
-       (qs #'x 0 '()
-         (lambda (b* xnew)
-           (if (eq? xnew #'x)
-               #'(syntax x)
-               (with-syntax (((b ...) b*) (x xnew))
-                 #'(with-syntax (b ...) (syntax x))))))))))
-
-(define-syntax unsyntax
-  (lambda (x)
-    (syntax-error x "misplaced")))
-
-(define-syntax unsyntax-splicing
-  (lambda (x)
-    (syntax-error x "misplaced")))
-
-(define-syntax include
-  (lambda (x)
-    (define read-file
-      (lambda (fn k)
-        (let ((p (open-input-file fn)))
-          (let f ()
-            (let ((x (read p)))
-              (if (eof-object? x)
-                  (begin (close-input-port p) '())
-                  (cons (datum->syntax-object k x) (f))))))))
-    (syntax-case x ()
-      ((k filename)
-       (let ((fn (syntax-object->datum (syntax filename))))
-         (with-syntax (((exp ...) (read-file fn (syntax k))))
-           (syntax (begin exp ...))))))))
-
-(define-syntax case
-  (lambda (x)
-    (syntax-case x ()
-      ((_ e m1 m2 ...)
-       (with-syntax
-         ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
-                  (if (null? clauses)
-                      (syntax-case clause (else)
-                        ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
-                        (((k ...) e1 e2 ...)
-                         (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
-                        (_ (syntax-error x)))
-                      (with-syntax ((rest (f (car clauses) (cdr clauses))))
-                        (syntax-case clause (else)
-                          (((k ...) e1 e2 ...)
-                           (syntax (if (memv t '(k ...))
-                                       (begin e1 e2 ...)
-                                       rest)))
-                          (_ (syntax-error x))))))))
-         (syntax (let ((t e)) body)))))))
-
-(define-syntax identifier-syntax
-  (syntax-rules (set!)
-    ((_ e)
-     (lambda (x)
-       (syntax-case x ()
-         (id (identifier? (syntax id)) (syntax e))
-         ((_ x (... ...)) (syntax (e x (... ...)))))))
-    ((_ (id exp1) ((set! var val) exp2))
-     (and (identifier? (syntax id)) (identifier? (syntax var)))
-     (cons 'macro!
-       (lambda (x)
-         (syntax-case x (set!)
-           ((set! var val) (syntax exp2))
-           ((id x (... ...)) (syntax (exp1 x (... ...))))
-           (id (identifier? (syntax id)) (syntax exp1))))))))
-
-(define-syntax parameterize
-  (lambda (x)
-    (syntax-case x ()
-      [(_ () b b* ...) #'(let () b b* ...)]
-      [(_ ([olhs* orhs*] ...) b b* ...)
-       (with-syntax ([(lhs* ...) (generate-temporaries #'(olhs* ...))]
-                     [(rhs* ...) (generate-temporaries #'(orhs* ...))])
-        #'(let ([lhs* olhs*] ...
-                [rhs* orhs*] ...)
-            (let ([swap
-                   (lambda ()
-                     (let ([t (lhs*)])
-                       (lhs* rhs*)
-                       (set! rhs* t)) ...)])
-              (dynamic-wind
-                swap
-                (lambda () b b* ...)
-                swap))))])))
-
-(define-syntax when
-  (syntax-rules ()
-    [(_ test b b* ...)
-     (if test 
-         (begin b b* ...)
-         (void))]))
-
-(define-syntax unless
-  (syntax-rules ()
-    [(_ test b b* ...)
-     (if test 
-         (void)
-         (begin b b* ...))]))
-
-(define-syntax let-values
-  (lambda (x)
-    (define (bindem n** v**)
-      (syntax-case n** ()
-        [() #'()]
-        [((n* ...) . n**)
-         (syntax-case v** ()
-          [((v* ...) . v**)
-           (with-syntax ([rest (bindem #'n** #'v**)])
-             #'([n* v*] ... . rest))])]))
-    (syntax-case x ()
-      [(_ ([(name** ...) v*] ...) b b* ...)
-       (let ([n**
-              (let f ([n** #'((name** ...) ...)])
-                (syntax-case n** ()
-                  [() #'()]
-                  [(n* . n**)
-                   (with-syntax ([n* (generate-temporaries #'n*)]
-                                 [n** (f #'n**)])
-                     #'(n* . n**))]))])
-         (let f ([t** n**] [v* #'(v* ...)])
-           (syntax-case t** ()
-             [((t* ...) . t**) 
-              (syntax-case v* ()
-                [(v . v*)
-                 (with-syntax ([body (f #'t** #'v*)])
-                   #'(call-with-values
-                       (lambda () v)
-                       (lambda (t* ...) body)))])]
-             [() 
-              (with-syntax ([bind* (bindem #'((name** ...) ...) n**)])
-                #'(let bind* b b* ...))])))])))
-
-
-
-(define-syntax define-record
-  (lambda (x)
-    (syntax-case x ()
-      [(_ name (field* ...)) 
-       (let* ([namestr (symbol->string (syntax-object->datum #'name))]
-              [fields (syntax-object->datum #'(field* ...))]
-              [fieldstr* (map symbol->string fields)]
-              [rtd (make-record-type namestr fields)])
-         (with-syntax ([constr 
-                        (datum->syntax-object #'name
-                          (string->symbol
-                            (string-append "make-" namestr)))]
-                       [pred 
-                        (datum->syntax-object #'name
-                          (string->symbol
-                            (string-append namestr "?")))]
-                       [(i ...)
-                        (datum->syntax-object #'name
-                          (let f ([i 0] [f* fieldstr*])
-                            (cond
-                              [(null? f*) '()]
-                              [else (cons i (f (fxadd1 i) (cdr f*)))])))]
-                       [(getters ...)
-                        (datum->syntax-object #'name
-                          (map (lambda (x)
-                                 (string->symbol 
-                                   (string-append namestr "-" x)))
-                               fieldstr*))]
-                       [(setters ...)
-                        (datum->syntax-object #'name
-                          (map (lambda (x) 
-                                 (string->symbol
-                                   (string-append "set-" namestr "-" x "!")))
-                               fieldstr*))]
-                       [rtd rtd])
-            #'(begin
-                (define-syntax name (cons '$rtd 'rtd))
-                (define constr 
-                  (lambda (field* ...)
-                    ($record 'rtd field* ...)))
-                (define pred
-                  (lambda (x) ($record/rtd? x 'rtd)))
-                (define getters 
-                  (lambda (x)
-                    (if ($record/rtd? x 'rtd) 
-                        ($record-ref x i)
-                        (error 'getters
-                               "~s is not a record of type ~s" x 'rtd)))) ...
-                (define setters 
-                  (lambda (x v)
-                    (if ($record/rtd? x 'rtd) 
-                        ($record-set! x i v)
-                        (error 'setters
-                               "~s is not a record of type ~s" x 'rtd)))) ...
-                )))])))
-
-
-(define-syntax $define-record-syntax
-  (lambda (x)
-    (syntax-case x ()
-      [(_ name (field* ...)) 
-       (let* ([namestr (symbol->string (syntax-object->datum #'name))]
-              [fields (syntax-object->datum #'(field* ...))]
-              [fieldstr* (map symbol->string fields)]
-              [rtd (make-record-type namestr fields)])
-         (with-syntax ([constr 
-                        (datum->syntax-object #'name
-                          (string->symbol
-                            (string-append "make-" namestr)))]
-                       [pred 
-                        (datum->syntax-object #'name
-                          (string->symbol
-                            (string-append namestr "?")))]
-                       [(i ...)
-                        (datum->syntax-object #'name
-                          (let f ([i 0] [f* fieldstr*])
-                            (cond
-                              [(null? f*) '()]
-                              [else (cons i (f (fxadd1 i) (cdr f*)))])))]
-                       [(getters ...)
-                        (datum->syntax-object #'name
-                          (map (lambda (x)
-                                 (string->symbol 
-                                   (string-append namestr "-" x)))
-                               fieldstr*))]
-                       [(setters ...)
-                        (datum->syntax-object #'name
-                          (map (lambda (x) 
-                                 (string->symbol
-                                   (string-append "set-" namestr "-" x "!")))
-                               fieldstr*))]
-                       [rtd rtd])
-            #'(begin
-                (define-syntax name (cons '$rtd 'rtd))
-                (define-syntax constr
-                  (syntax-rules ()
-                    [(_ field* ...) ($record 'rtd field* ...)]))
-                (define-syntax pred
-                  (syntax-rules ()
-                    [(_ x) ($record/rtd? x 'rtd)]))
-                (define-syntax getters 
-                  (syntax-rules ()
-                    [(_ x) ($record-ref x i)])) ...
-                (define-syntax setters 
-                  (syntax-rules ()
-                    [(_ x v) ($record-set! x i v)])) ...
-                )))])))
-
-(define-syntax trace
-  (lambda (x)
-    (syntax-case x ()
-      [(_ id) (identifier? #'id)
-       #'(trace-symbol! 'id)])))
-
-
-(define-syntax untrace
-  (lambda (x)
-    (syntax-case x ()
-      [(_ id) (identifier? #'id)
-       #'(untrace-symbol! 'id)])))
-
-
-(define-syntax trace-lambda
-  (lambda (x)
-    (syntax-case x ()
-      [(_ name args body body* ...)
-       #'(make-traced-procedure 'name (lambda args body body* ...))])))
-
diff --git a/src/psyntax-7.1-9.1.ss b/src/psyntax-7.1.ss
similarity index 100%
rename from src/psyntax-7.1-9.1.ss
rename to src/psyntax-7.1.ss