Implement classify-form-cXr to simplify code slightly.

This will be more important when history is added.

diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index e7d229596f8e18cc58e0078c886eac7afa130513..eaf1036da07eebb3d467228a5b0a6560c7bfb3b9 100644 (file)
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -34,7 +34,7 @@ USA.
 (define (transformer-keyword procedure-name transformer->expander)
   (lambda (form senv)
     (syntax-check '(KEYWORD EXPRESSION) form)
-    (let ((transformer (compile-expr-item (classify-form (cadr form) senv))))
+    (let ((transformer (compile-expr-item (classify-form-cadr form senv))))
       (transformer->expander (transformer-eval transformer senv)
                             senv
                             (expr-item
@@ -92,10 +92,10 @@ USA.
 (define (compiler:if form senv)
   (syntax-check '(KEYWORD 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))
+   (compile-expr-item (classify-form-caddr form senv))
    (if (pair? (cdddr form))
-       (compile-expr-item (classify-form (cadddr form) senv))
+       (compile-expr-item (classify-form-cadddr form senv))
        (output/unspecific))))
 
 (define (compiler:quote form senv)
@@ -116,7 +116,7 @@ USA.
       (classify/location (cadr form) senv)
     (let ((value
           (if (pair? (cddr form))
-              (compile-expr-item (classify-form (caddr form) senv))
+              (compile-expr-item (classify-form-caddr form senv))
               (output/unassigned))))
       (if environment-item
          (output/access-assignment
@@ -136,7 +136,7 @@ USA.
 
 (define (compiler:delay form senv)
   (syntax-check '(KEYWORD EXPRESSION) form)
-  (output/delay (compile-expr-item (classify-form (cadr form) senv))))
+  (output/delay (compile-expr-item (classify-form-cadr form senv))))
 \f
 ;;;; Definitions
 
@@ -148,12 +148,12 @@ USA.
        (variable-binder defn-item
                        senv
                        name
-                       (classify-form (caddr form) senv))))))
+                       (classify-form-caddr form senv))))))
 
 (define (classifier:define-syntax form senv)
   (syntax-check '(keyword identifier expression) form)
   (let ((name (cadr form))
-       (item (classify-form (caddr form) senv)))
+       (item (classify-form-caddr form senv)))
     (keyword-binder senv name item)
     ;; User-defined macros at top level are preserved in the output.
     (if (and (senv-top-level? senv)
@@ -184,7 +184,7 @@ USA.
                     (variable-binder cons
                                      binding-env
                                      (car binding)
-                                     (classify-form (cadr binding) env)))
+                                     (classify-form-cadr binding env)))
                   bindings)))
         (expr-item
          (let ((names (map car bindings))
@@ -206,7 +206,7 @@ USA.
     (for-each (lambda (binding)
                (keyword-binder binding-env
                                (car binding)
-                               (classify-form (cadr binding) env)))
+                               (classify-form-cadr binding env)))
              bindings)
     (classify-body body (make-internal-senv binding-env))))
 
@@ -227,7 +227,7 @@ USA.
                (keyword-binder binding-env (car binding) item))
              bindings
              (map (lambda (binding)
-                    (classify-form (cadr binding) binding-env))
+                    (classify-form-cadr binding binding-env))
                   bindings))
     (classify-body body (make-internal-senv binding-env))))
 
@@ -239,7 +239,8 @@ USA.
   (syntax-check '(KEYWORD * EXPRESSION) form)
   (if (pair? (cdr form))
       (let loop ((expressions (cdr form)))
-       (let ((compiled (compile-expr-item (classify-form (car expressions) senv))))
+       (let ((compiled
+              (compile-expr-item (classify-form-car expressions senv))))
          (if (pair? (cdr expressions))
              (output/disjunction compiled (loop (cdr expressions)))
              compiled)))
@@ -257,7 +258,7 @@ USA.
   (classifier->keyword
    (lambda (form senv)
      (make-access-item (cadr form)
-                      (classify-form (caddr form) senv)))))
+                      (classify-form-caddr form senv)))))
 
 (define-item-compiler access-item?
   (lambda (item)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 17281229c253a663bbaa82f7671f812c3101489f..b06f3b4867f058cce0f35722472a526cc99747d2 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4406,6 +4406,10 @@ USA.
          classifier->keyword
          classify-body
          classify-form
+         classify-form-car
+         classify-form-cadr
+         classify-form-caddr
+         classify-form-cadddr
          compile-body-items
          compile-expr-item
          compiler->keyword

diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index 9b59586571b41f0d6d6d738c01a4eeb33c9f2713..a34dd921ad4792ac0bc3c01efeefc9ebc0400e58 100644 (file)
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -73,7 +73,7 @@ USA.
                             senv
                             (syntactic-closure-senv form))))
        ((pair? form)
-        (let ((item (classify-form (car form) senv)))
+        (let ((item (classify-form-car form senv)))
           (cond ((classifier-item? item)
                  ((classifier-item-impl item) form senv))
                 ((compiler-item? item)
@@ -106,9 +106,21 @@ USA.
    (let loop ((forms forms) (items '()))
      (if (pair? forms)
         (loop (cdr forms)
-              (reverse* (item->list (classify-form (car forms) senv))
+              (reverse* (item->list (classify-form-car forms senv))
                         items))
         (reverse! items)))))
+
+(define (classify-form-car form senv)
+  (classify-form (car form) senv))
+
+(define (classify-form-cadr form senv)
+  (classify-form (cadr form) senv))
+
+(define (classify-form-caddr form senv)
+  (classify-form (caddr form) senv))
+
+(define (classify-form-cadddr form senv)
+  (classify-form (cadddr form) senv))
 \f
 ;;;; Compiler