From c30904eac7aaca6ed865c59a1bdbfa5eda731fab Mon Sep 17 00:00:00 2001 From: Peter Bex 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 ) ; (##core#lambda ({}+ [. ]) ) ; (##core#set! ) +; (##core#define-toplevel ) ; (##core#begin ...) ; (##core#include | #f) ; (##core#loop-lambda ) @@ -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