Hi all, I noticed that an ill-placed "define-values" can still result in new toplevel variables being defined.
In order to make this work without problems, I had to get rid of "##core#define-toplevel" and replace it with a pure check. Now the defining macros expand to something like this: (##core#begin (##core#ensure-toplevel-definition x) (set! x y)) The ensure-toplevel-definition will check that the definition is at toplevel and then compile down to (##core#undefined), and thus eventually it will just disappear, so the generated code should be identical to the original case of just a set!. This change was necessary because whatever I tried, with the old ##core#define-toplevel I was unable to prevent a failing values producer from resulting in the variables being (re)defined, which is definitely not what we want. PS: The ##core#set! hunk is so big because it fixes a bad indentation. I went through the trouble of replacining [] by () as well, while I'm at it. The only _real_ change is that the handling of ##core#define-toplevel is removed from that part of the code. Cheers, Peter
From d4ec4e39ebfa24c1acf1be6806ee338d393bf5bb Mon Sep 17 00:00:00 2001 From: Peter Bex <[email protected]> Date: Sun, 9 Apr 2017 15:20:51 +0200 Subject: [PATCH] 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. --- chicken-syntax.scm | 19 ++++---- core.scm | 126 ++++++++++++++++++++++++++----------------------- eval.scm | 20 ++++---- expand.scm | 8 ++-- tests/syntax-tests.scm | 3 +- 5 files changed, 96 insertions(+), 80 deletions(-) diff --git a/chicken-syntax.scm b/chicken-syntax.scm index b97e733..4441055 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 8fc8fc2..92a6021 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 72977a8..fec842f 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 d1d8ee3..3d376a6 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 6cbb751..49f9d64 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))) -- 2.1.4
signature.asc
Description: Digital signature
_______________________________________________ Chicken-hackers mailing list [email protected] https://lists.nongnu.org/mailman/listinfo/chicken-hackers
