From b7d19fbfef7f067d0ebb2f4bf375bad729711455 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 9 Feb 2018 20:24:38 -0800 Subject: [PATCH] Implement classify-form-cXr to simplify code slightly. This will be more important when history is added. --- src/runtime/mit-syntax.scm | 27 ++++++++++++++------------- src/runtime/runtime.pkg | 4 ++++ src/runtime/syntax.scm | 16 ++++++++++++++-- 3 files changed, 32 insertions(+), 15 deletions(-) diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm index e7d229596..eaf1036da 100644 --- 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)))) ;;;; 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 17281229c..b06f3b486 100644 --- 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 9b5958657..a34dd921a 100644 --- 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)) ;;;; Compiler -- 2.25.1