~ chicken-core (chicken-5) ae578568d3c6ca9dcb775217a90d77ffae1d7725
commit ae578568d3c6ca9dcb775217a90d77ffae1d7725
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sun Apr 9 15:20:51 2017 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Mon Apr 10 07:11:16 2017 +1200
Reject define-values in expression contexts.
This allows us to detect when define-values is being used in an
expression context, without it inadvertently defining toplevel
variables.
To make this work, ##core#define-toplevel is now removed in favour of
a new ##core#ensure-toplevel-definition. All defining forms will
expand to a call to this new core form plus a set!.
The tests for define in expression context were incorrect too, the
expression would result in an error (as expected) even if define
didn't error, because + would receive a void value.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index b97e733d..4441055c 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -366,14 +366,17 @@
(##sys#er-transformer
(lambda (form r c)
(##sys#check-syntax 'define-values form '(_ lambda-list _))
- (##sys#decompose-lambda-list
- (cadr form)
- (lambda (vars argc rest)
- (for-each (lambda (nm)
- (let ((name (##sys#get nm '##core#macro-alias nm)))
- (##sys#register-export name (##sys#current-module))))
- vars)))
- `(,(r 'set!-values) ,@(cdr form))))))
+ `(##core#begin
+ ,@(##sys#decompose-lambda-list
+ (cadr form)
+ (lambda (vars argc rest)
+ (for-each (lambda (nm)
+ (let ((name (##sys#get nm '##core#macro-alias nm)))
+ (##sys#register-export name (##sys#current-module))))
+ vars)
+ (map (lambda (nm) `(##core#ensure-toplevel-definition ,nm))
+ vars)))
+ ,(##sys#expand-multiple-values-assignment (cadr form) (caddr form)))))))
(##sys#extend-macro-environment
'let-values '()
diff --git a/core.scm b/core.scm
index 8fc8fc2a..d7b3aae0 100644
--- a/core.scm
+++ b/core.scm
@@ -110,7 +110,7 @@
; (##core#lambda <variable> <body>)
; (##core#lambda ({<variable>}+ [. <variable>]) <body>)
; (##core#set! <variable> <exp>)
-; (##core#define-toplevel <variable> <exp>)
+; (##core#ensure-toplevel-definition <variable>)
; (##core#begin <exp> ...)
; (##core#include <string> <string> | #f)
; (##core#loop-lambda <llist> <body>)
@@ -1043,65 +1043,71 @@
(set-real-names! aliases vars)
`(##core#lambda ,aliases ,body) ) )
- ((##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"
- var)))
- (cond ((assq var foreign-variables)
- => (lambda (fv)
- (let ([type (second fv)]
- [tmp (gensym)] )
- (walk
- `(let ([,tmp ,(foreign-type-convert-argument val type)])
- (##core#inline_update
- (,(third fv) ,type)
- ,(foreign-type-check tmp type) ) )
- e se #f #f h ln #f))))
- ((assq var location-pointer-map)
- => (lambda (a)
- (let* ([type (third a)]
- [tmp (gensym)] )
- (walk
- `(let ([,tmp ,(foreign-type-convert-argument val type)])
- (##core#inline_loc_update
- (,type)
- ,(second a)
- ,(foreign-type-check tmp type) ) )
- e se #f #f h ln #f))))
- (else
- (unless (memq var e) ; global?
- (set! var (or (##sys#get var '##core#primitive)
- (##sys#alias-global-hook var #t dest)))
- (when safe-globals-flag
- (mark-variable var '##compiler#always-bound-to-procedure)
- (mark-variable var '##compiler#always-bound))
- (when emit-debug-info
- (set! val
- `(let ((,var ,val))
- (##core#debug-event "C_DEBUG_GLOBAL_ASSIGN" ',var)
- ,var))))
- (cond ((##sys#macro? var)
- (warning
- (sprintf "assigned global variable `~S' is syntax ~A"
- var
- (if ln (sprintf "(~a)" ln) "") ))
- (when undefine-shadowed-macros (##sys#undefine-macro! var) ) )
- ((and ##sys#notices-enabled
- (assq var (##sys#current-environment)))
- (##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 #f))))))
+ ((##core#ensure-toplevel-definition)
+ (unless tl?
+ (let* ((var0 (cadr x))
+ (var (lookup var0 se))
+ (ln (get-line x)))
+ (quit-compiling
+ "~atoplevel definition of `~s' in non-toplevel context"
+ (if ln (sprintf "(~a) - " ln) "")
+ var)))
+ '(##core#undefined))
+
+ ((##core#set!)
+ (let* ((var0 (cadr x))
+ (var (lookup var0 se))
+ (ln (get-line x))
+ (val (caddr x)))
+ (when (memq var unlikely-variables)
+ (warning
+ (sprintf "assignment to variable `~s' possibly unintended"
+ var)))
+ (cond ((assq var foreign-variables)
+ => (lambda (fv)
+ (let ((type (second fv))
+ (tmp (gensym)))
+ (walk
+ `(let ((,tmp ,(foreign-type-convert-argument val type)))
+ (##core#inline_update
+ (,(third fv) ,type)
+ ,(foreign-type-check tmp type)))
+ e se #f #f h ln #f))))
+ ((assq var location-pointer-map)
+ => (lambda (a)
+ (let* ((type (third a))
+ (tmp (gensym)))
+ (walk
+ `(let ((,tmp ,(foreign-type-convert-argument val type)))
+ (##core#inline_loc_update
+ (,type)
+ ,(second a)
+ ,(foreign-type-check tmp type)))
+ e se #f #f h ln #f))))
+ (else
+ (unless (memq var e) ; global?
+ (set! var (or (##sys#get var '##core#primitive)
+ (##sys#alias-global-hook var #t dest)))
+ (when safe-globals-flag
+ (mark-variable var '##compiler#always-bound-to-procedure)
+ (mark-variable var '##compiler#always-bound))
+ (when emit-debug-info
+ (set! val
+ `(let ((,var ,val))
+ (##core#debug-event "C_DEBUG_GLOBAL_ASSIGN" ',var)
+ ,var))))
+ (cond ((##sys#macro? var)
+ (warning
+ (sprintf "assigned global variable `~S' is syntax ~A"
+ var
+ (if ln (sprintf "(~a)" ln) "")))
+ (when undefine-shadowed-macros (##sys#undefine-macro! var)))
+ ((and ##sys#notices-enabled
+ (assq var (##sys#current-environment)))
+ (##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 #f))))))
((##core#debug-event)
`(##core#debug-event
diff --git a/eval.scm b/eval.scm
index 72977a8e..89b1f82f 100644
--- a/eval.scm
+++ b/eval.scm
@@ -371,13 +371,17 @@
[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)
+ ((##core#ensure-toplevel-definition)
+ (unless tl?
+ (##sys#error "toplevel definition in non-toplevel context for variable" (cadr x)))
+ (compile
+ '(##core#undefined) e #f tf cntr se #f))
+
+ [(##core#set!)
(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 #f)))
- (cond [(not i)
+ (cond ((not i)
(when ##sys#notices-enabled
(and-let* ((a (assq var (##sys#current-environment)))
((symbol? (cdr a))))
@@ -392,12 +396,12 @@
(##sys#error 'eval "environment is not mutable" evalenv var)) ;XXX var?
(lambda (v)
(##sys#persist-symbol var)
- (##sys#setslot var 0 (##core#app val v))) ) ) ]
- [(zero? i) (lambda (v) (##sys#setslot (##sys#slot v 0) j (##core#app val v)))]
- [else
+ (##sys#setslot var 0 (##core#app val v))))))
+ ((zero? i) (lambda (v) (##sys#setslot (##sys#slot v 0) j (##core#app val v))))
+ (else
(lambda (v)
(##sys#setslot
- (##core#inline "C_u_i_list_ref" v i) j (##core#app val v)) ) ] ) ) ) ) ]
+ (##core#inline "C_u_i_list_ref" v i) j (##core#app val v))))))))]
[(##core#let)
(let* ([bindings (cadr x)]
diff --git a/expand.scm b/expand.scm
index d1d8ee34..02e69de1 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1076,9 +1076,11 @@
(##sys#register-export name (##sys#current-module)))
(when (c (r 'define) head)
(chicken.expand#defjam-error x))
- `(##core#define-toplevel
- ,head
- ,(if (pair? body) (car body) '(##core#undefined))) )
+ `(##core#begin
+ (##core#ensure-toplevel-definition ,head)
+ (##core#set!
+ ,head
+ ,(if (pair? body) (car body) '(##core#undefined)))))
((pair? (car head))
(##sys#check-syntax 'define form '(_ (_ . lambda-list) . #(_ 1)))
(loop (chicken.expand#expand-curried-define head body '()))) ;XXX '() should be se
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index 6cbb7511..49f9d641 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -785,7 +785,8 @@
;;; Definitions in expression contexts are rejected (#1309)
-(f (eval '(+ 1 2 (define x 3) 4)))
+(f (eval '(+ 1 2 (begin (define x 3) x) 4)))
+(f (eval '(+ 1 2 (begin (define-values (x y) (values 3 4)) x) 4)))
(f (eval '(display (define x 1))))
;; Some tests for nested but valid definition expressions:
(t 2 (eval '(begin (define x 1) 2)))
Trap