From 6c703a838081fe2418bc0dbfe003bdb429d8c479 Mon Sep 17 00:00:00 2001 From: Joe Marshall Date: Mon, 4 Jun 2012 19:58:35 -0700 Subject: [PATCH] Make LETREC and LETREC* be ordinary macros. Avoid adding integrate declarations to procedures with no arguments. --- src/runtime/mit-macros.scm | 44 +++++++++++++++++++++++++++++- src/runtime/mit-syntax.scm | 41 ---------------------------- src/runtime/runtime.pkg | 5 ++-- src/runtime/syntax-definitions.scm | 2 -- src/runtime/syntax-output.scm | 11 -------- 5 files changed, 45 insertions(+), 58 deletions(-) diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index f8860fb5f..245e5869f 100644 --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@ -253,6 +253,45 @@ USA. `(,let-keyword ,bindings ,@body))) `(,let-keyword ,bindings ,@body)))) +(define-syntax :letrec + (er-macro-transformer + (lambda (form rename compare) + (declare (ignore compare)) + (syntax-check '(KEYWORD (* (IDENTIFIER ? EXPRESSION)) + FORM) form) + (let ((bindings (cadr form)) + (r-lambda (rename 'LAMBDA)) + (r-named-lambda (rename 'NAMED-LAMBDA)) + (r-set! (rename 'SET!))) + (let ((temps (map (lambda (binding) + (make-synthetic-identifier + (identifier->symbol (car binding)))) bindings))) + `((,r-named-lambda (,lambda-tag:unnamed ,@(map car bindings)) + ((,r-lambda ,temps + ,@(map (lambda (binding temp) + `(,r-set! ,(car binding) ,temp)) bindings temps)) + ,@(map cadr bindings)) + ((,r-lambda () ,@(cddr form)))) + ,@(map (lambda (binding) + (declare (ignore binding)) + (unassigned-expression)) bindings))))))) + +(define-syntax :letrec* + (er-macro-transformer + (lambda (form rename compare) + (declare (ignore compare)) + (syntax-check '(KEYWORD (* (IDENTIFIER ? EXPRESSION)) + FORM) form) + (let ((bindings (cadr form)) + (r-lambda (rename 'LAMBDA)) + (r-named-lambda (rename 'NAMED-LAMBDA)) + (r-set! (rename 'SET!))) + `((,r-named-lambda (,lambda-tag:unnamed ,@(map car bindings)) + ,@(map (lambda (binding) + `(,r-set! ,@binding)) bindings) + ((,r-lambda () ,@(cddr form)))) + ,@(map (lambda (binding) + (declare (ignore binding)) + (unassigned-expression)) bindings)))))) + (define-syntax :and (er-macro-transformer (lambda (form rename compare) @@ -555,7 +594,10 @@ USA. `(,r-begin (,r-declare (INTEGRATE-OPERATOR ,(caadr form))) (,r-define ,(cadr form) - (,r-declare (INTEGRATE ,@(cdadr form))) + ,@(let ((arguments (cdadr form))) + (if (null? arguments) + '() + `((,r-declare (INTEGRATE ,@arguments))))) ,@(cddr form)))) (else (ill-formed-syntax form))))))) diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm index a2d3a9183..17522c64b 100644 --- a/src/runtime/mit-syntax.scm +++ b/src/runtime/mit-syntax.scm @@ -193,47 +193,6 @@ USA. variable-binding-theory output/let))))) -(define (classifier:letrec form environment definition-environment) - definition-environment - (syntax-check '(KEYWORD (* (IDENTIFIER ? EXPRESSION)) + FORM) form) - (let* ((binding-environment - (make-internal-syntactic-environment environment)) - (value-environment - (make-internal-syntactic-environment binding-environment)) - (body-environment - (make-internal-syntactic-environment binding-environment))) - (for-each (let ((item (make-reserved-name-item))) - (lambda (binding) - (syntactic-environment/define binding-environment - (car binding) - item))) - (cadr form)) - (classify/let-like form - value-environment - binding-environment - body-environment - variable-binding-theory - output/letrec))) - -(define (classifier:letrec* form environment definition-environment) - definition-environment - (syntax-check '(KEYWORD (* (IDENTIFIER ? EXPRESSION)) + FORM) form) - (let* ((binding-environment - (make-internal-syntactic-environment environment)) - (body-environment - (make-internal-syntactic-environment binding-environment))) - (for-each (let ((item (make-reserved-name-item))) - (lambda (binding) - (syntactic-environment/define binding-environment - (car binding) - item))) - (cadr form)) - (classify/let-like form - binding-environment - binding-environment - body-environment - variable-binding-theory - output/letrec*))) (define (classifier:let-syntax form environment definition-environment) definition-environment diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index a52f9aed9..23ee71521 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4696,7 +4696,6 @@ USA. output/lambda output/let output/letrec - output/letrec* output/local-declare output/named-lambda output/post-process-expression @@ -4739,8 +4738,6 @@ USA. classifier:define-syntax classifier:er-macro-transformer classifier:let-syntax - classifier:letrec - classifier:letrec* classifier:letrec-syntax classifier:local-declare classifier:non-hygienic-macro-transformer @@ -4783,6 +4780,8 @@ USA. (let :let) (let* :let*) (let*-syntax :let*-syntax) + (letrec :letrec) + (letrec* :letrec*) (quasiquote :quasiquote) (receive :receive) supported-srfi-features) diff --git a/src/runtime/syntax-definitions.scm b/src/runtime/syntax-definitions.scm index c69e1e2d3..0a1e21b5d 100644 --- a/src/runtime/syntax-definitions.scm +++ b/src/runtime/syntax-definitions.scm @@ -45,8 +45,6 @@ USA. (define-classifier 'DEFINE-SYNTAX classifier:define-syntax) (define-classifier 'ER-MACRO-TRANSFORMER classifier:er-macro-transformer) (define-classifier 'LET-SYNTAX classifier:let-syntax) - (define-classifier 'LETREC classifier:letrec) - (define-classifier 'LETREC* classifier:letrec*) (define-classifier 'LETREC-SYNTAX classifier:letrec-syntax) (define-classifier 'LOCAL-DECLARE classifier:local-declare) (define-classifier 'NON-HYGIENIC-MACRO-TRANSFORMER diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm index 7cfd678d8..272891d93 100644 --- a/src/runtime/syntax-output.scm +++ b/src/runtime/syntax-output.scm @@ -108,17 +108,6 @@ USA. (output/let '() '() body) body)))))))) -(define (output/letrec* names values body) - (output/let - names (map (lambda (name) name (output/unassigned)) names) - (make-sequence - (append! (map make-assignment names values) - (list - (let ((body (scan-defines body make-open-block))) - (if (open-block? body) - (output/let '() '() body) - body))))))) - (define (output/body declarations body) (scan-defines (let ((declarations (apply append declarations))) (if (pair? declarations) -- 2.25.1