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 ad7074653be056b394b1221dcdace195c2abfb79..eeb479e6667dd10c9ee7d93d91f3e1927b165326 100644 (file)
--- 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 5f9a598a0957c8c3ba66b69c61e6c9753bf0bcc3..5281391da06a23ab994834c3949b0dbf15af0437 100644 (file)
--- 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))
+;;        ...))
 \f
 ;;; 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 43d244ea2ef2d791c0e6809529ea6c44e809c097..17aea000457d99074737cb7f1ec16599749abe37 100644 (file)
--- 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.
 \f
 ;;;; 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))))
 \f
 ;;;; 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)))))
 \f
 ;;;; 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))))
 \f
 ;;;; 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 23bec3c2077659afd9a51541d722b51c49b6c54b..b5ae0da995eb3a7b64e10a647dc14fad67d7ef5a 100644 (file)
--- 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 a768083b27dd68a59c8583c5f143b34e42b0105d..fbbe9141347ecb14825d14fcfc88b41e260c8cf7 100644 (file)
--- 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 a34dd921ad4792ac0bc3c01efeefc9ebc0400e58..a07b86bab72f5166712d56f4e6062fa81bfbc042 100644 (file)
--- 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))))
 \f
 ;;;; 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)))
 \f
 ;;;; 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))))))
 \f
+;;;; 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)))
+       '())))
+\f
+;;;; 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)
+\f
 ;;;; 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