~ chicken-core (chicken-5) 0ca0af94d12c08a041258e5fba32c20569b1cbac
commit 0ca0af94d12c08a041258e5fba32c20569b1cbac
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Aug 28 13:37:16 2019 +0200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun Sep 15 19:22:49 2019 +0200
Catch self-referencing variables in `letrec' form
"(letrec ((x x)) ...)" results in and endless recursion in the optimizer, since a letrec-bound
variable ends up being replacable by itself. The intermediate form generated by expanding letrec
in the compiler binds "x" first to (##core#undefined) which the compiler uses to assume
the variable has no value, leading to (in this context) somewhat questionable conclusion.
Since this is a rather tricky part of the analysis framework of the compiler, and due to the fact
that catching the situation earlier (during canonicalization) gives a more useful error message,
"letrec" expands now into a use of the internal form "##core#with-forbidden-refs", which marks
references to variables temporarily as invalid, until the code walk encounters
a lambda form.
"letrec" expands into a complex "let" form and is then walked again, during which the information
about the original letrec is lost, so we need an intermediate form that also takes care of
variable renaming. "##core#with-forbidden-refs" is dropped as soon as it is walked.
A test from syntax-tests.scm that actually used such a self-reference has been dropped.
No changes have been made to the interpreter. I think it's ok for the compiler to be more
picky and give better error detection.
Signed-off-by: felix <felix@call-with-current-continuation.org>
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/core.scm b/core.scm
index 5c49a683..9bb08b42 100644
--- a/core.scm
+++ b/core.scm
@@ -149,6 +149,7 @@
; (##core#the <type> <strict?> <exp>)
; (##core#typecase <info> <exp> (<type> <body>) ... [(else <body>)])
; (##core#debug-event {<event> <loc>})
+; (##core#with-forbidden-refs (<var> ...) <loc> <expr>)
; (<exp> {<exp>})
; - Core language:
@@ -512,7 +513,8 @@
;;; Expand macros and canonicalize expressions:
(define (canonicalize-expression exp)
- (let ((compiler-syntax '()))
+ (let ((compiler-syntax '())
+ (forbidden-refs '()))
(define (find-id id se) ; ignores macro bindings
(cond ((null? se) #f)
@@ -559,11 +561,9 @@
x) )
(define (resolve-variable x0 e dest ldest h)
-
(when (memq x0 unlikely-variables)
(warning
(sprintf "reference to variable `~s' possibly unintended" x0) ))
-
(let ((x (lookup x0)))
(d `(RESOLVE-VARIABLE: ,x0 ,x ,(map (lambda (x) (car x)) (##sys#current-environment))))
(cond ((not (symbol? x)) x0) ; syntax?
@@ -592,6 +592,13 @@
t)
e dest ldest h #f #f))))
((not (memq x e)) (##sys#alias-global-hook x #f h)) ; only if global
+ ((assq x forbidden-refs) =>
+ (lambda (a)
+ (let ((ln (cdr a)))
+ (quit-compiling
+ "~acyclical reference in LETREC binding for variable `~a'"
+ (if ln (sprintf "(~a) - " ln) "")
+ (get-real-name x)))))
(else x))))
(define (emit-import-lib name il)
@@ -766,12 +773,26 @@
(list (car b) '(##core#undefined)))
bindings)
(##core#let
- ,(map (lambda (t b) (list t (cadr b))) tmps bindings)
+ ,(map (lambda (t b)
+ (list t `(##core#with-forbidden-refs
+ ,vars ,ln ,(cadr b))))
+ tmps bindings)
,@(map (lambda (v t)
`(##core#set! ,v ,t))
vars tmps)
(##core#let () ,@body) ) )
e dest ldest h ln #f)))
+
+ ((##core#with-forbidden-refs)
+ (let* ((loc (caddr x))
+ (vars (map (lambda (v)
+ (cons (resolve-variable v e dest
+ ldest h)
+ loc))
+ (cadr x))))
+ (fluid-let ((forbidden-refs
+ (append vars forbidden-refs)))
+ (walk (cadddr x) e dest ldest h ln #f))))
((##core#lambda)
(let ((llist (cadr x))
@@ -790,13 +811,15 @@
(body (parameterize ((##sys#current-environment se2))
(let ((body0 (canonicalize-body/ln
ln obody compiler-syntax-enabled)))
- (walk
- (if emit-debug-info
- `(##core#begin
- (##core#debug-event C_DEBUG_ENTRY (##core#quote ,dest))
- ,body0)
- body0)
- (append aliases e) #f #f dest ln #f))))
+ (fluid-let ((forbidden-refs '()))
+ (walk
+ (if emit-debug-info
+ `(##core#begin
+ (##core#debug-event C_DEBUG_ENTRY (##core#quote ,dest))
+ ,body0)
+ body0)
+ (append aliases e)
+ #f #f dest ln #f)))))
(llist2
(build-lambda-list
aliases argc
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index 3637fde9..1c98d94c 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -1283,10 +1283,6 @@ other-eval
(bar foo))
bar))
-(t (void) (letrec ((foo (gc))
- (bar foo))
- bar))
-
;; Obscure letrec issue #1068
(t 1 (letrec ((foo (lambda () 1))
(bar (let ((tmp (lambda (x) (if x (foo) (bar #t)))))
Trap