Hi all, Attached is a patch for #1309, which is due to an underlying problem that has plagued us for a long time, and has been reported in a few other bugs too (for example in #445 and #1297, and probably #512 too).
The attached patch fixes this by letting the core compiler (and also the closure compiler for "eval") keep track of whether or not the expression it's "walk"ing is at toplevel. This is then communicated to "expand" and parameterized. The exposed API is a procedure called "at-toplevel?", which can then be used by macros. I think once we apply this, we might try and see if we can simplify ##sys#canonicalize-body. It looks like it is more convoluted than necessary to avoid falling back to the global "define" in places where defines don't belong. And it doesn't work properly either, because even with this patch, something like (let () 1 (define x 2) x) still evaluates to 2, even though this is forbidden by the spec (see #1294). And I think #1132 is also a related bug. But this patch is a prequisite to cleaning things up, I think. We could also add a call to ##sys#check-toplevel-definition to the define-record-printer macro, but I think a proper fix for #1294 is to rework ##sys#canonicalize-body (I'll work on a follow-up patch for that once this is accepted). This patch should probably be applied to CHICKEN 5 only, because it messes with core macro expansion and changes the API to "expand" as well. I think it's acceptable to keep the bogus behaviour in CHICKEN 4, because it's only triggered by code that's incorrect in the first place. On a final note, I found it very surprising that in the tests, we use module declarations as expressions. In order not to change too much, I decided to simply reset the "at-toplevel" state to #t when compiling a module definition. We might want to revisit that, I think it's counter-intuitive that module or functor definitions are expressions that can even yield a value. Cheers, Peter
From bf174e79851934dc302eb6cf85b36f8ae0812641 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Thu, 8 Dec 2016 21:40:45 +0100
Subject: [PATCH] Let macros know if they run at toplevel.
This allows us to error out when encountering a definition in an
"expression context" (i.e., not at toplevel or in a place where an
internal define is allowed)
Introduces a new "at-toplevel?" procedure which can also be used by user
code to determine whether the current expansion is taking place in a
toplevel context.
Fixes #1309
---
NEWS | 2 +
chicken-ffi-syntax.scm | 3 +
chicken-syntax.scm | 5 ++
core.scm | 130 ++++++++++++++++++++---------------------
eval.scm | 151 ++++++++++++++++++++++++------------------------
expand.scm | 99 ++++++++++++++++++-------------
manual/Macros | 12 ++++
tests/functor-tests.scm | 2 +
tests/syntax-tests.scm | 7 +++
9 files changed, 232 insertions(+), 179 deletions(-)
diff --git a/NEWS b/NEWS
index 3d78582..5f33cd0 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.11.2
diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index 9bbe73f..0df4cbd 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -55,6 +55,7 @@
'()
(##sys#er-transformer
(lambda (form r c)
+ (##sys#check-toplevel-definition 'define-external form)
(let* ((form (cdr form))
(quals (and (pair? form) (string? (car form))))
(var (and (not quals) (pair? form) (symbol? (car form)))) )
@@ -100,6 +101,7 @@
'()
(##sys#er-transformer
(lambda (form r c)
+ (##sys#check-toplevel-definition 'define-location form)
(##sys#check-syntax 'define-location form '(_ variable _ . #(_ 0 1)))
(let ((var (cadr form))
(type (caddr form))
@@ -212,6 +214,7 @@
'()
(##sys#er-transformer
(lambda (form r c)
+ (##sys#check-toplevel-definition 'define-foreign-variable form)
`(##core#define-foreign-variable ,@(cdr form)))))
(##sys#extend-macro-environment
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index b4a19a1..4937ff1 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -56,6 +56,7 @@
'()
(##sys#er-transformer
(lambda (form r c)
+ (##sys#check-toplevel-definition 'define-constant form)
(##sys#check-syntax 'define-constant form '(_ symbol _))
`(##core#define-constant ,@(cdr form)))))
@@ -63,6 +64,7 @@
'define-record '()
(##sys#er-transformer
(lambda (x r c)
+ (##sys#check-toplevel-definition 'define-record x) ; clearer error
(##sys#check-syntax 'define-record x '(_ symbol . _))
(let* ((name (cadr x))
(slots (cddr x))
@@ -354,6 +356,7 @@
'define-values '()
(##sys#er-transformer
(lambda (form r c)
+ (##sys#check-toplevel-definition 'define-values form)
(##sys#check-syntax 'define-values form '(_ lambda-list _))
(##sys#decompose-lambda-list
(cadr form)
@@ -467,6 +470,7 @@
'define-inline '()
(##sys#er-transformer
(lambda (form r c)
+ (##sys#check-toplevel-definition 'define-inline form)
(letrec ([quotify-proc
(lambda (xs id)
(##sys#check-syntax id xs '#(_ 1))
@@ -840,6 +844,7 @@
'define-record-printer '()
(##sys#er-transformer
(lambda (form r c)
+ ;; TODO: Only allow at toplevel? It's not really a definition...
(##sys#check-syntax 'define-record-printer form '(_ _ . _))
(let ([head (cadr form)]
[body (cddr form)])
diff --git a/core.scm b/core.scm
index db6337d..e0a18b9 100644
--- a/core.scm
+++ b/core.scm
@@ -529,9 +529,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 +541,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 +551,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 +579,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)
@@ -600,25 +600,25 @@
(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)))
+ (xexpanded (expand x se compiler-syntax-enabled tl?)))
(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 +626,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 +667,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 +683,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 +693,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 +712,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 +730,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 +753,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 +790,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 +808,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 +833,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 +865,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 +892,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 +907,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 +916,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 +986,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 +999,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,7 +1017,7 @@
(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) ) )
@@ -1039,7 +1039,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 +1050,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 +1074,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 +1118,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,7 +1169,7 @@
(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) ] ) ) )
@@ -1212,7 +1212,7 @@
'() )
,(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))
@@ -1244,7 +1244,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 +1258,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 +1280,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 +1337,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 +1346,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 +1378,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 +1387,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 +1403,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 c43e444..bddc5f3 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)
@@ -315,10 +315,10 @@
(##sys#syntax-error/context "illegal non-atomic object" x)]
[(symbol? (##sys#slot x 0))
(emit-syntax-trace-info tf x cntr)
- (let ((x2 (expand x se)))
+ (let ((x2 (expand x se #f tl?)))
(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,40 @@
(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)) ) ] ) ) ]
+ ((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!)
(let ((var (cadr x)))
(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 +406,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 +437,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 +458,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 +475,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 +496,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 +583,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 +601,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 +616,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 +640,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 +691,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 +709,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 +745,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 +790,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 +799,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 +847,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 +868,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 783b34d..e95fb19 100644
--- a/expand.scm
+++ b/expand.scm
@@ -42,7 +42,8 @@
strip-syntax
syntax-error
er-macro-transformer
- ir-macro-transformer)
+ ir-macro-transformer
+ at-toplevel?)
(import scheme chicken
chicken.keyword)
@@ -209,7 +210,7 @@
;; The basic macro-expander
-(define (##sys#expand-0 exp dse cs?)
+(define (##sys#expand-0 exp dse cs? toplevel?)
(define (call-handler name handler exp se cs)
(dd "invoking macro: " name)
(dd `(STATIC-SE: ,@(map-se se)))
@@ -272,41 +273,42 @@
(call-handler head (cadr mdef) exp (car mdef) #f)
#t))
(else (values exp #f)) ) )
- (let loop ((exp exp))
- (if (pair? exp)
- (let ((head (car exp))
- (body (cdr exp)) )
- (if (symbol? head)
- (let ((head2 (or (lookup head dse) head)))
- (unless (pair? head2)
- (set! head2 (or (lookup head2 (##sys#macro-environment)) head2)) )
- (cond [(eq? head2 '##core#let)
- (##sys#check-syntax 'let body '#(_ 2) #f dse)
- (let ([bindings (car body)])
- (cond [(symbol? bindings) ; expand named let
- (##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)) #f dse)
- (let ([bs (cadr body)])
- (values
- `(##core#app
- (##core#letrec*
- ([,bindings
- (##core#loop-lambda
- ,(map (lambda (b) (car b)) bs) ,@(cddr body))])
- ,bindings)
- ,@(##sys#map cadr bs) )
- #t) ) ]
- [else (values exp #f)] ) ) ]
- ((and cs? (symbol? head2) (getp head2 '##compiler#compiler-syntax)) =>
- (lambda (cs)
- (let ((result (call-handler head (car cs) exp (cdr cs) #t)))
- (cond ((eq? result exp) (expand head exp head2))
- (else
- (when ##sys#compiler-syntax-hook
- (##sys#compiler-syntax-hook head result))
- (loop result))))))
- [else (expand head exp head2)] ) )
- (values exp #f) ) )
- (values exp #f) ) ) )
+ (parameterize ((expander-at-toplevel toplevel?))
+ (let loop ((exp exp))
+ (if (pair? exp)
+ (let ((head (car exp))
+ (body (cdr exp)) )
+ (if (symbol? head)
+ (let ((head2 (or (lookup head dse) head)))
+ (unless (pair? head2)
+ (set! head2 (or (lookup head2 (##sys#macro-environment)) head2)) )
+ (cond [(eq? head2 '##core#let)
+ (##sys#check-syntax 'let body '#(_ 2) #f dse)
+ (let ([bindings (car body)])
+ (cond [(symbol? bindings) ; expand named let
+ (##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)) #f dse)
+ (let ([bs (cadr body)])
+ (values
+ `(##core#app
+ (##core#letrec*
+ ([,bindings
+ (##core#loop-lambda
+ ,(map (lambda (b) (car b)) bs) ,@(cddr body))])
+ ,bindings)
+ ,@(##sys#map cadr bs) )
+ #t) ) ]
+ [else (values exp #f)] ) ) ]
+ ((and cs? (symbol? head2) (getp head2 '##compiler#compiler-syntax)) =>
+ (lambda (cs)
+ (let ((result (call-handler head (car cs) exp (cdr cs) #t)))
+ (cond ((eq? result exp) (expand head exp head2))
+ (else
+ (when ##sys#compiler-syntax-hook
+ (##sys#compiler-syntax-hook head result))
+ (loop result))))))
+ [else (expand head exp head2)] ) )
+ (values exp #f) ) )
+ (values exp #f) ) )) )
(define ##sys#compiler-syntax-hook #f)
(define ##sys#enable-runtime-macros #f)
@@ -315,9 +317,9 @@
;;; User-level macroexpansion
-(define (expand exp #!optional (se (##sys#current-environment)) cs?)
+(define (expand exp #!optional (se (##sys#current-environment)) cs? (toplevel? #t))
(let loop ((exp exp))
- (let-values (((exp2 m) (##sys#expand-0 exp se cs?)))
+ (let-values (((exp2 m) (##sys#expand-0 exp se cs? toplevel?)))
(if m
(loop exp2)
exp2) ) ) )
@@ -595,7 +597,7 @@
(else
(if (member (list head) vars)
(fini vars vals mvars body)
- (let ((x2 (##sys#expand-0 x se cs?)))
+ (let ((x2 (##sys#expand-0 x se cs? #f)))
(if (eq? x x2)
(fini vars vals mvars body)
(loop (cons x2 rest)
@@ -642,6 +644,11 @@
(define ##sys#syntax-error-culprit #f)
(define ##sys#syntax-context '())
+;; Used to forbid definitions in expression contexts
+(define expander-at-toplevel (make-parameter #t))
+
+(define (at-toplevel?) (expander-at-toplevel))
+
(define (syntax-error . args)
(apply ##sys#signal-hook #:syntax-error
(strip-syntax args)))
@@ -713,6 +720,17 @@
(define-constant +default-argument-count-limit+ 99999)
+(define ##sys#check-toplevel-definition
+ (lambda (form exp)
+ (unless (at-toplevel?)
+ (let ((ln (get-line-number exp))
+ (msg "definition found in expression context"))
+ (##sys#syntax-error-hook
+ (if ln
+ (string-append "(" ln ") in `" (symbol->string form) "' - " msg)
+ (string-append "in `" (symbol->string form) "' - " msg))
+ exp)))))
+
(define ##sys#check-syntax
(lambda (id exp pat #!optional culprit (se (##sys#current-environment)))
@@ -1034,6 +1052,7 @@
'()
(##sys#er-transformer
(lambda (x r c)
+ (##sys#check-toplevel-definition 'define x)
(##sys#check-syntax 'define x '(_ . #(_ 1)))
(let loop ((form x))
(let ((head (cadr form))
diff --git a/manual/Macros b/manual/Macros
index 36be848..691f4bc 100644
--- a/manual/Macros
+++ b/manual/Macros
@@ -86,6 +86,18 @@ below for more information about implicit renaming macros.
Strips all syntactical information from {{EXPRESSION}}, returning a new expression
where symbols have all context-information removed.
+==== at-toplevel?
+
+<procedure>(at-toplevel?)</procedure>
+
+This procedure determines whether the currently expanding macro is
+being expanded in a toplevel context. This can be useful to reject
+definitions in an expression context.
+
+It returns {{#t}} directly at the toplevel, but also for direct
+sub-expressions of any {{begin}} or {{module}} expression which is
+itself at the toplevel.
+
=== Explicit renaming macros
diff --git a/tests/functor-tests.scm b/tests/functor-tests.scm
index 3f0588b..5ef48bb 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..d17e472 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -783,6 +783,13 @@
)
|#
+;;; Definitions in expression contexts are rejected (#1309)
+
+(f (eval '(let () 1 (begin 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
signature.asc
Description: Digital signature
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
