From b2bdc634e4053f938a90085a9bf64a1829b96b61 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 19 Jan 2018 20:01:56 -0800 Subject: [PATCH] Rewrite define-like and let-like syntax for simplicity. --- src/runtime/mit-syntax.scm | 175 ++++++++++++++++--------------------- 1 file changed, 77 insertions(+), 98 deletions(-) diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm index dff676ab2..ce96390a0 100644 --- a/src/runtime/mit-syntax.scm +++ b/src/runtime/mit-syntax.scm @@ -85,6 +85,12 @@ USA. (compile-body-item (classify/body body environment)))))) +(define (compile-body-item item) + (receive (declaration-items items) + (extract-declarations-from-body (body-item/components item)) + (output/body (map declaration-item/text declaration-items) + (compile-body-items items)))) + (define (classifier:begin form environment) (syntax-check '(KEYWORD * FORM) form) (classify/body (cdr form) environment)) @@ -136,123 +142,96 @@ USA. (define keyword:define (classifier->keyword (lambda (form environment) - (classify/define form environment variable-binding-theory)))) + (let ((name (cadr form))) + (if (not (syntactic-environment/top-level? environment)) + (syntactic-environment/define environment + name + (make-reserved-name-item))) + (value-binder environment name + (classify/expression (caddr form) environment)))))) (define (classifier:define-syntax form environment) - (syntax-check '(KEYWORD IDENTIFIER EXPRESSION) form) - (classify/define form environment syntactic-binding-theory)) - -(define (classify/define form environment binding-theory) - (if (not (syntactic-environment/top-level? environment)) - (syntactic-environment/define environment - (cadr form) - (make-reserved-name-item))) - (binding-theory environment - (cadr form) - (classify/expression (caddr form) environment))) - -(define (syntactic-binding-theory environment name item) + (syntax-check '(keyword identifier expression) form) + (let ((name (cadr form)) + (item (classify/expression (caddr form) environment))) + (keyword-binder environment name item) + ;; User-defined macros at top level are preserved in the output. + (if (and (keyword-value-item? item) + (syntactic-environment/top-level? environment)) + (make-binding-item (rename-top-level-identifier name) item) + (make-body-item '())))) + +(define (keyword-binder environment name item) (if (not (keyword-item? item)) (syntax-error "Syntactic binding value must be a keyword:" name)) - (syntactic-environment/define environment name item) - ;; User-defined macros at top level are preserved in the output. - (if (and (keyword-value-item? item) - (syntactic-environment/top-level? environment)) - (make-binding-item (rename-top-level-identifier name) item) - (make-null-binding-item))) - -(define (variable-binding-theory environment name item) + (syntactic-environment/define environment name item)) + +(define (value-binder environment name item) (if (keyword-item? item) - (syntax-error "Binding value may not be a keyword:" name)) + (syntax-error "Normal binding value must not be a keyword:" name)) (make-binding-item (bind-variable! environment name) item)) ;;;; LET-like (define keyword:let (classifier->keyword - (lambda (form environment) - (let* ((binding-environment - (make-internal-syntactic-environment environment)) - (body-environment - (make-internal-syntactic-environment binding-environment))) - (classify/let-like form - environment - binding-environment - body-environment - variable-binding-theory - output/let))))) - - -(define (classifier:let-syntax form environment) - (syntax-check '(KEYWORD (* (IDENTIFIER EXPRESSION)) + FORM) form) - (let* ((binding-environment - (make-internal-syntactic-environment environment)) - (body-environment - (make-internal-syntactic-environment binding-environment))) - (classify/let-like form - environment - binding-environment - body-environment - syntactic-binding-theory - output/let))) + (lambda (form env) + (let ((bindings (cadr form)) + (body (cddr form)) + (binding-env (make-internal-syntactic-environment env))) + (let ((binding-items + (map (lambda (binding) + (value-binder binding-env + (car binding) + (classify/expression (cadr binding) env))) + bindings))) + (make-expression-item + (let ((names (map binding-item/name binding-items)) + (values (map binding-item/value binding-items)) + (body-item + (classify/body (cddr form) + (make-internal-syntactic-environment + binding-env)))) + (lambda () + (output/let names + (map compile-item/expression values) + (compile-body-item body-item)))))))))) + +(define (classifier:let-syntax form env) + (syntax-check '(keyword (* (identifier expression)) + form) form) + (let ((bindings (cadr form)) + (body (cddr form)) + (binding-env (make-internal-syntactic-environment env))) + (for-each (lambda (binding) + (keyword-binder binding-env + (car binding) + (classify/expression (cadr binding) env))) + bindings) + (classify/body body (make-internal-syntactic-environment binding-env)))) (define keyword:let-syntax (classifier->keyword classifier:let-syntax)) -(define (classifier:letrec-syntax form environment) - (syntax-check '(KEYWORD (* (IDENTIFIER EXPRESSION)) + FORM) form) - (let* ((binding-environment - (make-internal-syntactic-environment environment)) - (body-environment - (make-internal-syntactic-environment binding-environment))) +(define (classifier:letrec-syntax form env) + (syntax-check '(keyword (* (identifier expression)) + form) form) + (let ((bindings (cadr form)) + (body (cddr form)) + (binding-env (make-internal-syntactic-environment env))) (for-each (let ((item (make-reserved-name-item))) (lambda (binding) - (syntactic-environment/define binding-environment + (syntactic-environment/define binding-env (car binding) item))) - (cadr form)) - (classify/let-like form - binding-environment - binding-environment - body-environment - syntactic-binding-theory - output/letrec))) - -(define (classify/let-like form - value-environment - binding-environment - body-environment - binding-theory - output/let) - ;; Classify right-hand sides first, in order to catch references to - ;; reserved names. Then bind names prior to classifying body. - (let* ((bindings - (remove! null-binding-item? - (map (lambda (binding item) - (binding-theory binding-environment - (car binding) - item)) - (cadr form) - (map (lambda (binding) - (classify/expression (cadr binding) - value-environment)) - (cadr form))))) - (body (classify/body (cddr form) body-environment))) - (if (eq? binding-theory syntactic-binding-theory) - body - (make-expression-item - (let ((names (map binding-item/name bindings)) - (values (map binding-item/value bindings))) - (lambda () - (output/let names - (map compile-item/expression values) - (compile-body-item body)))))))) - -(define (compile-body-item item) - (receive (declaration-items items) - (extract-declarations-from-body (body-item/components item)) - (output/body (map declaration-item/text declaration-items) - (compile-body-items items)))) + 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/expression (cadr binding) binding-env)) + bindings)) + (classify/body body (make-internal-syntactic-environment binding-env)))) ;; TODO: this is a compiler rather than a macro because it uses the ;; special OUTPUT/DISJUNCTION. Unfortunately something downstream in -- 2.25.1