X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/5a0132b3375b35c69c6afb735acbaa8619237fb5..696495f4d21fc8bc479b50588c08ea55e7c6e3a7:/module/ice-9/psyntax.scm

diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 0af35dca9..fd7ad5906 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -22,6 +22,9 @@
 ;;; Extracted from Chez Scheme Version 5.9f
 ;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
 
+;;; Modified by Andy Wingo <wingo@pobox.com> according to the Git
+;;; revision control logs corresponding to this file: 2009.
+
 ;;; Modified by Mikael Djurfeldt <djurfeldt@nada.kth.se> according
 ;;; to the ChangeLog distributed in the same directory as this file:
 ;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24,
@@ -81,44 +84,12 @@
 ;;;      Revision 3, for a complete description)
 ;;;   (syntax-violation who message form [subform])
 ;;;      used to report errors found during expansion
-;;;   (install-global-transformer symbol value)
-;;;      used by expanded code to install top-level syntactic abstractions
 ;;;   ($sc-dispatch e p)
 ;;;      used by expanded code to handle syntax-case matching
 
 ;;; The following nonstandard procedures must be provided by the
-;;; implementation for this code to run.
-;;;
-;;; (void)
-;;; returns the implementation's cannonical "unspecified value".  This
-;;; 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)))))))))
-;;;
-;;; 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,
+;;; hooks and output constructors. They are not used by expanded code,
 ;;; and so need be present only at expansion time.
 ;;;
 ;;; (eval x)
@@ -134,21 +105,8 @@
 ;;; 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
-;;;
-;;; (putprop symbol key value)
-;;; (getprop symbol key)
-;;; key is always the symbol *sc-expander*; value may be any object.
-;;; putprop should associate the given value with the given symbol in
-;;; some way that it can be retrieved later with getprop.
 
 ;;; When porting to a new Scheme implementation, you should define the
 ;;; procedures listed above, load the expanded version of psyntax.ss
@@ -260,6 +218,25 @@
   (set-current-module (resolve-module '(guile))))
 
 (let ()
+;;; Private version of and-map that handles multiple lists.
+(define and-map*
+  (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)))))))))
+
 (define-syntax define-structure
   (lambda (x)
     (define construct-name
@@ -275,7 +252,7 @@
                         args))))))
     (syntax-case x ()
       ((_ (name id1 ...))
-       (andmap identifier? (syntax (name id1 ...)))
+       (and-map identifier? (syntax (name id1 ...)))
        (with-syntax
          ((constructor (construct-name (syntax name) "make-" (syntax name)))
           (predicate (construct-name (syntax name) (syntax name) "?"))
@@ -313,6 +290,7 @@
 
 (let ()
 (define noexpand "noexpand")
+(define *mode* (make-fluid))
 
 ;;; hooks to nonportable run-time helpers
 (begin
@@ -323,15 +301,19 @@
 
 (define top-level-eval-hook
   (lambda (x mod)
-    (primitive-eval `(,noexpand ,x))))
+    (primitive-eval
+     `(,noexpand
+       ,(case (fluid-ref *mode*)
+          ((c) ((@ (language tree-il) tree-il->scheme) x))
+          (else x))))))
 
 (define local-eval-hook
   (lambda (x mod)
-    (primitive-eval `(,noexpand ,x))))
-
-(define error-hook
-  (lambda (who why what)
-    (error who "~a ~s" why what)))
+    (primitive-eval
+     `(,noexpand
+       ,(case (fluid-ref *mode*)
+          ((c) ((@ (language tree-il) tree-il->scheme) x))
+          (else x))))))
 
 (define-syntax gensym-hook
   (syntax-rules ()
@@ -339,123 +321,184 @@
 
 (define put-global-definition-hook
   (lambda (symbol type val)
-    (module-define-keyword! (current-module) symbol type val)))
-
-(define remove-global-definition-hook
-  (lambda (symbol)
-    (module-undefine-keyword! (current-module) symbol)))
+    (let ((existing (let ((v (module-variable (current-module) symbol)))
+                      (and v (variable-bound? v)
+                           (let ((val (variable-ref v)))
+                             (and (macro? val)
+                                  (not (syncase-macro-type val))
+                                  val))))))
+      (module-define! (current-module)
+                      symbol
+                      (if existing
+                          (make-extended-syncase-macro existing type val)
+                          (make-syncase-macro type val))))))
 
 (define get-global-definition-hook
   (lambda (symbol module)
     (if (and (not module) (current-module))
         (warn "module system is booted, we should have a module" symbol))
-    (module-lookup-keyword (if module (resolve-module (cdr module))
-                               (current-module))
-                           symbol)))
+    (let ((v (module-variable (if module
+                                  (resolve-module (cdr module))
+                                  (current-module))
+                              symbol)))
+      (and v (variable-bound? v)
+           (let ((val (variable-ref v)))
+             (and (macro? val) (syncase-macro-type val)
+                  (cons (syncase-macro-type val)
+                        (syncase-macro-binding val))))))))
 
 )
 
 
 ;;; output constructors
-(define (build-annotated src exp)
-  (if (and src (not (annotation? exp)))
-      (make-annotation exp src #t)
-      exp))
-
-(define-syntax build-application
-  (syntax-rules ()
-    ((_ source fun-exp arg-exps)
-     (build-annotated source `(,fun-exp . ,arg-exps)))))
-
-(define-syntax build-conditional
-  (syntax-rules ()
-    ((_ source test-exp then-exp else-exp)
-     (build-annotated source `(if ,test-exp ,then-exp ,else-exp)))))
-
-(define-syntax build-lexical-reference
-  (syntax-rules ()
-    ((_ type source var)
-     (build-annotated source var))))
-
-(define-syntax build-lexical-assignment
-  (syntax-rules ()
-    ((_ source var exp)
-     (build-annotated source `(set! ,var ,exp)))))
-
-(define-syntax build-global-reference
-  (syntax-rules ()
-    ((_ source var mod)
-     (build-annotated
-      source
-      (if mod
-          (make-module-ref (cdr mod) var (car mod))
-          (make-module-ref mod var 'bare))))))
-
-(define-syntax build-global-assignment
-  (syntax-rules ()
-    ((_ source var exp mod)
-     (build-annotated source
-       `(set! ,(if mod
-                   (make-module-ref (cdr mod) var (car mod))
-                   (make-module-ref mod var 'bare))
-              ,exp)))))
-
-(define-syntax build-global-definition
-  (syntax-rules ()
-    ((_ source var exp mod)
-     (build-annotated source `(define ,var ,exp)))))
-
-(define-syntax build-lambda
-  (syntax-rules ()
-    ((_ src vars docstring exp)
-     (build-annotated src `(lambda ,vars ,@(if docstring (list docstring) '())
-                                   ,exp)))
-    ((_ src vars exp)
-     (build-annotated src `(lambda ,vars ,exp)))))
-
-;; FIXME: wingo: add modules here somehow?
-(define-syntax build-primref
-  (syntax-rules ()
-    ((_ src name) (build-annotated src name))
-    ((_ src level name) (build-annotated src name))))
+(define build-application
+  (lambda (source fun-exp arg-exps)
+    (case (fluid-ref *mode*)
+      ((c) ((@ (language tree-il) make-application) source fun-exp arg-exps))
+      (else `(,fun-exp . ,arg-exps)))))
+
+(define build-conditional
+  (lambda (source test-exp then-exp else-exp)
+    (case (fluid-ref *mode*)
+      ((c) ((@ (language tree-il) make-conditional)
+            source test-exp then-exp else-exp))
+      (else `(if ,test-exp ,then-exp ,else-exp)))))
+
+(define build-lexical-reference
+  (lambda (type source name var)
+    (case (fluid-ref *mode*)
+      ((c) ((@ (language tree-il) make-lexical-ref) source name var))
+      (else var))))
+
+(define build-lexical-assignment
+  (lambda (source name var exp)
+    (case (fluid-ref *mode*)
+      ((c) ((@ (language tree-il) make-lexical-set) source name var exp))
+      (else `(set! ,var ,exp)))))
+
+;; Before modules are booted, we can't expand into data structures from
+;; (language tree-il) -- we need to give the evaluator the
+;; s-expressions that it understands natively. Actually the real truth
+;; of the matter is that the evaluator doesn't understand tree-il
+;; structures at all. So until we fix the evaluator, if ever, the
+;; conflation that we should use tree-il iff we are compiling
+;; holds true.
+;;
+(define (analyze-variable mod var modref-cont bare-cont)
+  (if (not mod)
+      (bare-cont var)
+      (let ((kind (car mod))
+            (mod (cdr mod)))
+        (case kind
+          ((public) (modref-cont mod var #t))
+          ((private) (if (not (equal? mod (module-name (current-module))))
+                         (modref-cont mod var #f)
+                         (bare-cont var)))
+          ((bare) (bare-cont var))
+          ((hygiene) (if (and (not (equal? mod (module-name (current-module))))
+                              (module-variable (resolve-module mod) var))
+                         (modref-cont mod var #f)
+                         (bare-cont var)))
+          (else (syntax-violation #f "bad module kind" var mod))))))
+
+(define build-global-reference
+  (lambda (source var mod)
+    (analyze-variable
+     mod var
+     (lambda (mod var public?) 
+       (case (fluid-ref *mode*)
+         ((c) ((@ (language tree-il) make-module-ref) source mod var public?))
+         (else (list (if public? '@ '@@) mod var))))
+     (lambda (var)
+       (case (fluid-ref *mode*)
+         ((c) ((@ (language tree-il) make-toplevel-ref) source var))
+         (else var))))))
+
+(define build-global-assignment
+  (lambda (source var exp mod)
+    (analyze-variable
+     mod var
+     (lambda (mod var public?) 
+       (case (fluid-ref *mode*)
+         ((c) ((@ (language tree-il) make-module-set) source mod var public? exp))
+         (else `(set! ,(list (if public? '@ '@@) mod var) ,exp))))
+     (lambda (var)
+       (case (fluid-ref *mode*)
+         ((c) ((@ (language tree-il) make-toplevel-set) source var exp))
+         (else `(set! ,var ,exp)))))))
+
+(define build-global-definition
+  (lambda (source var exp)
+    (case (fluid-ref *mode*)
+      ((c) ((@ (language tree-il) make-toplevel-define) source var exp))
+      (else `(define ,var ,exp)))))
+
+(define build-lambda
+  (lambda (src ids vars docstring exp)
+    (case (fluid-ref *mode*)
+      ((c) ((@ (language tree-il) make-lambda) src ids vars
+            (if docstring `((documentation . ,docstring)) '())
+            exp))
+      (else `(lambda ,vars ,@(if docstring (list docstring) '())
+                     ,exp)))))
+
+(define build-primref
+  (lambda (src name)
+    (case (fluid-ref *mode*)
+      ((c) ((@ (language tree-il) make-primitive-ref) src name))
+      ;; hygiene guile is a hack
+      (else (build-global-reference src name '(hygiene guile))))))
 
 (define (build-data src exp)
-  (if (and (self-evaluating? exp)
-	   (not (vector? exp)))
-      (build-annotated src exp)
-      (build-annotated src (list 'quote exp))))
+  (case (fluid-ref *mode*)
+    ((c) ((@ (language tree-il) make-const) src exp))
+    (else (if (and (self-evaluating? exp) (not (vector? exp)))
+              exp
+              (list 'quote exp)))))
 
 (define build-sequence
   (lambda (src exps)
     (if (null? (cdr exps))
-        (build-annotated src (car exps))
-        (build-annotated src `(begin ,@exps)))))
+        (car exps)
+        (case (fluid-ref *mode*)
+          ((c) ((@ (language tree-il) make-sequence) src exps))
+          (else `(begin ,@exps))))))
 
 (define build-let
-  (lambda (src vars val-exps body-exp)
+  (lambda (src ids vars val-exps body-exp)
     (if (null? vars)
-	(build-annotated src body-exp)
-	(build-annotated src `(let ,(map list vars val-exps) ,body-exp)))))
+	body-exp
+        (case (fluid-ref *mode*)
+          ((c) ((@ (language tree-il) make-let) src ids vars val-exps body-exp))
+          (else `(let ,(map list vars val-exps) ,body-exp))))))
 
 (define build-named-let
-  (lambda (src vars val-exps body-exp)
-    (if (null? vars)
-	(build-annotated src body-exp)
-	(build-annotated src
-                         `(let ,(car vars)
-                            ,(map list (cdr vars) val-exps) ,body-exp)))))
+  (lambda (src ids vars val-exps body-exp)
+    (let ((f (car vars))
+          (f-name (car ids))
+          (vars (cdr vars))
+          (ids (cdr ids)))
+      (case (fluid-ref *mode*)
+        ((c) ((@ (language tree-il) make-letrec) src
+              (list f-name)
+              (list f)
+              (list (build-lambda src ids vars #f body-exp))
+              (build-application src (build-lexical-reference 'fun src f-name f)
+                                 val-exps)))
+        (else `(let ,f ,(map list vars val-exps) ,body-exp))))))
 
 (define build-letrec
-  (lambda (src vars val-exps body-exp)
+  (lambda (src ids vars val-exps body-exp)
     (if (null? vars)
-        (build-annotated src body-exp)
-        (build-annotated src
-                         `(letrec ,(map list vars val-exps) ,body-exp)))))
+        body-exp
+        (case (fluid-ref *mode*)
+          ((c) ((@ (language tree-il) make-letrec) src ids vars val-exps body-exp))
+          (else `(letrec ,(map list vars val-exps) ,body-exp))))))
 
-;; FIXME: wingo: use make-lexical
+;; FIXME: wingo: use make-lexical ?
 (define-syntax build-lexical-var
   (syntax-rules ()
-    ((_ src id) (build-annotated src (gensym (symbol->string id))))))
+    ((_ src id) (gensym (symbol->string id)))))
 
 (define-structure (syntax-object expression wrap module))
 
@@ -480,7 +523,7 @@
   (syntax-rules ()
     ((_ pred? e who)
      (let ((x e))
-       (if (not (pred? x)) (error-hook who "invalid argument" x))))))
+       (if (not (pred? x)) (syntax-violation who "invalid argument" x))))))
 
 ;;; compile-time environments
 
@@ -800,7 +843,7 @@
       ((annotation? id)
        (let ((id (unannotate id)))
          (or (first (search id (wrap-subst w) (wrap-marks w))) id)))
-      (else (error-hook 'id-var-name "invalid id" id)))))
+      (else (syntax-violation 'id-var-name "invalid id" id)))))
 
 ;;; 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.
@@ -893,12 +936,30 @@
             (let ((first (chi-top (car body) r w m esew mod)))
               (cons first (dobody (cdr body) r w m esew mod))))))))
 
-;; FIXME: module?
 (define chi-install-global
   (lambda (name e)
-    (build-application no-source
-      (build-primref no-source 'install-global-transformer)
-      (list (build-data no-source name) e))))
+    (build-global-definition
+     no-source
+     name
+     ;; FIXME: seems nasty to call current-module here
+     (if (let ((v (module-variable (current-module) name)))
+           ;; FIXME use primitive-macro?
+           (and v (variable-bound? v) (macro? (variable-ref v))
+                (not (eq? (macro-type (variable-ref v)) 'syncase-macro))))
+         (build-application
+          no-source
+          (build-primref no-source 'make-extended-syncase-macro)
+          (list (build-application
+                 no-source
+                 (build-primref no-source 'module-ref)
+                 (list (build-application no-source 'current-module '())
+                       (build-data no-source name)))
+                (build-data no-source 'macro)
+                e))
+         (build-application
+          no-source
+          (build-primref no-source 'make-syncase-macro)
+          (list (build-data no-source 'macro) e))))))
 
 (define chi-when-list
   (lambda (e when-list w)
@@ -1006,7 +1067,7 @@
                     ((_ name)
                      (id? (syntax name))
                      (values 'define-form (wrap (syntax name) w mod)
-                       (syntax (void))
+                       (syntax (if #f #f))
                        empty-wrap s mod))))
                  ((define-syntax)
                   (syntax-case e ()
@@ -1098,18 +1159,13 @@
            (let* ((n (id-var-name value w))
 		  (type (binding-type (lookup n r mod))))
              (case type
-               ((global)
+               ((global core macro module-ref)
                 (eval-if-c&e m
-                  (build-global-definition s n (chi e r w mod) mod)
+                  (build-global-definition s n (chi e r w mod))
                   mod))
                ((displaced-lexical)
                 (syntax-violation #f "identifier out of context"
                                   e (wrap value w mod)))
-               ((core macro module-ref)
-                (remove-global-definition-hook n)
-                (eval-if-c&e m
-                  (build-global-definition s n (chi e r w mod) mod)
-                  mod))
                (else
                 (syntax-violation #f "cannot define keyword at top level"
                                   e (wrap value w mod))))))
@@ -1126,7 +1182,7 @@
   (lambda (type value e r w s mod)
     (case type
       ((lexical)
-       (build-lexical-reference 'value s value))
+       (build-lexical-reference 'value s e value))
       ((core external-macro)
        ;; apply transformer
        (value e r w s mod))
@@ -1136,7 +1192,8 @@
          (lambda (id mod) (build-global-reference s id mod))))
       ((lexical-call)
        (chi-application
-         (build-lexical-reference 'fun (source-annotation (car e)) value)
+         (build-lexical-reference 'fun (source-annotation (car e))
+                                  (car e) value)
          e r w s mod))
       ((global-call)
        (chi-application
@@ -1337,6 +1394,7 @@
                                        (loop (cdr bs) er-cache r-cache)))))
                            (set-cdr! r (extend-env labels bindings (cdr r)))
                            (build-letrec no-source
+                             (map syntax->datum ids)
                              vars
                              (map (lambda (x)
                                     (chi (cdr x) (car x) empty-wrap mod))
@@ -1359,7 +1417,8 @@
              (syntax-violation 'lambda "invalid parameter list" e)
              (let ((labels (gen-labels ids))
                    (new-vars (map gen-var ids)))
-               (k new-vars
+               (k (map syntax->datum ids)
+                  new-vars
                   docstring
                   (chi-body (syntax (e1 e2 ...))
                             e
@@ -1372,7 +1431,11 @@
              (syntax-violation 'lambda "invalid parameter list" e)
              (let ((labels (gen-labels old-ids))
                    (new-vars (map gen-var old-ids)))
-               (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
+               (k (let f ((ls1 (cdr old-ids)) (ls2 (car old-ids)))
+                    (if (null? ls1)
+                        (syntax->datum ls2)
+                        (f (cdr ls1) (cons (syntax->datum (car ls1)) ls2))))
+                  (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
                     (if (null? ls1)
                         ls2
                         (f (cdr ls1) (cons (car ls1) ls2))))
@@ -1420,7 +1483,7 @@
 
 (define chi-void
   (lambda ()
-    (build-application no-source (build-primref no-source 'void) '())))
+    (build-application no-source (build-primref no-source 'if) '(#f #f))))
 
 (define ellipsis?
   (lambda (x)
@@ -1477,7 +1540,7 @@
             ((vector? x)
              (let ((old (vector->list x)))
                 (let ((new (map f old)))
-                   (if (andmap eq? old new) x (list->vector new)))))
+                   (if (and-map* eq? old new) x (list->vector new)))))
             (else x))))))
 
 ;;; lexical variables
@@ -1651,7 +1714,7 @@
              ; identity map equivalence:
              ; (map (lambda (x) x) y) == y
              (car actuals))
-            ((andmap
+            ((and-map
                 (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
                 (cdr e))
              ; eta map equivalence:
@@ -1691,16 +1754,15 @@
     (define regen
       (lambda (x)
         (case (car x)
-          ((ref) (build-lexical-reference 'value no-source (cadr x)))
+          ((ref) (build-lexical-reference 'value no-source (cadr x) (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))))
+          ((lambda) (build-lambda no-source (cadr x) (cadr x) #f (regen (caddr x))))
           ((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
+                     ;; this check used to be here, not sure what for:
+                     ;; (if (fx= (length ls) 2)
+                     (build-primref no-source 'map)
                      ls)))
           (else (build-application no-source
                   (build-primref no-source (car x))
@@ -1721,7 +1783,8 @@
       (syntax-case e ()
          ((_ . c)
           (chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod
-            (lambda (vars docstring body) (build-lambda s vars docstring body)))))))
+            (lambda (names vars docstring body)
+              (build-lambda s names vars docstring body)))))))
 
 
 (global-extend 'core 'let
@@ -1734,6 +1797,7 @@
 	    (let ((nw (make-binding-wrap ids labels w))
 		  (nr (extend-var-env labels new-vars r)))
 	      (constructor s
+                           (map syntax->datum ids)
 			   new-vars
 			   (map (lambda (x) (chi x r w mod)) vals)
 			   (chi-body exps (source-wrap e nw s mod)
@@ -1768,6 +1832,7 @@
                (let ((w (make-binding-wrap ids labels w))
                     (r (extend-var-env labels new-vars r)))
                  (build-letrec s
+                   (map syntax->datum ids)
                    new-vars
                    (map (lambda (x) (chi x r w mod)) (syntax (val ...)))
                    (chi-body (syntax (e1 e2 ...)) 
@@ -1785,7 +1850,10 @@
          (let ((b (lookup n r mod)))
            (case (binding-type b)
              ((lexical)
-              (build-lexical-assignment s (binding-value b) val))
+              (build-lexical-assignment s
+                                        (syntax->datum (syntax id))
+                                        (binding-value b)
+                                        val))
              ((global) (build-global-assignment s n val mod))
              ((displaced-lexical)
               (syntax-violation 'set! "identifier out of context"
@@ -1813,7 +1881,7 @@
    (lambda (e)
      (syntax-case e ()
         ((_ (mod ...) id)
-         (and (andmap id? (syntax (mod ...))) (id? (syntax id)))
+         (and (and-map id? (syntax (mod ...))) (id? (syntax id)))
          (values (syntax->datum (syntax id))
                  (syntax->datum
                   (syntax (public mod ...))))))))
@@ -1822,7 +1890,7 @@
    (lambda (e)
      (syntax-case e ()
         ((_ (mod ...) id)
-         (and (andmap id? (syntax (mod ...))) (id? (syntax id)))
+         (and (and-map id? (syntax (mod ...))) (id? (syntax id)))
          (values (syntax->datum (syntax id))
                  (syntax->datum
                   (syntax (private mod ...))))))))
@@ -1875,7 +1943,7 @@
           (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
+              (list (build-lambda no-source (map syntax->datum ids) new-vars #f
                       (chi exp
                            (extend-env
                             labels
@@ -1896,14 +1964,15 @@
             (cond
               ((not (distinct-bound-ids? (map car pvars)))
                (syntax-violation 'syntax-case "duplicate pattern variable" pat))
-              ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
+              ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
                (syntax-violation 'syntax-case "misplaced ellipsis" pat))
               (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 ((y (build-lexical-reference 'value no-source y)))
+                   (build-lambda no-source (list 'tmp) (list y) #f
+                     (let ((y (build-lexical-reference 'value no-source
+                                                       'tmp y)))
                        (build-conditional no-source
                          (syntax-case fender ()
                            (#t y)
@@ -1930,12 +1999,14 @@
             (syntax-case (car clauses) ()
               ((pat exp)
                (if (and (id? (syntax pat))
-                        (andmap (lambda (x) (not (free-id=? (syntax pat) x)))
-                          (cons (syntax (... ...)) keys)))
+                        (and-map (lambda (x) (not (free-id=? (syntax pat) x)))
+                                 (cons (syntax (... ...)) keys)))
                    (let ((labels (list (gen-label)))
                          (var (gen-var (syntax pat))))
                      (build-application no-source
-                       (build-lambda no-source (list var)
+                       (build-lambda no-source
+                                     (list (syntax->datum (syntax pat))) (list var)
+                                     #f
                          (chi (syntax exp)
                               (extend-env labels
                                 (list (make-binding 'syntax `(,var . 0)))
@@ -1956,13 +2027,14 @@
       (let ((e (source-wrap e w s mod)))
         (syntax-case e ()
           ((_ val (key ...) m ...)
-           (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
-                       (syntax (key ...)))
+           (if (and-map (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 s
-                   (build-lambda no-source (list x)
-                     (gen-syntax-case (build-lexical-reference 'value no-source x)
+                   (build-lambda no-source (list 'tmp) (list x) #f
+                     (gen-syntax-case (build-lexical-reference 'value no-source
+                                                               'tmp x)
                        (syntax (key ...)) (syntax (m ...))
                        r
                        mod))
@@ -1979,26 +2051,17 @@
 ;;; expanded, and the expanded definitions are also residualized into
 ;;; the object file if we are compiling a file.
 (set! sc-expand
-  (let ((m 'e) (esew '(eval)))
-    (lambda (x)
-      (if (and (pair? x) (equal? (car x) noexpand))
-          (cadr x)
-          (chi-top x null-env top-wrap m esew
-                   (cons 'hygiene (module-name (current-module))))))))
-
-(set! sc-expand3
-  (let ((m 'e) (esew '(eval)))
-    (lambda (x . rest)
-      (if (and (pair? x) (equal? (car x) noexpand))
-          (cadr x)
-          (chi-top x
-		   null-env
-		   top-wrap
-		   (if (null? rest) m (car rest))
-		   (if (or (null? rest) (null? (cdr rest)))
-		       esew
-		       (cadr rest))
-                   (cons 'hygiene (module-name (current-module))))))))
+      (lambda (x . rest)
+        (if (and (pair? x) (equal? (car x) noexpand))
+            (cadr x)
+            (let ((m (if (null? rest) 'e (car rest)))
+                  (esew (if (or (null? rest) (null? (cdr rest)))
+                            '(eval)
+                            (cadr rest))))
+              (with-fluid* *mode* m
+                (lambda ()
+                  (chi-top x null-env top-wrap m esew
+                           (cons 'hygiene (module-name (current-module))))))))))
 
 (set! identifier?
   (lambda (x)
@@ -2047,12 +2110,6 @@
                  (if who (cons who tail) tail))
                #f)))
 
-(set! install-global-transformer
-  (lambda (sym v)
-    (arg-check symbol? sym 'define-syntax)
-    (arg-check procedure? v 'define-syntax)
-    (global-extend 'macro sym v)))
-
 ;;; $sc-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
@@ -2200,7 +2257,7 @@
   (lambda (x)
     (syntax-case x ()
       ((let* ((x v) ...) e1 e2 ...)
-       (andmap identifier? (syntax (x ...)))
+       (and-map identifier? (syntax (x ...)))
        (let f ((bindings (syntax ((x v)  ...))))
          (if (null? bindings)
              (syntax (let () e1 e2 ...))
@@ -2301,20 +2358,20 @@
            (syntax (begin exp ...))))))))
 
 (define-syntax unquote
-   (lambda (x)
-      (syntax-case x ()
-         ((_ e)
-          (error 'unquote
-		 "expression ,~s not valid outside of quasiquote"
-		 (syntax->datum (syntax e)))))))
+  (lambda (x)
+    (syntax-case x ()
+      ((_ e)
+       (syntax-violation 'unquote
+                         "expression not valid outside of quasiquote"
+                         x)))))
 
 (define-syntax unquote-splicing
-   (lambda (x)
-      (syntax-case x ()
-         ((_ e)
-          (error 'unquote-splicing
-		 "expression ,@~s not valid outside of quasiquote"
-		 (syntax->datum (syntax e)))))))
+  (lambda (x)
+    (syntax-case x ()
+      ((_ e)
+       (syntax-violation 'unquote-splicing
+                         "expression not valid outside of quasiquote"
+                         x)))))
 
 (define-syntax case
   (lambda (x)