From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 11 Feb 2018 07:14:18 +0000 (-0800)
Subject: Implement history mechanism for syntax processor.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~258
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=882f30c399e6ff1f3e7ad16330eb24b1572bc225;p=mit-scheme.git

Implement history mechanism for syntax processor.

This mechanism keeps track of how each subexpression is derived from the larger
program, so that error messages can have that context.

The history isn't yet hooked up to anything; it's just being tracked.  The next
step is to attach it to the syntax errors and change the error messages to
reveal that context.
---

diff --git a/src/edwin/clsmac.scm b/src/edwin/clsmac.scm
index ad7074653..eeb479e66 100644
--- a/src/edwin/clsmac.scm
+++ b/src/edwin/clsmac.scm
@@ -87,7 +87,7 @@ USA.
 (define with-instance-variables
   (make-unmapped-macro-reference-trap
    (compiler-item
-    (lambda (form environment)
+    (lambda (form environment . rest)
       (syntax-check '(_ identifier expression (* identifier) + expression) form)
       (let ((class-name (cadr form))
 	    (self (caddr form))
@@ -96,15 +96,16 @@ USA.
 	(transform-instance-variables
 	 (class-instance-transforms
 	  (name->class (identifier->symbol class-name)))
-	 (compile-expr-item (classify-form self environment))
+	 (compile-expr-item (apply classify-form self environment rest))
 	 free-names
 	 (compile-expr-item
-	  (classify-form
-	   `(,(close-syntax 'begin
-			    (runtime-environment->syntactic
-			     system-global-environment))
-	     ,@body)
-	   environment))))))))
+	  (apply classify-form
+		 `(,(close-syntax 'begin
+				  (runtime-environment->syntactic
+				   system-global-environment))
+		   ,@body)
+		 environment
+		 rest))))))))
 
 (define-syntax ==>
   (syntax-rules ()
diff --git a/src/runtime/integer-bits.scm b/src/runtime/integer-bits.scm
index 5f9a598a0..5281391da 100644
--- a/src/runtime/integer-bits.scm
+++ b/src/runtime/integer-bits.scm
@@ -60,8 +60,8 @@ USA.
 
 ;; (define (shift number amount)
 ;;   (cond ((exact-integer? number) (arithmetic-shift number amount))
-;; 	((flonum? number) (flonum-denormalize number amount))
-;; 	...))
+;;	   ((flonum? number) (flonum-denormalize number amount))
+;;	   ...))
 
 ;;; Eventually the next two should be primitives with nice definitions
 ;;; on bignums requiring only a single copy and nice open-codings for
diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index 43d244ea2..17aea0004 100644
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -32,9 +32,9 @@ USA.
 ;;;; Macro transformers
 
 (define (transformer-keyword procedure-name transformer->expander)
-  (lambda (form senv)
+  (lambda (form senv hist)
     (syntax-check '(_ expression) form)
-    (let ((transformer (compile-expr-item (classify-form-cadr form senv))))
+    (let ((transformer (compile-expr-item (classify-form-cadr form senv hist))))
       (transformer->expander (transformer-eval transformer senv)
 			     senv
 			     (expr-item
@@ -59,16 +59,19 @@ USA.
 
 ;;;; Core primitives
 
-(define (compiler:lambda form senv)
+(define (compiler:lambda form senv hist)
   (syntax-check '(_ mit-bvl + form) form)
-  (compile-lambda scode-lambda-name:unnamed (cadr form) (cddr form) senv))
+  (compile-lambda scode-lambda-name:unnamed
+		  (cadr form)
+		  form senv hist))
 
-(define (compiler:named-lambda form senv)
+(define (compiler:named-lambda form senv hist)
   (syntax-check '(_ (identifier . mit-bvl) + form) form)
-  (compile-lambda (identifier->symbol (caadr form)) (cdadr form) (cddr form)
-		  senv))
+  (compile-lambda (identifier->symbol (caadr form))
+		  (cdadr form)
+		  form senv hist))
 
-(define (compile-lambda name bvl body senv)
+(define (compile-lambda name bvl form senv hist)
   (let ((senv (make-internal-senv senv)))
     ;; Force order -- bind names before classifying body.
     (let ((bvl
@@ -77,42 +80,43 @@ USA.
 				bvl)))
       (output/lambda name
 		     bvl
-		     (compile-body-item (classify-body body senv))))))
+		     (compile-body-item (classify-body-cddr form senv hist))))))
 
 (define (compile-body-item item)
   (output/body (compile-body-items (item->list item))))
 
-(define (classifier:begin form senv)
+(define (classifier:begin form senv hist)
   (syntax-check '(_ * form) form)
-  (classify-body (cdr form) senv))
+  (classify-body-cdr form senv hist))
 
-(define (compiler:if form senv)
+(define (compiler:if form senv hist)
   (syntax-check '(_ expression expression ? expression) form)
   (output/conditional
-   (compile-expr-item (classify-form-cadr form senv))
-   (compile-expr-item (classify-form-caddr form senv))
+   (compile-expr-item (classify-form-cadr form senv hist))
+   (compile-expr-item (classify-form-caddr form senv hist))
    (if (pair? (cdddr form))
-       (compile-expr-item (classify-form-cadddr form senv))
+       (compile-expr-item (classify-form-cadddr form senv hist))
        (output/unspecific))))
 
-(define (compiler:quote form senv)
-  (declare (ignore senv))
+(define (compiler:quote form senv hist)
+  (declare (ignore senv hist))
   (syntax-check '(_ datum) form)
   (output/constant (strip-syntactic-closures (cadr form))))
 
-(define (compiler:quote-identifier form senv)
+(define (compiler:quote-identifier form senv hist)
+  (declare (ignore hist))
   (syntax-check '(_ identifier) form)
   (let ((item (lookup-identifier (cadr form) senv)))
     (if (not (var-item? item))
 	(syntax-error "Can't quote a keyword identifier:" form))
     (output/quoted-identifier (var-item-id item))))
 
-(define (compiler:set! form senv)
+(define (compiler:set! form senv hist)
   (syntax-check '(_ form ? expression) form)
-  (let ((lhs (classify-form-cadr form senv))
+  (let ((lhs (classify-form-cadr form senv hist))
 	(rhs
 	 (if (pair? (cddr form))
-	     (compile-expr-item (classify-form-caddr form senv))
+	     (compile-expr-item (classify-form-caddr form senv hist))
 	     (output/unassigned))))
     (cond ((var-item? lhs)
 	   (output/assignment (var-item-id lhs) rhs))
@@ -123,26 +127,26 @@ USA.
 	  (else
 	   (syntax-error "Variable required in this context:" (cadr form))))))
 
-(define (compiler:delay form senv)
+(define (compiler:delay form senv hist)
   (syntax-check '(_ expression) form)
-  (output/delay (compile-expr-item (classify-form-cadr form senv))))
+  (output/delay (compile-expr-item (classify-form-cadr form senv hist))))
 
 ;;;; Definitions
 
 (define keyword:define
   (classifier->keyword
-   (lambda (form senv)
+   (lambda (form senv hist)
      (let ((name (cadr form)))
        (reserve-identifier name senv)
        (variable-binder defn-item
 			senv
 			name
-			(classify-form-caddr form senv))))))
+			(classify-form-caddr form senv hist))))))
 
-(define (classifier:define-syntax form senv)
+(define (classifier:define-syntax form senv hist)
   (syntax-check '(_ identifier expression) form)
   (let ((name (cadr form))
-	(item (classify-form-caddr form senv)))
+	(item (classify-form-caddr form senv hist)))
     (keyword-binder senv name item)
     ;; User-defined macros at top level are preserved in the output.
     (if (and (senv-top-level? senv)
@@ -164,76 +168,72 @@ USA.
 
 (define keyword:let
   (classifier->keyword
-   (lambda (form env)
-     (let ((bindings (cadr form))
-	   (body (cddr form))
-	   (binding-env (make-internal-senv env)))
-       (let ((bindings
-	      (map (lambda (binding)
-		     (variable-binder cons
-				      binding-env
-				      (car binding)
-				      (classify-form-cadr binding env)))
-		   bindings)))
-	 (expr-item
-	  (let ((names (map car bindings))
-		(values (map cdr bindings))
-		(seq-item
-		 (classify-body
-		  body
-		  (make-internal-senv binding-env))))
-	    (lambda ()
-	      (output/let names
-			  (map compile-expr-item values)
-			  (compile-body-item seq-item))))))))))
-
-(define (classifier:let-syntax form env)
+   (lambda (form senv hist)
+     (let* ((binding-senv (make-internal-senv senv))
+	    (bindings
+	     (map (lambda (binding hist)
+		    (variable-binder cons
+				     binding-senv
+				     (car binding)
+				     (classify-form-cadr binding senv hist)))
+		  (cadr form)
+		  (subform-hists (cadr form) (hist-cadr hist))))
+	    (body-item
+	     (classify-body-cddr form
+				 (make-internal-senv binding-senv)
+				 hist)))
+       (expr-item
+	(let ((names (map car bindings))
+	      (values (map cdr bindings)))
+	  (lambda ()
+	    (output/let names
+			(map compile-expr-item values)
+			(compile-body-item body-item)))))))))
+
+(define (classifier:let-syntax form senv hist)
   (syntax-check '(_ (* (identifier expression)) + form) form)
-  (let ((bindings (cadr form))
-	(body (cddr form))
-	(binding-env (make-internal-senv env)))
-    (for-each (lambda (binding)
-		(keyword-binder binding-env
+  (let ((binding-senv (make-internal-senv senv)))
+    (for-each (lambda (binding hist)
+		(keyword-binder binding-senv
 				(car binding)
-				(classify-form-cadr binding env)))
-	      bindings)
-    (classify-body body (make-internal-senv binding-env))))
+				(classify-form-cadr binding senv hist)))
+	      (cadr form)
+	      (subform-hists (cadr form) (hist-cadr hist)))
+    (classify-body-cddr form
+			(make-internal-senv binding-senv)
+			hist)))
 
 (define keyword:let-syntax
   (classifier->keyword classifier:let-syntax))
 
-(define (classifier:letrec-syntax form env)
+(define (classifier:letrec-syntax form senv hist)
   (syntax-check '(_ (* (identifier expression)) + form) form)
-  (let ((bindings (cadr form))
-	(body (cddr form))
-	(binding-env (make-internal-senv env)))
-    (for-each (lambda (binding)
-		(reserve-identifier (car binding) binding-env))
-	      bindings)
-    ;; Classify right-hand sides first, in order to catch references to
-    ;; reserved names.  Then bind names prior to classifying body.
-    (for-each (lambda (binding item)
-		(keyword-binder binding-env (car binding) item))
-	      bindings
-	      (map (lambda (binding)
-		     (classify-form-cadr binding binding-env))
-		   bindings))
-    (classify-body body (make-internal-senv binding-env))))
+  (let ((binding-senv (make-internal-senv senv)))
+    (let ((bindings (cadr form)))
+      (for-each (lambda (binding)
+		  (reserve-identifier (car binding) binding-senv))
+		bindings)
+      ;; Classify right-hand sides first, in order to catch references to
+      ;; reserved names.  Then bind names prior to classifying body.
+      (for-each (lambda (binding item)
+		  (keyword-binder binding-senv (car binding) item))
+		bindings
+		(map (lambda (binding hist)
+		       (classify-form-cadr binding binding-senv hist))
+		     bindings
+		     (subform-hists bindings (hist-cadr hist)))))
+    (classify-body-cddr form (make-internal-senv binding-senv) hist)))
 
 ;; TODO: this is a compiler rather than a macro because it uses the
 ;; special OUTPUT/DISJUNCTION.  Unfortunately something downstream in
 ;; the compiler wants this, but it would be nice to eliminate this
 ;; hack.
-(define (compiler:or form senv)
+(define (compiler:or form senv hist)
   (syntax-check '(_ * expression) form)
-  (if (pair? (cdr form))
-      (let loop ((expressions (cdr form)))
-	(let ((compiled
-	       (compile-expr-item (classify-form-car expressions senv))))
-	  (if (pair? (cdr expressions))
-	      (output/disjunction compiled (loop (cdr expressions)))
-	      compiled)))
-      `#F))
+  (reduce-right output/disjunction
+		'#f
+		(map compile-expr-item
+		     (classify-forms (cdr form) senv (hist-cdr hist)))))
 
 ;;;; MIT-specific syntax
 
@@ -245,16 +245,17 @@ USA.
 
 (define keyword:access
   (classifier->keyword
-   (lambda (form senv)
+   (lambda (form senv hist)
      (access-item (cadr form)
-		  (classify-form-caddr form senv)))))
+		  (classify-form-caddr form senv hist)))))
 
 (define-item-compiler access-item?
   (lambda (item)
     (output/access-reference (access-item-name item)
 			     (compile-expr-item (access-item-env item)))))
 
-(define (compiler:the-environment form senv)
+(define (compiler:the-environment form senv hist)
+  (declare (ignore hist))
   (syntax-check '(_) form)
   (if (not (senv-top-level? senv))
       (syntax-error "This form allowed only at top level:" form))
@@ -262,36 +263,38 @@ USA.
 
 (define keyword:unspecific
   (compiler->keyword
-   (lambda (form senv)
-     (declare (ignore form senv))
+   (lambda (form senv hist)
+     (declare (ignore form senv hist))
      (output/unspecific))))
 
 (define keyword:unassigned
   (compiler->keyword
-   (lambda (form senv)
-     (declare (ignore form senv))
+   (lambda (form senv hist)
+     (declare (ignore form senv hist))
      (output/unassigned))))
 
 ;;;; Declarations
 
-(define (classifier:declare form senv)
+(define (classifier:declare form senv hist)
   (syntax-check '(_ * (identifier * datum)) form)
   (decl-item
    (lambda ()
-     (classify-decls (cdr form) senv))))
+     (classify-decls (cdr form) senv (hist-cdr hist)))))
 
-(define (classify-decls decls senv)
-  (map (lambda (decl)
-	 (classify-decl decl senv))
-       decls))
+(define (classify-decls decls senv hist)
+  (map (lambda (decl hist)
+	 (classify-decl decl senv hist))
+       decls
+       (subform-hists decls hist)))
 
-(define (classify-decl decl senv)
+(define (classify-decl decl senv hist)
   (map-decl-ids (lambda (id)
-		  (classify-id id senv))
+		  ;; Need to get the right hist here.
+		  (classify-id id senv hist))
 		decl))
 
-(define (classify-id id senv)
-  (let ((item (classify-form id senv)))
+(define (classify-id id senv hist)
+  (let ((item (classify-form id senv hist)))
     (if (not (var-item? item))
 	(syntax-error "Variable required in this context:" id))
     (var-item-id item)))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 23bec3c20..b5ae0da99 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4403,18 +4403,42 @@ USA.
 	  syntax*
 	  syntax-error)
   (export (runtime syntax)
+	  biselect-car
+	  biselect-cdr
+	  biselect-subform
+	  biselector:cadddr
+	  biselector:caddr
+	  biselector:cadr
+	  biselector:car
+	  biselector:cddddr
+	  biselector:cdddr
+	  biselector:cddr
+	  biselector:cdr
+	  biselector:cr
 	  classifier->keyword
 	  classify-body
+	  classify-body-cddr
+	  classify-body-cdr
 	  classify-form
-	  classify-form-car
-	  classify-form-cadr
-	  classify-form-caddr
 	  classify-form-cadddr
+	  classify-form-caddr
+	  classify-form-cadr
+	  classify-form-car
+	  classify-forms
 	  compile-body-items
 	  compile-expr-item
 	  compiler->keyword
 	  define-item-compiler
-	  raw-identifier?))
+	  hist-caddr
+	  hist-cadr
+	  hist-car
+	  hist-cddr
+	  hist-cdr
+	  hist-reduce
+	  hist-select
+	  initial-hist
+	  raw-identifier?
+	  subform-hists))
 
 (define-package (runtime syntax items)
   (files "syntax-items")
diff --git a/src/runtime/syntax-rules.scm b/src/runtime/syntax-rules.scm
index a768083b2..fbbe91413 100644
--- a/src/runtime/syntax-rules.scm
+++ b/src/runtime/syntax-rules.scm
@@ -251,8 +251,8 @@ USA.
 
 (define (syntax-quote expression)
   `(,(compiler->keyword
-      (lambda (form environment)
-	environment			;ignore
+      (lambda (form senv hist)
+	(declare (ignore senv hist))
 	(syntax-check '(_ datum) form)
 	(output/constant (cadr form))))
     ,expression))
diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index a34dd921a..a07b86bab 100644
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -55,43 +55,66 @@ USA.
     (with-identifier-renaming
      (lambda ()
        (if (senv-top-level? senv)
-	   (compile-top-level-body (classify-body forms senv))
+	   (%compile-top-level-body (%classify-body-top-level forms senv))
 	   (output/sequence
-	    (map (lambda (expr)
-		   (compile-expr-item (classify-form expr senv)))
+	    (map (lambda (form)
+		   (compile-expr-item
+		    (%classify-form-top-level form senv)))
 		 forms)))))))
+
+(define (%classify-form-top-level form senv)
+  (classify-form form senv (initial-hist form)))
+
+(define (%classify-body-top-level forms senv)
+  (seq-item
+   (map-in-order (lambda (form)
+		   (%classify-form-top-level form senv))
+		 forms)))
+
+(define (%compile-top-level-body item)
+  (output/top-level-sequence
+   (map (lambda (item)
+	  (if (defn-item? item)
+	      (let ((name (defn-item-id item))
+		    (value (compile-expr-item (defn-item-value item))))
+		(if (defn-item-syntax? item)
+		    (output/top-level-syntax-definition name value)
+		    (output/top-level-definition name value)))
+	      (compile-expr-item item)))
+	(item->list item))))
 
 ;;;; Classifier
 
-(define (classify-form form senv)
+(define (classify-form form senv hist)
   (cond ((identifier? form)
 	 (lookup-identifier form senv))
 	((syntactic-closure? form)
-	 (classify-form
-	  (syntactic-closure-form form)
-	  (make-partial-senv (syntactic-closure-free form)
-			     senv
-			     (syntactic-closure-senv form))))
+	 (classify-form (syntactic-closure-form form)
+			(make-partial-senv (syntactic-closure-free form)
+					   senv
+					   (syntactic-closure-senv form))
+			hist))
 	((pair? form)
-	 (let ((item (classify-form-car form senv)))
+	 (let ((item (classify-form-car form senv hist)))
 	   (cond ((classifier-item? item)
-		  ((classifier-item-impl item) form senv))
+		  ((classifier-item-impl item) form senv hist))
 		 ((compiler-item? item)
 		  (expr-item
 		   (let ((compiler (compiler-item-impl item)))
 		     (lambda ()
-		       (compiler form senv)))))
+		       (compiler form senv hist)))))
 		 ((expander-item? item)
-		  (classify-form ((expander-item-impl item) form senv)
-				 senv))
+		  (reclassify ((expander-item-impl item) form senv)
+			      senv
+			      hist))
 		 (else
 		  (if (not (list? (cdr form)))
 		      (syntax-error "Combination must be a proper list:" form))
 		  (expr-item
 		   (let ((items
-			  (map (lambda (expr)
-				 (classify-form expr senv))
-			       (cdr form))))
+			  (classify-forms (cdr form)
+					  senv
+					  (hist-cdr hist))))
 		     (lambda ()
 		       (output/combination
 			(compile-expr-item item)
@@ -99,43 +122,44 @@ USA.
 	(else
 	 (expr-item (lambda () (output/constant form))))))
 
-(define (classify-body forms senv)
+(define (classify-form-car form senv hist)
+  (classify-form (car form) senv (hist-car hist)))
+
+(define (classify-form-cadr form senv hist)
+  (classify-form (cadr form) senv (hist-cadr hist)))
+
+(define (classify-form-caddr form senv hist)
+  (classify-form (caddr form) senv (hist-caddr hist)))
+
+(define (classify-form-cadddr form senv hist)
+  (classify-form (cadddr form) senv (hist-cadddr hist)))
+
+(define (classify-forms forms senv hist)
+  (map (lambda (expr hist)
+	 (classify-form expr senv hist))
+       forms
+       (subform-hists forms hist)))
+
+(define (reclassify form env hist)
+  (classify-form form env (hist-reduce form hist)))
+
+(define (classify-body forms senv hist)
   ;; Syntactic definitions affect all forms that appear after them, so classify
   ;; FORMS in order.
   (seq-item
-   (let loop ((forms forms) (items '()))
-     (if (pair? forms)
-	 (loop (cdr forms)
-	       (reverse* (item->list (classify-form-car forms senv))
-			 items))
-	 (reverse! items)))))
-
-(define (classify-form-car form senv)
-  (classify-form (car form) senv))
+   (map-in-order (lambda (form hist)
+		   (classify-form form senv hist))
+		 forms
+		 (subform-hists forms hist))))
 
-(define (classify-form-cadr form senv)
-  (classify-form (cadr form) senv))
+(define (classify-body-cdr form senv hist)
+  (classify-body (cdr form) senv (hist-cdr hist)))
 
-(define (classify-form-caddr form senv)
-  (classify-form (caddr form) senv))
-
-(define (classify-form-cadddr form senv)
-  (classify-form (cadddr form) senv))
+(define (classify-body-cddr form senv hist)
+  (classify-body (cddr form) senv (hist-cddr hist)))
 
 ;;;; Compiler
 
-(define (compile-top-level-body item)
-  (output/top-level-sequence
-   (map (lambda (item)
-	  (if (defn-item? item)
-	      (let ((name (defn-item-id item))
-		    (value (compile-expr-item (defn-item-value item))))
-		(if (defn-item-syntax? item)
-		    (output/top-level-syntax-definition name value)
-		    (output/top-level-definition name value)))
-	      (compile-expr-item item)))
-	(item->list item))))
-
 (define (compile-body-items items)
   (let ((items (flatten-items items)))
     (if (not (pair? items))
@@ -281,6 +305,94 @@ USA.
 	     (eq? (var-item-id item-1)
 		  (var-item-id item-2))))))
 
+;;;; History
+
+(define-record-type <history>
+    (%history records)
+    history?
+  (records %history-records))
+
+(define (initial-hist form)
+  (%history (list form)))
+
+(define (hist-select selector hist)
+  (%history
+   (let ((records (%history-records hist)))
+     (if (and (pair? records)
+	      (eq? 'select (caar records)))
+	 (cons (cons 'select (biselect-append selector (cdar records)))
+	       (cdr records))
+	 (cons (cons 'select selector)
+	       records)))))
+
+(define (hist-reduce form hist)
+  (%history (cons (cons 'reduce form) (%history-records hist))))
+
+(define (hist-car hist)
+  (hist-select biselector:car hist))
+
+(define (hist-cdr hist)
+  (hist-select biselector:cdr hist))
+
+(define (hist-cadr hist)
+  (hist-select biselector:cadr hist))
+
+(define (hist-cddr hist)
+  (hist-select biselector:cddr hist))
+
+(define (hist-caddr hist)
+  (hist-select biselector:caddr hist))
+
+(define (hist-cdddr hist)
+  (hist-select biselector:cdddr hist))
+
+(define (hist-cadddr hist)
+  (hist-select biselector:cadddr hist))
+
+(define (subform-hists forms hist)
+  (let loop ((forms forms) (hist hist))
+    (if (pair? forms)
+	(cons (hist-car hist)
+	      (loop (cdr forms) (hist-cdr hist)))
+	'())))
+
+;;;; Binary selectors
+
+(define (biselect-car selector)
+  (let ((n (integer-length selector)))
+    (+ (shift-left 1 n)
+       (- selector (shift-left 1 (- n 1))))))
+
+(define (biselect-cdr selector)
+  (+ (shift-left 1 (integer-length selector))
+     selector))
+
+(define (biselect-subform selector form)
+  (if (> selector 1)
+      (biselect-subform (quotient selector 2)
+			(if (even? selector) (car form) (cdr form)))
+      form))
+
+;; Selector order is:
+;; (= biselector:cadr (biselect-append biselector:car biselector:cdr))
+(define (biselect-append . selectors)
+  (reduce (lambda (s1 s2)
+	    (let ((n (- (integer-length s1) 1)))
+	      (+ (shift-left s2 n)
+		 (- s1 (shift-left 1 n)))))
+	  biselector:cr
+	  selectors))
+
+(define-integrable biselector:cr     #b00001)
+(define-integrable biselector:car    #b00010)
+(define-integrable biselector:cdr    #b00011)
+(define-integrable biselector:cadr   #b00101)
+(define-integrable biselector:cddr   #b00111)
+(define-integrable biselector:caddr  #b01011)
+(define-integrable biselector:cdddr  #b01111)
+(define-integrable biselector:cadddr #b10111)
+(define-integrable biselector:cddddr #b11111)
+
 ;;;; Utilities
 
 (define (syntax-error . rest)
@@ -297,11 +409,18 @@ USA.
 
 (define (capture-syntactic-environment expander)
   `(,(classifier->keyword
-      (lambda (form senv)
+      (lambda (form senv hist)
 	(declare (ignore form))
-	(classify-form (expander senv) senv)))))
+	(classify-form (expander senv) senv hist)))))
 
 (define (reverse-syntactic-environments senv procedure)
   (capture-syntactic-environment
    (lambda (closing-senv)
-     (close-syntax (procedure closing-senv) senv))))
\ No newline at end of file
+     (close-syntax (procedure closing-senv) senv))))
+
+(define (map-in-order procedure . lists)
+  (let loop ((lists lists) (values '()))
+    (if (pair? (car lists))
+	(loop (map cdr lists)
+	      (cons (apply procedure (map car lists)) values))
+	(reverse! values))))
\ No newline at end of file