On Sat, Feb 25, 2017 at 06:13:48PM +0100, Peter Bex wrote: > However, I figured out that the real cause of #1309 is much, much deeper > and has to do with a nasty bug in ##sys#canonicalize-body: it invokes > "fini" as soon as it sees a non-pair. However, fini doesn't handle > expansions the same way as the body. For example: > > (let () 1 (begin (define blabla 3)) blabla) > > This will define blabla globally (or trigger an error in CHICKEN 5 with > the patch), because the "1" stops the begin from being expanded properly. > I fear that this requires a pretty invasive rewrite of > ##sys#canonicalize-body. I'll get back to y'all on that.
Attached is an updated and hopefully final patch set to tackle this bug.
The fix for the nested "begin" mentioned above is pretty simple: The list
of special cases in "fini" needs to be extended with ##core#begin; if that
is encountered, we need to call "expand" again, which will flatten all the
begins.
But the trickier bit here is that the forms are all macro-expanded by
##sys#canonicalize-body. This results in three problems:
1) A form that expands to something that eventually expands to "define"
was expanded just once and then processed by the compiler as a
regular form, resulting in a toplevel define, which is incorrect.
2) After fixing the above by expanding macros completely in
##sys#canonicalize-body, line numbers are lost in the compiler because
##sys#canonicalize-body does not have access to the line number
database maintained by the compiler.
3) "import" and "module" need special consideration with macro expansion.
Here, number 1) was fixed by simplifying macro expansion a bit: the
"expand" procedure no longer tries to do macro-expansion or detection
of calls to any locally defined procedures or macros. Instead, "fini"
now does this. It will expand until it finds a define, "begin", "import"
or "module", and then either hand back control to the compiler or
re-invoke "expand" on the remaining body to grab all the defines it
can find.
Number 2) was easily fixed by adding yet another hook. It's ugly, but
I've discussed this on IRC with Felix and he sess no other way to do
it either. The advantage is that this actually _improves_ precision
of line numbers, as you can see in the final patch's hunk that changes
the scrutiny-2.expected; it now correctly knows that the (pair?) call
is on line 20 instead of on line 14 (which is the start of the LET).
Number 3) deserves some more attention. It turns out that a (module)
form which instantiates a functor will expand to two (module ...)
forms, one for an "internal" module and one for another module that
imports this internal one. However, the macro will look up the
other module at expansion time, in a table that's only populated once
the ##core#module form is processed by the compiler or interpreter core.
Thus, if you expand both module forms one by one, this will fail.
The other issue is with "import". In functor-tests, there is a test
that creates three different functors, which are then used in an
inner define:
(define output
(with-output-to-string
(lambda ()
(import (2x print))
(print-twice #\a)
(import (2x noop))
(print-twice #\a)
(import (2x write))
(print-twice #\a))))
This is supposed to import (2x print) and use print-twice from that
module. Then it will import module (2x noop) and use print-twice from
there, then import module (2x write) and use its print-twice. This
_requires_ that expansion of import is delayed.
Normally, one would see an import as a "global action", affecting all
subsequent uses of the identifiers from the imported module. This is
exactly what happens if you expand the import, then process the rest
of the body. So what needs to happen is to process all the forms,
except for any imports. Then, the compiler can process the import,
process the following form, process the import, process the form, etc
to get the interleaving that was intended.
This works in the above code in CHICKEN 4, but only "by accident".
A simple change can already break this behaviour:
(define output
(with-output-to-string
(lambda ()
(import (2x print))
(print-twice #\a)
(import (2x noop))
(print-twice #\a)
(define whatever 1) ;; This interferes with the final print
(import (2x write))
(print-twice #\a))))
This causes the imports to be expanded incorrectly. All this is
now handled correctly with the attached patches, including the
r7rs test case from the original bugreport; the r7rs version of
define-record-type is now correctly seen as an internal define.
And truly incorrectly placed defines are now rejected with a syntax
error, of course :)
Cheers,
Peter
From 7e51fc89adc74a775cc6b42892f84b51c70a247b Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Sat, 11 Feb 2017 15:30:13 +0100
Subject: [PATCH 1/5] Reject toplevel definitions in non-toplevel contexts.
This introduces a distinction between define and set!, which allows
the compiler (and the closure-compiler in the interpreter) to error
out when a definition somehow ends up out of place.
Fixes #1309
---
NEWS | 2 +
core.scm | 166 +++++++++++++++++++++++++++---------------------
eval.scm | 155 ++++++++++++++++++++++----------------------
expand.scm | 2 +-
tests/functor-tests.scm | 2 +
tests/syntax-tests.scm | 7 ++
6 files changed, 187 insertions(+), 147 deletions(-)
diff --git a/NEWS b/NEWS
index 4c97bcf..aee94c5 100644
--- a/NEWS
+++ b/NEWS
@@ -57,6 +57,8 @@
- Syntax expander
- Removed support for (define-syntax (foo e r c) ...), which was
undocumented and not officially supported anyway.
+ - define and friends are now aggressively rejected in "expression
+ contexts" (i.e., anywhere but toplevel or as internal defines).
4.12.1
diff --git a/core.scm b/core.scm
index 718e7e8..b24e5ca 100644
--- a/core.scm
+++ b/core.scm
@@ -110,6 +110,7 @@
; (##core#lambda <variable> <body>)
; (##core#lambda ({<variable>}+ [. <variable>]) <body>)
; (##core#set! <variable> <exp>)
+; (##core#define-toplevel <variable> <exp>)
; (##core#begin <exp> ...)
; (##core#include <string> <string> | #f)
; (##core#loop-lambda <llist> <body>)
@@ -529,9 +530,9 @@
(d `(RESOLVE-VARIABLE: ,x0 ,x ,(map (lambda (x) (car x)) se)))
(cond ((not (symbol? x)) x0) ; syntax?
((##sys#hash-table-ref constant-table x)
- => (lambda (val) (walk val e se dest ldest h #f)))
+ => (lambda (val) (walk val e se dest ldest h #f #f)))
((##sys#hash-table-ref inline-table x)
- => (lambda (val) (walk val e se dest ldest h #f)))
+ => (lambda (val) (walk val e se dest ldest h #f #f)))
((assq x foreign-variables)
=> (lambda (fv)
(let* ((t (second fv))
@@ -541,7 +542,7 @@
(foreign-type-convert-result
(finish-foreign-result ft body)
t)
- e se dest ldest h #f))))
+ e se dest ldest h #f #f))))
((assq x location-pointer-map)
=> (lambda (a)
(let* ((t (third a))
@@ -551,7 +552,7 @@
(foreign-type-convert-result
(finish-foreign-result ft body)
t)
- e se dest ldest h #f))))
+ e se dest ldest h #f #f))))
((##sys#get x '##core#primitive))
((not (memq x e)) (##sys#alias-global-hook x #f h)) ; only if global
(else x))))
@@ -579,7 +580,7 @@
(for-each pretty-print imps)
(print "\n;; END OF FILE"))))) ) )
- (define (walk x e se dest ldest h outer-ln)
+ (define (walk x e se dest ldest h outer-ln tl?)
(cond ((symbol? x)
(cond ((keyword? x) `(quote ,x))
((memq x unlikely-variables)
@@ -603,22 +604,22 @@
(xexpanded (expand x se compiler-syntax-enabled)))
(when ln (update-line-number-database! xexpanded ln))
(cond ((not (eq? x xexpanded))
- (walk xexpanded e se dest ldest h ln))
+ (walk xexpanded e se dest ldest h ln tl?))
((##sys#hash-table-ref inline-table name)
=> (lambda (val)
- (walk (cons val (cdr x)) e se dest ldest h ln)))
+ (walk (cons val (cdr x)) e se dest ldest h ln #f)))
(else
(case name
((##core#if)
`(if
- ,(walk (cadr x) e se #f #f h ln)
- ,(walk (caddr x) e se #f #f h ln)
+ ,(walk (cadr x) e se #f #f h ln #f)
+ ,(walk (caddr x) e se #f #f h ln #f)
,(if (null? (cdddr x))
'(##core#undefined)
- (walk (cadddr x) e se #f #f h ln) ) ) )
+ (walk (cadddr x) e se #f #f h ln #f) ) ) )
((##core#syntax ##core#quote)
`(quote ,(strip-syntax (cadr x))))
@@ -626,21 +627,21 @@
((##core#check)
(if unsafe
''#t
- (walk (cadr x) e se dest ldest h ln) ) )
+ (walk (cadr x) e se dest ldest h ln tl?) ) )
((##core#the)
`(##core#the
,(strip-syntax (cadr x))
,(caddr x)
- ,(walk (cadddr x) e se dest ldest h ln)))
+ ,(walk (cadddr x) e se dest ldest h ln tl?)))
((##core#typecase)
`(##core#typecase
,(or ln (cadr x))
- ,(walk (caddr x) e se #f #f h ln)
+ ,(walk (caddr x) e se #f #f h ln tl?)
,@(map (lambda (cl)
(list (strip-syntax (car cl))
- (walk (cadr cl) e se dest ldest h ln)))
+ (walk (cadr cl) e se dest ldest h ln tl?)))
(cdddr x))))
((##core#immutable)
@@ -667,7 +668,7 @@
((##core#inline_loc_ref)
`(##core#inline_loc_ref
,(strip-syntax (cadr x))
- ,(walk (caddr x) e se dest ldest h ln)))
+ ,(walk (caddr x) e se dest ldest h ln #f)))
((##core#require-for-syntax)
(load-extension (cadr x))
@@ -683,7 +684,7 @@
file-requirements type
(cut lset-adjoin/eq? <> id)
(cut list id)))
- (walk exp e se dest ldest h ln))))
+ (walk exp e se dest ldest h ln #f))))
((##core#let)
(let* ((bindings (cadr x))
@@ -693,12 +694,12 @@
(set-real-names! aliases vars)
`(let
,(map (lambda (alias b)
- (list alias (walk (cadr b) e se (car b) #t h ln)) )
+ (list alias (walk (cadr b) e se (car b) #t h ln #f)) )
aliases bindings)
,(walk (##sys#canonicalize-body
(cddr x) se2 compiler-syntax-enabled)
(append aliases e)
- se2 dest ldest h ln) ) ) )
+ se2 dest ldest h ln #f) ) ) )
((##core#letrec*)
(let ((bindings (cadr x))
@@ -712,7 +713,7 @@
`(##core#set! ,(car b) ,(cadr b)))
bindings)
(##core#let () ,@body) )
- e se dest ldest h ln)))
+ e se dest ldest h ln #f)))
((##core#letrec)
(let* ((bindings (cadr x))
@@ -730,7 +731,7 @@
`(##core#set! ,v ,t))
vars tmps)
(##core#let () ,@body) ) )
- e se dest ldest h ln)))
+ e se dest ldest h ln #f)))
((##core#lambda)
(let ((llist (cadr x))
@@ -753,7 +754,7 @@
(##core#debug-event "C_DEBUG_ENTRY" ',dest)
,body0)
body0)
- (append aliases e) se2 #f #f dest ln))
+ (append aliases e) se2 #f #f dest ln #f))
(llist2
(build-lambda-list
aliases argc
@@ -790,7 +791,7 @@
(walk
(##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
e se2
- dest ldest h ln) ) )
+ dest ldest h ln #f) ) )
((##core#letrec-syntax)
(let* ((ms (map (lambda (b)
@@ -808,7 +809,7 @@
ms)
(walk
(##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
- e se2 dest ldest h ln)))
+ e se2 dest ldest h ln #f)))
((##core#define-syntax)
(##sys#check-syntax
@@ -833,7 +834,7 @@
',var
(##sys#current-environment) ,body) ;XXX possibly wrong se?
'(##core#undefined) )
- e se dest ldest h ln)) )
+ e se dest ldest h ln #f)) )
((##core#define-compiler-syntax)
(let* ((var (cadr x))
@@ -865,7 +866,7 @@
',var)
(##sys#current-environment))))
'(##core#undefined) )
- e se dest ldest h ln)))
+ e se dest ldest h ln #f)))
((##core#let-compiler-syntax)
(let ((bs (map
@@ -892,7 +893,7 @@
(walk
(##sys#canonicalize-body
(cddr x) se compiler-syntax-enabled)
- e se dest ldest h ln) )
+ e se dest ldest h ln tl?) )
(lambda ()
(for-each
(lambda (b)
@@ -907,7 +908,7 @@
(cadr x)
(caddr x)
(lambda (forms)
- (walk `(##core#begin ,@forms) e se dest ldest h ln)))))
+ (walk `(##core#begin ,@forms) e se dest ldest h ln tl?)))))
((##core#let-module-alias)
(##sys#with-module-aliases
@@ -916,7 +917,7 @@
(strip-syntax b))
(cadr x))
(lambda ()
- (walk `(##core#begin ,@(cddr x)) e se dest ldest h ln))))
+ (walk `(##core#begin ,@(cddr x)) e se dest ldest h ln #t))))
((##core#module)
(let* ((name (strip-syntax (cadr x)))
@@ -986,7 +987,7 @@
(car body)
e ;?
(##sys#current-environment)
- #f #f h ln)
+ #f #f h ln #t) ; reset to toplevel!
xs))))))))))
(let ((body
(canonicalize-begin-body
@@ -999,7 +1000,7 @@
(walk
x
e ;?
- (##sys#current-meta-environment) #f #f h ln) )
+ (##sys#current-meta-environment) #f #f h ln tl?) )
(cons `(##core#provide ,req) module-registration)))
body))))
(do ((cs compiler-syntax (cdr cs)))
@@ -1017,15 +1018,20 @@
(walk
(##sys#canonicalize-body obody se2 compiler-syntax-enabled)
(append aliases e)
- se2 #f #f dest ln) ] )
+ se2 #f #f dest ln #f) ] )
(set-real-names! aliases vars)
`(##core#lambda ,aliases ,body) ) )
- ((##core#set!)
+ ((##core#set! ##core#define-toplevel)
(let* ([var0 (cadr x)]
[var (lookup var0 se)]
[ln (get-line x)]
[val (caddr x)] )
+ (when (and (eq? name '##core#define-toplevel) (not tl?))
+ (quit-compiling
+ "~atoplevel definition of `~s' in non-toplevel context"
+ (if ln (sprintf "(~a) - " ln) "")
+ var))
(when (memq var unlikely-variables)
(warning
(sprintf "assignment to variable `~s' possibly unintended"
@@ -1039,7 +1045,7 @@
(##core#inline_update
(,(third fv) ,type)
,(foreign-type-check tmp type) ) )
- e se #f #f h ln))))
+ e se #f #f h ln #f))))
((assq var location-pointer-map)
=> (lambda (a)
(let* ([type (third a)]
@@ -1050,7 +1056,7 @@
(,type)
,(second a)
,(foreign-type-check tmp type) ) )
- e se #f #f h ln))))
+ e se #f #f h ln #f))))
(else
(unless (memq var e) ; global?
(set! var (or (##sys#get var '##core#primitive)
@@ -1074,38 +1080,38 @@
(##sys#notice "assignment to imported value binding" var)))
(when (keyword? var)
(warning (sprintf "assignment to keyword `~S'" var) ))
- `(set! ,var ,(walk val e se var0 (memq var e) h ln))))))
+ `(set! ,var ,(walk val e se var0 (memq var e) h ln #f))))))
((##core#debug-event)
`(##core#debug-event
,(unquotify (cadr x) se)
,ln ; this arg is added - from this phase on ##core#debug-event has an additional argument!
,@(map (lambda (arg)
- (unquotify (walk arg e se #f #f h ln) se))
+ (unquotify (walk arg e se #f #f h ln tl?) se))
(cddr x))))
((##core#inline)
`(##core#inline
- ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) e se h ln)))
+ ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) e se h ln #f)))
((##core#inline_allocate)
`(##core#inline_allocate
,(map (cut unquotify <> se) (second x))
- ,@(mapwalk (cddr x) e se h ln)))
+ ,@(mapwalk (cddr x) e se h ln #f)))
((##core#inline_update)
- `(##core#inline_update ,(cadr x) ,(walk (caddr x) e se #f #f h ln)) )
+ `(##core#inline_update ,(cadr x) ,(walk (caddr x) e se #f #f h ln #f)) )
((##core#inline_loc_update)
`(##core#inline_loc_update
,(cadr x)
- ,(walk (caddr x) e se #f #f h ln)
- ,(walk (cadddr x) e se #f #f h ln)) )
+ ,(walk (caddr x) e se #f #f h ln #f)
+ ,(walk (cadddr x) e se #f #f h ln #f)) )
((##core#compiletimetoo ##core#elaborationtimetoo)
(let ((exp (cadr x)))
(##sys#eval/meta exp)
- (walk exp e se dest #f h ln) ) )
+ (walk exp e se dest #f h ln tl?) ) )
((##core#compiletimeonly ##core#elaborationtimeonly)
(##sys#eval/meta (cadr x))
@@ -1118,24 +1124,24 @@
(let ([x (car xs)]
[r (cdr xs)] )
(if (null? r)
- (list (walk x e se dest ldest h ln))
- (cons (walk x e se #f #f h ln) (fold r)) ) ) ) )
+ (list (walk x e se dest ldest h ln tl?))
+ (cons (walk x e se #f #f h ln tl?) (fold r)) ) ) ) )
'(##core#undefined) ) )
((##core#foreign-lambda)
- (walk (expand-foreign-lambda x #f) e se dest ldest h ln) )
+ (walk (expand-foreign-lambda x #f) e se dest ldest h ln #f) )
((##core#foreign-safe-lambda)
- (walk (expand-foreign-lambda x #t) e se dest ldest h ln) )
+ (walk (expand-foreign-lambda x #t) e se dest ldest h ln #f) )
((##core#foreign-lambda*)
- (walk (expand-foreign-lambda* x #f) e se dest ldest h ln) )
+ (walk (expand-foreign-lambda* x #f) e se dest ldest h ln #f) )
((##core#foreign-safe-lambda*)
- (walk (expand-foreign-lambda* x #t) e se dest ldest h ln) )
+ (walk (expand-foreign-lambda* x #t) e se dest ldest h ln #f) )
((##core#foreign-primitive)
- (walk (expand-foreign-primitive x) e se dest ldest h ln) )
+ (walk (expand-foreign-primitive x) e se dest ldest h ln #f) )
((##core#define-foreign-variable)
(let* ((var (strip-syntax (second x)))
@@ -1169,17 +1175,23 @@
(define
,ret
,(if (pair? (cdr conv)) (second conv) '##sys#values)) )
- e se dest ldest h ln) ) ]
+ e se dest ldest h ln #f) ) ]
[else
(register-foreign-type! name type)
'(##core#undefined) ] ) ) )
((##core#define-external-variable)
- (let* ([sym (second x)]
- [name (symbol->string sym)]
- [type (third x)]
- [exported (fourth x)]
- [rname (make-random-name)] )
+ (let* ((sym (second x))
+ (ln (ln (get-line x)))
+ (name (symbol->string sym))
+ (type (third x))
+ (exported (fourth x))
+ (rname (make-random-name)) )
+ (unless tl?
+ (quit-compiling
+ "~aexternal variable definition of `~s' in non-toplevel context"
+ (if ln (sprintf "(~a) - " ln) "")
+ sym))
(unless exported (set! name (symbol->string (fifth x))))
(set! external-variables (cons (vector name type exported) external-variables))
(set! foreign-variables
@@ -1212,16 +1224,23 @@
'() )
,(if init (fifth x) (fourth x)) ) )
e (alist-cons var alias se)
- dest ldest h ln) ) )
+ dest ldest h ln #f) ) )
((##core#define-inline)
(let* ((name (second x))
- (val `(##core#lambda ,@(cdaddr x))))
+ (val `(##core#lambda ,@(cdaddr x)))
+ (ln (get-line x)))
+ (unless tl?
+ (quit-compiling
+ "~ainline definition of `~s' in non-toplevel context"
+ (if ln (sprintf "(~a) - " ln) "")
+ name))
(##sys#hash-table-set! inline-table name val)
'(##core#undefined)))
((##core#define-constant)
(let* ((name (second x))
+ (ln (get-line x))
(valexp (third x))
(val (handle-exceptions ex
;; could show line number here
@@ -1233,6 +1252,11 @@
(eval
`(##core#let
,defconstant-bindings ,valexp))))))
+ (unless tl?
+ (quit-compiling
+ "~aconstant definition of `~s' in non-toplevel context"
+ (if ln (sprintf "(~a) - " ln) "")
+ name))
(set! defconstant-bindings
(cons (list name `(##core#quote ,val)) defconstant-bindings))
(cond ((collapsable-literal? val)
@@ -1244,7 +1268,7 @@
(hide-variable var)
(mark-variable var '##compiler#constant)
(mark-variable var '##compiler#always-bound)
- (walk `(define ,var (##core#quote ,val)) e se #f #f h ln)))
+ (walk `(define ,var (##core#quote ,val)) e se #f #f h ln tl?)))
(else
(quit-compiling "invalid compile-time value for named constant `~S'"
name)))))
@@ -1258,7 +1282,7 @@
(lambda (id)
(memq (lookup id se) e))))
(cdr x) ) )
- e '() #f #f h ln) )
+ e '() #f #f h ln #f) )
((##core#foreign-callback-wrapper)
(let-values ([(args lam) (split-at (cdr x) 4)])
@@ -1280,7 +1304,7 @@
"non-matching or invalid argument list to foreign callback-wrapper"
vars atypes) )
`(##core#foreign-callback-wrapper
- ,@(mapwalk args e se h ln)
+ ,@(mapwalk args e se h ln #f)
,(walk `(##core#lambda
,vars
(##core#let
@@ -1337,7 +1361,7 @@
(##sys#make-c-string r ',name)) ) ) )
(else (cddr lam)) ) )
rtype) ) )
- e se #f #f h ln) ) ) ) )
+ e se #f #f h ln #f) ) ) ) )
((##core#location)
(let ([sym (cadr x)])
@@ -1346,23 +1370,23 @@
=> (lambda (a)
(walk
`(##sys#make-locative ,(second a) 0 #f 'location)
- e se #f #f h ln) ) ]
+ e se #f #f h ln #f) ) ]
[(assq sym external-to-pointer)
- => (lambda (a) (walk (cdr a) e se #f #f h ln)) ]
+ => (lambda (a) (walk (cdr a) e se #f #f h ln #f)) ]
[(assq sym callback-names)
`(##core#inline_ref (,(symbol->string sym) c-pointer)) ]
[else
(walk
`(##sys#make-locative ,sym 0 #f 'location)
- e se #f #f h ln) ] )
+ e se #f #f h ln #f) ] )
(walk
`(##sys#make-locative ,sym 0 #f 'location)
- e se #f #f h ln) ) ) )
+ e se #f #f h ln #f) ) ) )
(else
(let* ((x2 (fluid-let ((##sys#syntax-context
(cons name ##sys#syntax-context)))
- (mapwalk x e se h ln)))
+ (mapwalk x e se h ln tl?)))
(head2 (car x2))
(old (##sys#hash-table-ref line-number-database-2 head2)) )
(when ln
@@ -1378,7 +1402,7 @@
((constant? (car x))
(emit-syntax-trace-info x #f)
(warning "literal in operator position" x)
- (mapwalk x e se h outer-ln) )
+ (mapwalk x e se h outer-ln tl?) )
(else
(emit-syntax-trace-info x #f)
@@ -1387,10 +1411,10 @@
`(##core#let
((,tmp ,(car x)))
(,tmp ,@(cdr x)))
- e se dest ldest h outer-ln)))))
+ e se dest ldest h outer-ln #f)))))
- (define (mapwalk xs e se h ln)
- (map (lambda (x) (walk x e se #f #f h ln)) xs) )
+ (define (mapwalk xs e se h ln tl?)
+ (map (lambda (x) (walk x e se #f #f h ln tl?)) xs) )
(when (memq 'c debugging-chicken) (newline) (pretty-print exp))
(foreign-code "C_clear_trace_buffer();")
@@ -1403,7 +1427,7 @@
,(begin
(set! extended-bindings (append internal-bindings extended-bindings))
exp) )
- '() (##sys#current-environment) #f #f #f #f) ) )
+ '() (##sys#current-environment) #f #f #f #f #t) ) )
(define (process-declaration spec se local?)
diff --git a/eval.scm b/eval.scm
index f1f6471..72977a8 100644
--- a/eval.scm
+++ b/eval.scm
@@ -207,7 +207,7 @@
(define compile-to-closure
(let ((reverse reverse))
- (lambda (exp env se #!optional cntr evalenv static)
+ (lambda (exp env se #!optional cntr evalenv static tl?)
(define (find-id id se) ; ignores macro bindings
(cond ((null? se) #f)
@@ -252,7 +252,7 @@
(define (decorate p ll h cntr)
(eval-decorator p ll h cntr))
- (define (compile x e h tf cntr se)
+ (define (compile x e h tf cntr se tl?)
(cond ((keyword? x) (lambda v x))
((symbol? x)
(receive (i j) (lookup x e se)
@@ -318,7 +318,7 @@
(let ((x2 (expand x se)))
(d `(EVAL/EXPANDED: ,x2))
(if (not (eq? x2 x))
- (compile x2 e h tf cntr se)
+ (compile x2 e h tf cntr se tl?)
(let ((head (rename (##sys#slot x 0) se)))
;; here we did't resolve ##core#primitive, but that is done in compile-call (via
;; a normal walking of the operator)
@@ -341,40 +341,42 @@
(lambda v c)))
[(##core#check)
- (compile (cadr x) e h tf cntr se) ]
+ (compile (cadr x) e h tf cntr se #f) ]
[(##core#immutable)
- (compile (cadr x) e #f tf cntr se) ]
+ (compile (cadr x) e #f tf cntr se #f) ]
[(##core#undefined) (lambda (v) (##core#undefined))]
[(##core#if)
- (let* ([test (compile (cadr x) e #f tf cntr se)]
- [cns (compile (caddr x) e #f tf cntr se)]
- [alt (if (pair? (cdddr x))
- (compile (cadddr x) e #f tf cntr se)
- (compile '(##core#undefined) e #f tf cntr se) ) ] )
+ (let* ((test (compile (cadr x) e #f tf cntr se #f))
+ (cns (compile (caddr x) e #f tf cntr se #f))
+ (alt (if (pair? (cdddr x))
+ (compile (cadddr x) e #f tf cntr se #f)
+ (compile '(##core#undefined) e #f tf cntr se #f) ) ) )
(lambda (v) (if (##core#app test v) (##core#app cns v) (##core#app alt v))) ) ]
[(##core#begin)
(let* ((body (##sys#slot x 1))
(len (length body)) )
(case len
- [(0) (compile '(##core#undefined) e #f tf cntr se)]
- [(1) (compile (##sys#slot body 0) e #f tf cntr se)]
- [(2) (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se)]
- [x2 (compile (cadr body) e #f tf cntr se)] )
- (lambda (v) (##core#app x1 v) (##core#app x2 v)) ) ]
- [else
- (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se)]
- [x2 (compile (cadr body) e #f tf cntr se)]
- [x3 (compile `(##core#begin ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr se)] )
- (lambda (v) (##core#app x1 v) (##core#app x2 v) (##core#app x3 v)) ) ] ) ) ]
-
- [(##core#set!)
+ ((0) (compile '(##core#undefined) e #f tf cntr se tl?))
+ ((1) (compile (##sys#slot body 0) e #f tf cntr se tl?))
+ ((2) (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se tl?)]
+ [x2 (compile (cadr body) e #f tf cntr se tl?)] )
+ (lambda (v) (##core#app x1 v) (##core#app x2 v)) ) )
+ (else
+ (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se tl?)]
+ [x2 (compile (cadr body) e #f tf cntr se tl?)]
+ [x3 (compile `(##core#begin ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr se tl?)] )
+ (lambda (v) (##core#app x1 v) (##core#app x2 v) (##core#app x3 v)) ) ) ) ) ]
+
+ [(##core#set! ##core#define-toplevel)
(let ((var (cadr x)))
+ (when (and (eq? head '##core#define-toplevel) (not tl?))
+ (##sys#error "toplevel definition in non-toplevel context for variable" var))
(receive (i j) (lookup var e se)
- (let ((val (compile (caddr x) e var tf cntr se)))
+ (let ((val (compile (caddr x) e var tf cntr se #f)))
(cond [(not i)
(when ##sys#notices-enabled
(and-let* ((a (assq var (##sys#current-environment)))
@@ -406,28 +408,28 @@
(se2 (##sys#extend-se se vars aliases))
[body (compile-to-closure
(##sys#canonicalize-body (cddr x) se2 #f)
- e2 se2 cntr evalenv static) ] )
+ e2 se2 cntr evalenv static #f) ] )
(case n
- [(1) (let ([val (compile (cadar bindings) e (car vars) tf cntr se)])
+ [(1) (let ([val (compile (cadar bindings) e (car vars) tf cntr se #f)])
(lambda (v)
(##core#app body (cons (vector (##core#app val v)) v)) ) ) ]
- [(2) (let ([val1 (compile (cadar bindings) e (car vars) tf cntr se)]
- [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se)] )
+ [(2) (let ([val1 (compile (cadar bindings) e (car vars) tf cntr se #f)]
+ [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se #f)] )
(lambda (v)
(##core#app body (cons (vector (##core#app val1 v) (##core#app val2 v)) v)) ) ) ]
- [(3) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se)]
- [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se)]
+ [(3) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se #f)]
+ [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se #f)]
[t (cddr bindings)]
- [val3 (compile (cadar t) e (caddr vars) tf cntr se)] )
+ [val3 (compile (cadar t) e (caddr vars) tf cntr se #f)] )
(lambda (v)
(##core#app
body
(cons (vector (##core#app val1 v) (##core#app val2 v) (##core#app val3 v)) v)) ) ) ]
- [(4) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se)]
- [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se)]
+ [(4) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se #f)]
+ [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se #f)]
[t (cddr bindings)]
- [val3 (compile (cadar t) e (caddr vars) tf cntr se)]
- [val4 (compile (cadadr t) e (cadddr vars) tf cntr se)] )
+ [val3 (compile (cadar t) e (caddr vars) tf cntr se #f)]
+ [val4 (compile (cadadr t) e (cadddr vars) tf cntr se #f)] )
(lambda (v)
(##core#app
body
@@ -437,7 +439,7 @@
(##core#app val4 v))
v)) ) ) ]
[else
- (let ([vals (map (lambda (x) (compile (cadr x) e (car x) tf cntr se)) bindings)])
+ (let ((vals (map (lambda (x) (compile (cadr x) e (car x) tf cntr se #f)) bindings)))
(lambda (v)
(let ([v2 (##sys#make-vector n)])
(do ([i 0 (fx+ i 1)]
@@ -458,7 +460,7 @@
`(##core#set! ,(car b) ,(cadr b)))
bindings)
(##core#let () ,@body) )
- e h tf cntr se)))
+ e h tf cntr se #f)))
((##core#letrec)
(let* ((bindings (cadr x))
@@ -475,7 +477,7 @@
`(##core#set! ,v ,t))
vars tmps)
(##core#let () ,@body) ) )
- e h tf cntr se)))
+ e h tf cntr se #f)))
[(##core#lambda)
(##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f se)
@@ -496,7 +498,7 @@
(body
(compile-to-closure
(##sys#canonicalize-body body se2 #f)
- e2 se2 (or h cntr) evalenv static) ) )
+ e2 se2 (or h cntr) evalenv static #f) ) )
(case argc
[(0) (if rest
(lambda (v)
@@ -583,7 +585,7 @@
se) ) )
(compile
(##sys#canonicalize-body (cddr x) se2 #f)
- e #f tf cntr se2)))
+ e #f tf cntr se2 #f)))
((##core#letrec-syntax)
(let* ((ms (map (lambda (b)
@@ -601,7 +603,7 @@
ms)
(compile
(##sys#canonicalize-body (cddr x) se2 #f)
- e #f tf cntr se2)))
+ e #f tf cntr se2 #f)))
((##core#define-syntax)
(let* ((var (cadr x))
@@ -616,22 +618,22 @@
name
(##sys#current-environment)
(##sys#eval/meta body))
- (compile '(##core#undefined) e #f tf cntr se) ) )
+ (compile '(##core#undefined) e #f tf cntr se #f) ) )
((##core#define-compiler-syntax)
- (compile '(##core#undefined) e #f tf cntr se))
+ (compile '(##core#undefined) e #f tf cntr se #f))
((##core#let-compiler-syntax)
(compile
(##sys#canonicalize-body (cddr x) se #f)
- e #f tf cntr se))
+ e #f tf cntr se #f))
((##core#include)
(##sys#include-forms-from-file
(cadr x)
(caddr x)
(lambda (forms)
- (compile `(##core#begin ,@forms) e #f tf cntr se))))
+ (compile `(##core#begin ,@forms) e #f tf cntr se tl?))))
((##core#let-module-alias)
(##sys#with-module-aliases
@@ -640,7 +642,7 @@
(strip-syntax b))
(cadr x))
(lambda ()
- (compile `(##core#begin ,@(cddr x)) e #f tf cntr se))))
+ (compile `(##core#begin ,@(cddr x)) e #f tf cntr se tl?))))
((##core#module)
(let* ((x (strip-syntax x))
@@ -691,14 +693,15 @@
(cons (compile
(car body)
'() #f tf cntr
- (##sys#current-environment))
+ (##sys#current-environment)
+ #t) ; reset back to toplevel!
xs))))) ) )))
[(##core#loop-lambda)
- (compile `(,(rename 'lambda se) ,@(cdr x)) e #f tf cntr se) ]
+ (compile `(,(rename 'lambda se) ,@(cdr x)) e #f tf cntr se #f) ]
[(##core#provide)
- (compile `(##sys#provide (##core#quote ,(cadr x))) e #f tf cntr se)]
+ (compile `(##sys#provide (##core#quote ,(cadr x))) e #f tf cntr se #f)]
[(##core#require-for-syntax)
(let ((id (cadr x)))
@@ -708,30 +711,30 @@
,@(map (lambda (x)
`(##sys#load-extension (##core#quote ,x)))
(lookup-runtime-requirements id)))
- e #f tf cntr se))]
+ e #f tf cntr se #f))]
[(##core#require)
(let ((id (cadr x))
(alternates (cddr x)))
(let-values (((exp _ _) (##sys#process-require id #f alternates)))
- (compile exp e #f tf cntr se)))]
+ (compile exp e #f tf cntr se #f)))]
[(##core#elaborationtimeonly ##core#elaborationtimetoo) ; <- Note this!
(##sys#eval/meta (cadr x))
- (compile '(##core#undefined) e #f tf cntr se) ]
+ (compile '(##core#undefined) e #f tf cntr se tl?) ]
[(##core#compiletimetoo)
- (compile (cadr x) e #f tf cntr se) ]
+ (compile (cadr x) e #f tf cntr se tl?) ]
[(##core#compiletimeonly ##core#callunit)
- (compile '(##core#undefined) e #f tf cntr se) ]
+ (compile '(##core#undefined) e #f tf cntr se tl?) ]
[(##core#declare)
(##sys#notice "declarations are ignored in interpreted code" x)
- (compile '(##core#undefined) e #f tf cntr se) ]
+ (compile '(##core#undefined) e #f tf cntr se #f) ]
[(##core#define-inline ##core#define-constant)
- (compile `(,(rename 'define se) ,@(cdr x)) e #f tf cntr se) ]
+ (compile `(,(rename 'define se) ,@(cdr x)) e #f tf cntr se #f) ]
[(##core#primitive ##core#inline ##core#inline_allocate ##core#foreign-lambda
##core#define-foreign-variable
@@ -744,13 +747,13 @@
(compile-call (cdr x) e tf cntr se) ]
((##core#the)
- (compile (cadddr x) e h tf cntr se))
+ (compile (cadddr x) e h tf cntr se tl?))
((##core#typecase)
;; drops exp and requires "else" clause
(cond ((assq 'else (strip-syntax (cdddr x))) =>
(lambda (cl)
- (compile (cadr cl) e h tf cntr se)))
+ (compile (cadr cl) e h tf cntr se tl?)))
(else
(##sys#syntax-error-hook
'compiler-typecase
@@ -789,7 +792,7 @@
(let* ((head (##sys#slot x 0))
(fn (if (procedure? head)
(lambda _ head)
- (compile (##sys#slot x 0) e #f tf cntr se)))
+ (compile (##sys#slot x 0) e #f tf cntr se #f)))
(args (##sys#slot x 1))
(argc (checked-length args))
(info x) )
@@ -798,34 +801,34 @@
[(0) (lambda (v)
(emit-trace-info tf info cntr e v)
((##core#app fn v)))]
- [(1) (let ([a1 (compile (##sys#slot args 0) e #f tf cntr se)])
+ [(1) (let ((a1 (compile (##sys#slot args 0) e #f tf cntr se #f)))
(lambda (v)
(emit-trace-info tf info cntr e v)
((##core#app fn v) (##core#app a1 v))) ) ]
- [(2) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
- [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)] )
+ [(2) (let* ((a1 (compile (##sys#slot args 0) e #f tf cntr se #f))
+ (a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se #f)) )
(lambda (v)
(emit-trace-info tf info cntr e v)
((##core#app fn v) (##core#app a1 v) (##core#app a2 v))) ) ]
- [(3) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
- [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)]
- [a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se)] )
+ [(3) (let* ((a1 (compile (##sys#slot args 0) e #f tf cntr se #f))
+ (a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se #f))
+ (a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se #f)) )
(lambda (v)
(emit-trace-info tf info cntr e v)
((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v))) ) ]
- [(4) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
- [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)]
- [a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se)]
- [a4 (compile (##core#inline "C_u_i_list_ref" args 3) e #f tf cntr se)] )
+ [(4) (let* ((a1 (compile (##sys#slot args 0) e #f tf cntr se #f))
+ (a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se #f))
+ (a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se #f))
+ (a4 (compile (##core#inline "C_u_i_list_ref" args 3) e #f tf cntr se #f)) )
(lambda (v)
(emit-trace-info tf info cntr e v)
((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v) (##core#app a4 v))) ) ]
- [else (let ([as (##sys#map (lambda (a) (compile a e #f tf cntr se)) args)])
+ [else (let ((as (##sys#map (lambda (a) (compile a e #f tf cntr se #f)) args)))
(lambda (v)
(emit-trace-info tf info cntr e v)
(apply (##core#app fn v) (##sys#map (lambda (a) (##core#app a v)) as))) ) ] ) ) )
- (compile exp env #f (fx> (##sys#eval-debug-level) 0) cntr se) ) ) )
+ (compile exp env #f (fx> (##sys#eval-debug-level) 0) cntr se tl?) ) ) )
;;; evaluate in the macro-expansion/compile-time environment
@@ -846,8 +849,10 @@
((compile-to-closure
form
'()
- (##sys#current-meta-environment)) ;XXX evalenv? static?
- '() ) )
+ (##sys#current-meta-environment)
+ #f #f #f ;XXX evalenv? static?
+ #t) ; toplevel.
+ '()) )
(lambda ()
(##sys#active-eval-environment aee)
(##sys#current-module oldcm)
@@ -865,11 +870,11 @@
(let ((se2 (##sys#slot env 2)))
((if se2 ; not interaction-environment?
(parameterize ((##sys#macro-environment '()))
- (compile-to-closure x '() se2 #f env (##sys#slot env 3)))
- (compile-to-closure x '() se #f env #f))
+ (compile-to-closure x '() se2 #f env (##sys#slot env 3) #t))
+ (compile-to-closure x '() se #f env #f #t))
'() ) ) )
(else
- ((compile-to-closure x '() se #f #f #f) '())))))))
+ ((compile-to-closure x '() se #f #f #f #t) '())))))))
(define (eval x . env)
(apply (eval-handler) x env))
diff --git a/expand.scm b/expand.scm
index c279512..9e194b9 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1044,7 +1044,7 @@
(##sys#register-export name (##sys#current-module)))
(when (c (r 'define) head)
(chicken.expand#defjam-error x))
- `(##core#set!
+ `(##core#define-toplevel
,head
,(if (pair? body) (car body) '(##core#undefined))) )
((pair? (car head))
diff --git a/tests/functor-tests.scm b/tests/functor-tests.scm
index 173b8d4..8d109e6 100644
--- a/tests/functor-tests.scm
+++ b/tests/functor-tests.scm
@@ -166,6 +166,8 @@
(import chicken X)
yibble)
+;; XXX This is somewhat iffy: functor instantiation results in a
+;; value!
(test-equal
"alternative functor instantiation syntax"
(module yabble = frob (import scheme) (define yibble 99))
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index a43b20e..4f07a3c 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -783,6 +783,13 @@
)
|#
+;;; Definitions in expression contexts are rejected (#1309)
+
+(f (eval '(+ 1 2 (define x 3) 4)))
+(f (eval '(display (define x 1))))
+;; Some tests for nested but valid definition expressions:
+(t 2 (eval '(begin (define x 1) 2)))
+(t 2 (eval '(module _ () (import scheme) (define x 1) 2)))
;;; renaming of keyword argument (#277)
--
2.1.4
From 0d7d60f502ebef3071bf65ee00fe507da6155a06 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Sat, 25 Feb 2017 15:45:41 +0100
Subject: [PATCH 2/5] Fix invalid definition caught by previous commit.
This was inadvertantly treated as a global definition before!
---
chicken-profile.scm | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/chicken-profile.scm b/chicken-profile.scm
index 85120fa..4a6bbb8 100644
--- a/chicken-profile.scm
+++ b/chicken-profile.scm
@@ -138,14 +138,14 @@ EOF
(set! sort-by sort-by-time)
(define (set-decimals arg)
+ (define (arg-digit n)
+ (let ((n (- (char->integer (string-ref arg n))
+ (char->integer #\0))))
+ (if (<= 0 n 9)
+ (if (= n 9) 8 n) ; 9 => overflow in format-real
+ (error "invalid argument to -decimals option" arg))))
(if (= (string-length arg) 3)
(begin
- (define (arg-digit n)
- (let ((n (- (char->integer (string-ref arg n))
- (char->integer #\0))))
- (if (<= 0 n 9)
- (if (= n 9) 8 n) ; 9 => overflow in format-real
- (error "invalid argument to -decimals option" arg))))
(set! seconds-digits (arg-digit 0))
(set! average-digits (arg-digit 1))
(set! percent-digits (arg-digit 2)))
--
2.1.4
From cfcaaa3a1bb97d09e3457623a53cf6b5162d1957 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Sat, 25 Feb 2017 17:04:28 +0100
Subject: [PATCH 3/5] Export internal define-like definitions from
chicken.syntax
Without this, the compiler would "inline" these aggressively as
unspecified, because they're not assigned to from within the
module itself.
---
expand.scm | 20 +++++++++++++-------
tests/syntax-tests.scm | 3 +++
2 files changed, 16 insertions(+), 7 deletions(-)
diff --git a/expand.scm b/expand.scm
index 9e194b9..9ee0140 100644
--- a/expand.scm
+++ b/expand.scm
@@ -42,7 +42,13 @@
strip-syntax
syntax-error
er-macro-transformer
- ir-macro-transformer)
+ ir-macro-transformer
+
+ ;; These must be exported or the compiler will assume they're never
+ ;; assigned to.
+ define-definition
+ define-syntax-definition
+ define-values-definition)
(import scheme chicken
chicken.keyword)
@@ -471,9 +477,9 @@
;
; This code is disgustingly complex.
-(define chicken.expand#define-definition)
-(define chicken.expand#define-syntax-definition)
-(define chicken.expand#define-values-definition)
+(define define-definition)
+(define define-syntax-definition)
+(define define-values-definition)
(define ##sys#canonicalize-body
(lambda (body #!optional (se (##sys#current-environment)) cs?)
@@ -481,9 +487,9 @@
(let ((f (lookup id se)))
(or (eq? s f)
(case s
- ((define) (if f (eq? f chicken.expand#define-definition) (eq? s id)))
- ((define-syntax) (if f (eq? f chicken.expand#define-syntax-definition) (eq? s id)))
- ((define-values) (if f (eq? f chicken.expand#define-values-definition) (eq? s id)))
+ ((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)))
(else (eq? s id))))))
(define (fini vars vals mvars body)
(if (and (null? vars) (null? mvars))
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index 4f07a3c..1da12c3 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -790,6 +790,9 @@
;; Some tests for nested but valid definition expressions:
(t 2 (eval '(begin (define x 1) 2)))
(t 2 (eval '(module _ () (import scheme) (define x 1) 2)))
+(t 1 (eval '(let ()
+ (define-record-type foo (make-foo bar) foo? (bar foo-bar))
+ (foo-bar (make-foo 1)))))
;;; renaming of keyword argument (#277)
--
2.1.4
From 7aa1fbaca16c4ecd0310b843290512ebabc21af5 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Sat, 25 Feb 2017 21:04:45 +0100
Subject: [PATCH 4/5] 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.
---
expand.scm | 103 ++++++++++++++++++++++++++++++-------------------
tests/syntax-tests.scm | 4 ++
2 files changed, 68 insertions(+), 39 deletions(-)
diff --git a/expand.scm b/expand.scm
index 9ee0140..b1a91eb 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 1da12c3..6cbb751 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
--
2.1.4
From eebe22419e3df08c9d7b5e4e7acd148c6dcc58c7 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Sat, 18 Mar 2017 14:15:35 +0100
Subject: [PATCH 5/5] Add expander hook so compiler can track line numbers.
This restores (and even improves) precision of line number reporting
in let bodies. Now that ##sys#canonicalize-body is performing macro
expansion, we need a way for the compiler to update its line number
database. This information got lost in the preceding commit.
---
core.scm | 65 +++++++++++++++++++++++++++++++----------------
expand.scm | 7 ++---
tests/scrutiny-2.expected | 10 ++++----
3 files changed, 52 insertions(+), 30 deletions(-)
diff --git a/core.scm b/core.scm
index b24e5ca..8fc8fc2 100644
--- a/core.scm
+++ b/core.scm
@@ -509,6 +509,18 @@
(##sys#put! alias '##core#macro-alias (lookup var se))
alias) )
+ (define (handle-expansion-result outer-ln)
+ (lambda (input output)
+ (and-let* (((not (eq? input output)))
+ (ln (or (get-line input) outer-ln)))
+ (update-line-number-database! output ln))
+ output))
+
+ (define (canonicalize-body/ln ln body se cs?)
+ (fluid-let ((expansion-result-hook
+ (handle-expansion-result ln)))
+ (##sys#canonicalize-body body se cs?)))
+
(define (set-real-names! as ns)
(for-each (lambda (a n) (set-real-name! a n)) as ns) )
@@ -601,8 +613,10 @@
(set! ##sys#syntax-error-culprit x)
(let* ((name0 (lookup (car x) se))
(name (or (and (symbol? name0) (##sys#get name0 '##core#primitive)) name0))
- (xexpanded (expand x se compiler-syntax-enabled)))
- (when ln (update-line-number-database! xexpanded ln))
+ (xexpanded
+ (fluid-let ((expansion-result-hook
+ (handle-expansion-result ln)))
+ (expand x se compiler-syntax-enabled))))
(cond ((not (eq? x xexpanded))
(walk xexpanded e se dest ldest h ln tl?))
@@ -690,14 +704,15 @@
(let* ((bindings (cadr x))
(vars (unzip1 bindings))
(aliases (map gensym vars))
- (se2 (##sys#extend-se se vars aliases)))
+ (se2 (##sys#extend-se se vars aliases))
+ (ln (or (get-line x) outer-ln)))
(set-real-names! aliases vars)
`(let
,(map (lambda (alias b)
(list alias (walk (cadr b) e se (car b) #t h ln #f)) )
aliases bindings)
- ,(walk (##sys#canonicalize-body
- (cddr x) se2 compiler-syntax-enabled)
+ ,(walk (canonicalize-body/ln
+ ln (cddr x) se2 compiler-syntax-enabled)
(append aliases e)
se2 dest ldest h ln #f) ) ) )
@@ -745,9 +760,10 @@
llist
(lambda (vars argc rest)
(let* ((aliases (map gensym vars))
+ (ln (or (get-line x) outer-ln))
(se2 (##sys#extend-se se vars aliases))
- (body0 (##sys#canonicalize-body
- obody se2 compiler-syntax-enabled))
+ (body0 (canonicalize-body/ln
+ ln obody se2 compiler-syntax-enabled))
(body (walk
(if emit-debug-info
`(##core#begin
@@ -787,11 +803,12 @@
(##sys#eval/meta (cadr b))
(strip-syntax (car b)))))
(cadr x) )
- se) ) )
+ se) )
+ (ln (or (get-line x) outer-ln)))
(walk
- (##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
- e se2
- dest ldest h ln #f) ) )
+ (canonicalize-body/ln
+ ln (cddr x) se2 compiler-syntax-enabled)
+ e se2 dest ldest h ln #f) ) )
((##core#letrec-syntax)
(let* ((ms (map (lambda (b)
@@ -802,13 +819,15 @@
(##sys#eval/meta (cadr b))
(strip-syntax (car b)))))
(cadr x) ) )
- (se2 (append ms se)) )
+ (se2 (append ms se))
+ (ln (or (get-line x) outer-ln)) )
(for-each
(lambda (sb)
(set-car! (cdr sb) se2) )
ms)
(walk
- (##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
+ (canonicalize-body/ln
+ ln (cddr x) se2 compiler-syntax-enabled)
e se2 dest ldest h ln #f)))
((##core#define-syntax)
@@ -882,7 +901,8 @@
(strip-syntax (car b)))
se))
(##sys#get name '##compiler#compiler-syntax) ) ) )
- (cadr x))))
+ (cadr x)))
+ (ln (or (get-line x) outer-ln)))
(dynamic-wind
(lambda ()
(for-each
@@ -891,8 +911,8 @@
bs) )
(lambda ()
(walk
- (##sys#canonicalize-body
- (cddr x) se compiler-syntax-enabled)
+ (canonicalize-body/ln
+ ln (cddr x) se compiler-syntax-enabled)
e se dest ldest h ln tl?) )
(lambda ()
(for-each
@@ -1010,15 +1030,16 @@
body))))
((##core#loop-lambda) ;XXX is this really needed?
- (let* ([vars (cadr x)]
- [obody (cddr x)]
- [aliases (map gensym vars)]
+ (let* ((vars (cadr x))
+ (obody (cddr x))
+ (aliases (map gensym vars))
(se2 (##sys#extend-se se vars aliases))
- [body
+ (ln (or (get-line x) outer-ln))
+ (body
(walk
- (##sys#canonicalize-body obody se2 compiler-syntax-enabled)
+ (canonicalize-body/ln ln obody se2 compiler-syntax-enabled)
(append aliases e)
- se2 #f #f dest ln #f) ] )
+ se2 #f #f dest ln #f) ) )
(set-real-names! aliases vars)
`(##core#lambda ,aliases ,body) ) )
diff --git a/expand.scm b/expand.scm
index b1a91eb..d1d8ee3 100644
--- a/expand.scm
+++ b/expand.scm
@@ -48,7 +48,8 @@
;; assigned to.
define-definition
define-syntax-definition
- define-values-definition)
+ define-values-definition
+ expansion-result-hook)
(import scheme chicken
chicken.keyword)
@@ -259,7 +260,7 @@
"' returns original form, which would result in endless expansion")
exp))
(dx `(,name --> ,exp2))
- exp2)))
+ (expansion-result-hook exp exp2) ) ) )
(define (expand head exp mdef)
(dd `(EXPAND:
,head
@@ -316,7 +317,7 @@
(define ##sys#compiler-syntax-hook #f)
(define ##sys#enable-runtime-macros #f)
-
+(define expansion-result-hook (lambda (input output) output))
;;; User-level macroexpansion
diff --git a/tests/scrutiny-2.expected b/tests/scrutiny-2.expected
index 4cabcc4..412e7a5 100644
--- a/tests/scrutiny-2.expected
+++ b/tests/scrutiny-2.expected
@@ -1,18 +1,18 @@
Note: at toplevel:
- (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is called with an argument of type `pair' and will always return true
+ (scrutiny-tests-2.scm:20) in procedure call to `pair?', the predicate is called with an argument of type `pair' and will always return true
Note: at toplevel:
- (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is called with an argument of type `null' and will always return false
+ (scrutiny-tests-2.scm:20) in procedure call to `pair?', the predicate is called with an argument of type `null' and will always return false
Note: at toplevel:
- (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is called with an argument of type `null' and will always return false
+ (scrutiny-tests-2.scm:20) in procedure call to `pair?', the predicate is called with an argument of type `null' and will always return false
Note: at toplevel:
- (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is called with an argument of type `fixnum' and will always return false
+ (scrutiny-tests-2.scm:20) in procedure call to `pair?', the predicate is called with an argument of type `fixnum' and will always return false
Note: at toplevel:
- (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is called with an argument of type `float' and will always return false
+ (scrutiny-tests-2.scm:20) in procedure call to `pair?', the predicate is called with an argument of type `float' and will always return false
Note: at toplevel:
(scrutiny-tests-2.scm:21) in procedure call to `list?', the predicate is called with an argument of type `null' and will always return true
--
2.1.4
signature.asc
Description: Digital signature
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
