Now with attachments... On Sat, Feb 25, 2017 at 06:13:48PM +0100, Peter Bex wrote: > On Sat, Feb 11, 2017 at 03:37:35PM +0100, Peter Bex wrote: > > On Mon, Dec 12, 2016 at 09:38:17AM +0100, Peter Bex wrote: > > > I'll ponder this some more as well. > > > > Here's a very patch which _doesn't_ require macros to know they're > > being evaluated at toplevel or not. > > Here's an update with this patch plus two related patches which fix > an occurrance of a "define" in an invalid context in CHICKEN core > which you'll see when you try to recompile CHICKEN with itself after > having applied the first patch. > > This originally worked because the define would be a global one, which > is quite broken! I think erroring out early is a nice benefit. > Finally, the third patch here fixes a bug that we inadvertently > introduced when we made chicken.expand into a module: because these > internal definitions like chicken.expand#define-definition weren't > exported, and they're not set! inside the module, the compiler assumed > it would never be set, so it would inline the values, which means the > definitions would always be compared with #<unspecified>. > > 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. > > Cheers, > Peter
From c30904eac7aaca6ed865c59a1bdbfa5eda731fab 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/3] 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 5099942..fece6c6 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.0
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 c6dfb7f..b29d69b 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 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..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 370cee49e337ce1bcda4b28d82e6d52bb45b671a 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/3] 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 a97d7cbf658e595e172133c716d16532ee26242e 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/3] 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.
This is the final fix to complete #1309 (though the actual cause
is that the r7rs library needs to be refactored)
---
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
signature.asc
Description: Digital signature
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
