~ chicken-core (chicken-5) c9220247dbcdf6fd39697b428cfd40068244219a
commit c9220247dbcdf6fd39697b428cfd40068244219a
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sat Feb 25 21:04:45 2017 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Mar 22 11:15:54 2017 +0100
Change the way LET bodies are macro-expanded.
A macro might expand into a define. That means we need to keep
expanding the body and restart the main expansion process when we
encounter a define. Instead of returning the original expressions
when wrapping up, we should return the macro-expanded expressions,
because macros should be called exactly once to be safe in the
presence of side-effects.
We now also treat ##core#begin as a reason to restart the expansion
process, because nested begins can contain definitions as well. The
expansion will recursively eliminate those nested begins.
There is some special treatment for ##core#module and "import",
because those do all kinds of nasty side-effecting things which ensure
we can't simply expand the body in one go. Import is one of those
aforementioned side-effecting macros, and the core module form is also
side-effecting in a way: we can't refer to the module until it has
been processed by the compiler.
There could be other macros and special forms that are allowed in let
bodies but need special processing. This situation needs to be
addressed properly and fixed in general, but for now we can fix them
by adding more special cases. Note that this is not a newly
introduced problem: there have always been such issues, but due to
the obscure workings of ##sys#canonicalize-body they would only
surface under very specific conditions.
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/expand.scm b/expand.scm
index 9ee0140b..b1a91ebb 100644
--- a/expand.scm
+++ b/expand.scm
@@ -480,6 +480,7 @@
(define define-definition)
(define define-syntax-definition)
(define define-values-definition)
+(define import-definition)
(define ##sys#canonicalize-body
(lambda (body #!optional (se (##sys#current-environment)) cs?)
@@ -490,24 +491,52 @@
((define) (if f (eq? f define-definition) (eq? s id)))
((define-syntax) (if f (eq? f define-syntax-definition) (eq? s id)))
((define-values) (if f (eq? f define-values-definition) (eq? s id)))
+ ((import) (if f (eq? f import-definition) (eq? s id)))
(else (eq? s id))))))
(define (fini vars vals mvars body)
(if (and (null? vars) (null? mvars))
- (let loop ([body2 body] [exps '()])
- (if (not (pair? body2))
- (cons
+ ;; Macro-expand body, and restart when defines are found.
+ (let loop ((body body) (exps '()))
+ (if (not (pair? body))
+ (cons
'##core#begin
- body) ; no more defines, otherwise we would have called `expand'
- (let ((x (car body2)))
- (if (and (pair? x)
- (let ((d (car x)))
- (and (symbol? d)
- (or (comp 'define d)
- (comp 'define-values d)))))
- (cons
- '##core#begin
- (##sys#append (reverse exps) (list (expand body2))))
- (loop (cdr body2) (cons x exps)) ) ) ) )
+ (reverse exps)) ; no more defines, otherwise we would have called `expand'
+ (let loop2 ((body body))
+ (let ((x (car body))
+ (rest (cdr body)))
+ (if (and (pair? x)
+ (let ((d (car x)))
+ (and (symbol? d)
+ (or (comp 'define d)
+ (comp 'define-values d)
+ (comp 'define-syntax d)
+ (comp '##core#begin d)
+ (comp 'import d)))))
+ ;; Stupid hack to avoid expanding imports
+ (if (comp 'import (car x))
+ (loop rest (cons x exps))
+ (cons
+ '##core#begin
+ (##sys#append (reverse exps) (list (expand body)))))
+ (let ((x2 (##sys#expand-0 x se cs?)))
+ (if (eq? x x2)
+ ;; Modules must be registered before we
+ ;; can continue with other forms, so
+ ;; hand back control to the compiler
+ (if (and (pair? x)
+ (symbol? (car x))
+ (comp '##core#module (car x)))
+ `(##core#begin
+ ,@(reverse exps)
+ ,x
+ ,@(if (null? rest)
+ '()
+ `((##core#let () ,@rest))))
+ (loop rest (cons x exps)))
+ (loop2 (cons x2 rest)) )) ))) ))
+ ;; We saw defines. Translate to letrec, and let compiler
+ ;; call us again for the remaining body by wrapping the
+ ;; remaining body forms in a ##core#let.
(let* ((result
`(##core#let
,(##sys#map
@@ -549,6 +578,8 @@
(defjam-error def))
(loop (cdr body) (cons def defs) #f)))
(else (loop body defs #t))))))
+ ;; Expand a run of defines or define-syntaxes into letrec. As
+ ;; soon as we encounter something else, finish up.
(define (expand body)
;; Each #t in "mvars" indicates an MV-capable "var". Non-MV
;; vars (#f in mvars) are 1-element lambda-lists for simplicity.
@@ -598,14 +629,7 @@
(loop rest (cons (cadr x) vars) (cons (caddr x) vals) (cons #t mvars)))
((comp '##core#begin head)
(loop (##sys#append (cdr x) rest) vars vals mvars))
- (else
- (if (member (list head) vars)
- (fini vars vals mvars body)
- (let ((x2 (##sys#expand-0 x se cs?)))
- (if (eq? x x2)
- (fini vars vals mvars body)
- (loop (cons x2 rest)
- vars vals mvars)))))))))))
+ (else (fini vars vals mvars body))))))))
(expand body) ) )
@@ -959,23 +983,24 @@
##sys#current-environment ##sys#macro-environment
#f #t 'reexport)))
-(##sys#extend-macro-environment
- 'import '()
- (##sys#er-transformer
- (lambda (x r c)
- `(##core#begin
- ,@(map (lambda (x)
- (let-values (((name lib spec v s i) (##sys#decompose-import x r c 'import)))
- (if (not spec)
- (##sys#syntax-error-hook
- 'import "cannot import from undefined module" name)
- (##sys#import
- spec v s i
- ##sys#current-environment ##sys#macro-environment #f #f 'import))
- (if (not lib)
- '(##core#undefined)
- `(##core#require ,lib ,(module-requirement name)))))
- (cdr x))))))
+(set! chicken.expand#import-definition
+ (##sys#extend-macro-environment
+ 'import '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ `(##core#begin
+ ,@(map (lambda (x)
+ (let-values (((name lib spec v s i) (##sys#decompose-import x r c 'import)))
+ (if (not spec)
+ (##sys#syntax-error-hook
+ 'import "cannot import from undefined module" name)
+ (##sys#import
+ spec v s i
+ ##sys#current-environment ##sys#macro-environment #f #f 'import))
+ (if (not lib)
+ '(##core#undefined)
+ `(##core#require ,lib ,(module-requirement name)))))
+ (cdr x)))))))
(##sys#extend-macro-environment
'begin-for-syntax '()
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index 1da12c34..6cbb7511 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -794,6 +794,10 @@
(define-record-type foo (make-foo bar) foo? (bar foo-bar))
(foo-bar (make-foo 1)))))
+;; Nested begins inside definitions were not treated correctly
+(t 3 (eval '(let () (begin 1 (begin 2 (define internal-def 3) internal-def)))))
+(f (eval '(let () internal-def)))
+
;;; renaming of keyword argument (#277)
(define-syntax foo1
Trap