~ chicken-core (chicken-5) a647d9ed65f44df527e513464093447f56e24ead
commit a647d9ed65f44df527e513464093447f56e24ead
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Aug 1 11:52:57 2013 +0200
Commit: Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sat Aug 3 12:21:57 2013 +0200
Adds "letrec*" and minimal tests. "letrec*" ist not used explicitly and only in internal expansions to avoid bootstrapping issues. Internal defines expand into uses of "letrec*".
Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
diff --git a/NEWS b/NEWS
index 2d9ab2bc..4d96844e 100644
--- a/NEWS
+++ b/NEWS
@@ -25,6 +25,8 @@
- For R7RS compatibility, named character literals #\escape and #\null are
supported as aliases for #\esc and #\nul. WRITE will output R7RS names.
- The CASE form accepts => proc syntax, like COND (as specified by R7RS).
+ - letrec* was added for R7RS compatibility. Plain letrec no longer behaves
+ like letrec*.
- Compiler
- the "inline" declaration does not force inlining anymore as recursive
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index ce1bdf6d..29ed89d2 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -422,6 +422,7 @@
`(,%let-values (,(car vbindings))
,(fold (cdr vbindings))) ) ) ))))
+;;XXX do we need letrec*-values ?
(##sys#extend-macro-environment
'letrec-values '()
(##sys#er-transformer
@@ -1056,11 +1057,11 @@
(##sys#check-syntax 'rec form '(_ _ . _))
(let ((head (cadr form)))
(if (pair? head)
- `(##core#letrec ((,(car head)
- (##core#lambda ,(cdr head)
- ,@(cddr form))))
- ,(car head))
- `(##core#letrec ((,head ,@(cddr form))) ,head))))))
+ `(##core#letrec* ((,(car head)
+ (##core#lambda ,(cdr head)
+ ,@(cddr form))))
+ ,(car head))
+ `(##core#letrec* ((,head ,@(cddr form))) ,head))))))
;;; Definitions available at macroexpansion-time:
diff --git a/compiler.scm b/compiler.scm
index 3cadc6b1..0398eefb 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -105,6 +105,7 @@
; (##core#let <variable> ({(<variable> <exp>)}) <body>)
; (##core#let ({(<variable> <exp>)}) <body>)
; (##core#letrec ({(<variable> <exp>)}) <body>)
+; (##core#letrec* ({(<variable> <exp>)}) <body>)
; (##core#let-location <symbol> <type> [<init>] <exp>)
; (##core#lambda <variable> <body>)
; (##core#lambda ({<variable>}+ [. <variable>]) <body>)
@@ -616,7 +617,7 @@
(append aliases e)
se2 dest ldest h ln) ) ) )
- ((##core#letrec)
+ ((##core#letrec*)
(let ((bindings (cadr x))
(body (cddr x)) )
(walk
@@ -630,6 +631,24 @@
(##core#let () ,@body) )
e se dest ldest h ln)))
+ ((##core#letrec)
+ (let* ((bindings (cadr x))
+ (vars (unzip1 bindings))
+ (tmps (map gensym vars))
+ (body (cddr x)) )
+ (walk
+ `(##core#let
+ ,(map (lambda (b)
+ (list (car b) '(##core#undefined)))
+ bindings)
+ (##core#let
+ ,(map (lambda (t b) (list t (cadr b))) tmps bindings)
+ ,@(map (lambda (v t)
+ `(##core#set! ,v ,t))
+ vars tmps)
+ (##core#let () ,@body) ) )
+ e se dest ldest h ln)))
+
((##core#lambda)
(let ((llist (cadr x))
(obody (cddr x)) )
diff --git a/eval.scm b/eval.scm
index 4adc6964..607246b6 100644
--- a/eval.scm
+++ b/eval.scm
@@ -436,7 +436,7 @@
(##sys#setslot v2 i (##core#app (##sys#slot vlist 0) v)) )
(##core#app body (cons v2 v)) ) ) ) ] ) ) ]
- ((##core#letrec)
+ ((##core#letrec*)
(let ((bindings (cadr x))
(body (cddr x)) )
(compile
@@ -450,6 +450,23 @@
(##core#let () ,@body) )
e h tf cntr se)))
+ ((##core#letrec)
+ (let* ((bindings (cadr x))
+ (vars (map car bindings))
+ (tmps (map gensym vars))
+ (body (cddr x)) )
+ (compile
+ `(##core#let
+ ,(map (lambda (b)
+ (list (car b) '(##core#undefined)))
+ bindings)
+ (##core#let ,(map (lambda (t b) (list t (cadr b))) tmps bindings)
+ ,@(map (lambda (v t)
+ `(##core#set! ,v ,t))
+ vars tmps)
+ (##core#let () ,@body) ) )
+ e h tf cntr se)))
+
[(##core#lambda)
(##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f se)
(let* ([llist (cadr x)]
diff --git a/expand.scm b/expand.scm
index d5f3652f..2f34df36 100644
--- a/expand.scm
+++ b/expand.scm
@@ -277,7 +277,7 @@
(let ([bs (cadr body)])
(values
`(##core#app
- (##core#letrec
+ (##core#letrec*
([,bindings
(##core#loop-lambda
,(map (lambda (b) (car b)) bs) ,@(cddr body))])
@@ -1049,6 +1049,15 @@
(check-for-multiple-bindings (cadr x) x "let")))
`(##core#let ,@(cdr x)))))
+(##sys#extend-macro-environment
+ 'letrec*
+ '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax 'letrec* x '(_ #((symbol _) 0) . #(_ 1)))
+ (check-for-multiple-bindings (cadr x) x "letrec*")
+ `(##core#letrec* ,@(cdr x)))))
+
(##sys#extend-macro-environment
'letrec
'()
diff --git a/extras.scm b/extras.scm
index f6daf1c2..49ab5cf2 100644
--- a/extras.scm
+++ b/extras.scm
@@ -557,7 +557,7 @@
(define (style head)
(case head
- ((lambda let* letrec define) pp-lambda)
+ ((lambda let* letrec letrec* define) pp-lambda)
((if set!) pp-if)
((cond) pp-cond)
((case) pp-case)
diff --git a/manual/Non-standard macros and special forms b/manual/Non-standard macros and special forms
index ee222838..728ce3b0 100644
--- a/manual/Non-standard macros and special forms
+++ b/manual/Non-standard macros and special forms
@@ -172,6 +172,13 @@ executed normally and the result of the last expression is the
result of the {{and-let*}} form. See also the documentation for
[[http://srfi.schemers.org/srfi-2/srfi-2.html|SRFI-2]].
+==== letrec*
+
+<macro>(letrec* ((VARIABLE EXPRESSION) ...) BODY ...)</macro>
+
+Implements R6RS/R7RS {{letrec*}}. {{letrec*}} is similar to {{letrec}} but
+binds the variables sequentially and is to {{letrec}} what {{let*}} is to {{let}}.
+
==== rec
<macro>(rec NAME EXPRESSION)</macro><br>
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index c4962700..a5f4323b 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -1100,3 +1100,19 @@ take
((_) (begin (define req 2) (display req) (newline)))))
(bar)
(assert (eq? req 1)))
+
+
+;; letrec vs. letrec*
+
+;;XXX this fails - the optimizer substitutes "foo" for it's known constant value
+#;(t (void) (letrec ((foo 1)
+ (bar foo))
+ bar))
+
+(t (void) (letrec ((foo (gc))
+ (bar foo))
+ bar))
+
+(t 1 (letrec* ((foo 1)
+ (bar foo))
+ bar))
Trap