~ chicken-core (chicken-5) 61241e5d58299264ff0a8a7318288906ff710660
commit 61241e5d58299264ff0a8a7318288906ff710660
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sat Feb 11 15:30:13 2017 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Mar 22 11:15:53 2017 +0100
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
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/NEWS b/NEWS
index 4c97bcf0..aee94c56 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 718e7e8f..b24e5caa 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 f1f64715..72977a8e 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 c2795125..9e194b96 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 173b8d4a..8d109e6e 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 a43b20ed..4f07a3c6 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)
Trap