From: Joe Marshall Date: Mon, 13 Feb 2012 21:04:49 +0000 (-0800) Subject: Add LETREC*. Convert LETREC to R6RS semantics. Use internal definition for expansio... X-Git-Tag: release-9.2.0~302 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=70e1d7c10133bbef65ab7abbafd695d773da5ffa;p=mit-scheme.git Add LETREC*. Convert LETREC to R6RS semantics. Use internal definition for expansion of named let. --- diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index 94d9e92d4..4888170f1 100644 --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@ -164,7 +164,7 @@ USA. (else (ill-formed-syntax form)))) -(define named-let-strategy 'letrec) +(define named-let-strategy 'internal-definition) (define-syntax :let (er-macro-transformer @@ -175,39 +175,48 @@ USA. (let ((name (cadr form)) (bindings (caddr form)) (body (cdddr form))) - (case named-let-strategy - ((letrec) - `((,(rename 'LETREC) - ((,name (,(rename 'NAMED-LAMBDA) (,name ,@(map car bindings)) - ,@body))) - ,name) - ,@(map (lambda (binding) - (if (pair? (cdr binding)) - (cadr binding) - (unassigned-expression))) - bindings))) - ((fixed-point) - (let ((iter (make-synthetic-identifier 'ITER)) - (kernel (make-synthetic-identifier 'KERNEL)) - (temps (map (lambda (b) - (declare (ignore b)) - (make-synthetic-identifier 'TEMP)) bindings)) - (r-lambda (rename 'LAMBDA)) - (r-declare (rename 'DECLARE))) - `((,r-lambda (,kernel) - (,kernel ,kernel ,@(map (lambda (binding) - (if (pair? (cdr binding)) - (cadr binding) - (unassigned-expression))) - bindings))) - (,r-lambda (,iter ,@(map car bindings)) - ((,r-lambda (,name) - (,r-declare (INTEGRATE-OPERATOR ,name)) - ,@body) - (,r-lambda ,temps - (,r-declare (INTEGRATE ,@temps)) - (,iter ,iter ,@temps))))))) - (else (error "Unrecognized named-let-strategy: " named-let-strategy))))) + (let ((vars (map car bindings)) + (vals (map (lambda (binding) + (if (pair? (cdr binding)) + (cadr binding) + (unassigned-expression))) + bindings))) + (case named-let-strategy + ((fixed-point) + (let ((iter (make-synthetic-identifier 'ITER)) + (kernel (make-synthetic-identifier 'KERNEL)) + (temps (map (lambda (b) + (declare (ignore b)) + (make-synthetic-identifier 'TEMP)) bindings)) + (r-lambda (rename 'LAMBDA)) + (r-declare (rename 'DECLARE))) + `((,r-lambda (,kernel) + (,kernel ,kernel ,@vals)) + (,r-lambda (,iter ,@vars) + ((,r-lambda (,name) + (,r-declare (INTEGRATE-OPERATOR ,name)) + ,@body) + (,r-lambda ,temps + (,r-declare (INTEGRATE ,@temps)) + (,iter ,iter ,@temps))))))) + ((internal-definition) + `((,(rename 'LET) () + (,(rename 'DEFINE) (,name ,@vars) ,@body) + ,name) + ,@vals)) + ((letrec) + `((,(rename 'LETREC) + ((,name (,(rename 'NAMED-LAMBDA) (,name ,@vars) + ,@body))) + ,name) + ,@vals)) + ((letrec*) + `((,(rename 'LETREC*) + ((,name (,(rename 'NAMED-LAMBDA) (,name ,@vars) + ,@body))) + ,name) + ,@vals)) + (else (error "Unrecognized named-let-strategy: " named-let-strategy)))))) ((syntax-match? '((* (IDENTIFIER ? EXPRESSION)) + FORM) (cdr form)) `(,keyword:let ,@(cdr (normalize-let-bindings form)))) (else diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm index e0ea9a417..a2d3a9183 100644 --- a/src/runtime/mit-syntax.scm +++ b/src/runtime/mit-syntax.scm @@ -2,8 +2,8 @@ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007, 2008, 2009, 2010, 2011 Massachusetts Institute of - Technology + 2006, 2007, 2008, 2009, 2010, 2011, 2012 Massachusetts Institute + of Technology This file is part of MIT/GNU Scheme. @@ -25,6 +25,7 @@ USA. |# ;;;; MIT/GNU Scheme Syntax +;;; package: (runtime syntax mit) (declare (usual-integrations)) @@ -197,6 +198,8 @@ USA. (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))) @@ -206,11 +209,31 @@ USA. item))) (cadr form)) (classify/let-like form - binding-environment + 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 93039f657..7159dab86 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4694,6 +4694,7 @@ USA. output/lambda output/let output/letrec + output/letrec* output/local-declare output/named-lambda output/post-process-expression @@ -4737,6 +4738,7 @@ USA. classifier:er-macro-transformer classifier:let-syntax classifier:letrec + classifier:letrec* classifier:letrec-syntax classifier:local-declare classifier:non-hygienic-macro-transformer diff --git a/src/runtime/syntax-definitions.scm b/src/runtime/syntax-definitions.scm index 10df021ce..8a2d96502 100644 --- a/src/runtime/syntax-definitions.scm +++ b/src/runtime/syntax-definitions.scm @@ -25,6 +25,7 @@ USA. |# ;;;; Code to install syntax keywords in global environment +;;; package: (runtime syntax definitions) (declare (usual-integrations)) @@ -45,6 +46,7 @@ USA. (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 a8ee5d5b9..7cfd678d8 100644 --- a/src/runtime/syntax-output.scm +++ b/src/runtime/syntax-output.scm @@ -2,8 +2,8 @@ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007, 2008, 2009, 2010, 2011 Massachusetts Institute of - Technology + 2006, 2007, 2008, 2009, 2010, 2011, 2012 Massachusetts Institute + of Technology This file is part of MIT/GNU Scheme. @@ -25,6 +25,7 @@ USA. |# ;;;; Syntaxer Output Interface +;;; package: (runtime syntax output) (declare (usual-integrations)) @@ -89,14 +90,34 @@ USA. (output/combination (output/named-lambda lambda-tag:let names body) values)) (define (output/letrec names values body) - (output/let '() '() - (make-sequence - (append! (map make-definition names values) - (list - (let ((body (scan-defines body make-open-block))) - (if (open-block? body) - (output/let '() '() body) - body))))))) + (let ((temps (map (lambda (name) + (utf8-string->uninterned-symbol + (string-append (symbol-name (identifier->symbol name)) + "-value"))) names))) + (output/let + names (map (lambda (name) name (output/unassigned)) names) + (make-sequence + (cons (output/let + temps values + (make-sequence (map (lambda (name temp) + (make-assignment name (make-variable temp))) + names temps))) + (list + (let ((body (scan-defines body make-open-block))) + (if (open-block? body) + (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)))