~ chicken-core (chicken-5) 469f2bb6c196edadcb2ad44f65ddf1e04659198b
commit 469f2bb6c196edadcb2ad44f65ddf1e04659198b
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sun Apr 3 17:36:33 2016 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Mon Apr 4 16:37:08 2016 +1200
Fix #1274 by grouping mvars and vars together.
Instead of collecting mvars and vars in separate variables, which means
we lose their correct ordering, we now store them in "vars" and their
values in "vals". We still keep a separate "mvars" list around which
holds #t and #f to distinguish mvars from non-mvars, because non-mvars
are implicitly MV; additional values after the first must be silently
ignored. Also, set! is more efficient than call-with-values for one
argument.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/NEWS b/NEWS
index 78e41d1c..729c06c8 100644
--- a/NEWS
+++ b/NEWS
@@ -67,6 +67,10 @@
- The -sudo and -s options for chicken-install and chicken-uninstall
now honor a "SUDO" environment variable (thanks to Timo Myyrä).
+- Syntax expander
+ - Mixed internal define/define-values are now correctly ordered, so
+ later defines can refer to earlier define-values (#1274).
+
4.10.1
- Core libraries
diff --git a/expand.scm b/expand.scm
index 606452c4..3739d609 100644
--- a/expand.scm
+++ b/expand.scm
@@ -477,14 +477,14 @@
((define-syntax) (if f (eq? f ##sys#define-syntax-definition) (eq? s id)))
((define-values) (if f (eq? f ##sys#define-values-definition) (eq? s id)))
(else (eq? s id))))))
- (define (fini vars vals mvars mvals body)
+ (define (fini vars vals mvars body)
(if (and (null? vars) (null? mvars))
(let loop ([body2 body] [exps '()])
(if (not (pair? body2))
(cons
'##core#begin
body) ; no more defines, otherwise we would have called `expand'
- (let ([x (car body2)])
+ (let ((x (car body2)))
(if (and (pair? x)
(let ((d (car x)))
(and (symbol? d)
@@ -494,26 +494,32 @@
'##core#begin
(##sys#append (reverse exps) (list (expand body2))))
(loop (cdr body2) (cons x exps)) ) ) ) )
- (let* ((vars (reverse vars))
- (result
+ (let* ((result
`(##core#let
,(##sys#map
(lambda (v) (##sys#list v '(##core#undefined)))
- (foldl (lambda (l v) ; flatten multi-value formals
+ ;; vars are all normalised to lambda-lists: flatten them
+ (foldl (lambda (l v)
(##sys#append l (##sys#decompose-lambda-list
v (lambda (a _ _) a))))
- vars
- mvars))
- ,@(map (lambda (v x) `(##core#set! ,v ,x)) vars (reverse vals))
- ,@(map ##sys#expand-multiple-values-assignment
- (reverse mvars)
- (reverse mvals) )
+ '()
+ (reverse vars))) ; not strictly necessary...
+ ,@(map (lambda (var val is-mvar?)
+ ;; Non-mvars should expand to set! for
+ ;; efficiency, but also because they must be
+ ;; implicit multi-value continuations.
+ (if is-mvar?
+ (##sys#expand-multiple-values-assignment var val)
+ `(##core#set! ,(car var) ,val)))
+ (reverse vars)
+ (reverse vals)
+ (reverse mvars))
,@body) ) )
(dd `(BODY: ,result))
result)))
- (define (fini/syntax vars vals mvars mvals body)
+ (define (fini/syntax vars vals mvars body)
(fini
- vars vals mvars mvals
+ vars vals mvars
(let loop ((body body) (defs '()) (done #f))
(cond (done `((##core#letrec-syntax
,(map cdr (reverse defs)) ,@body) ))
@@ -539,60 +545,62 @@
#f)))
(else (loop body defs #t))))))
(define (expand body)
- (let loop ([body body] [vars '()] [vals '()] [mvars '()] [mvals '()])
+ ;; Each #t in "mvars" indicates an MV-capable "var". Non-MV
+ ;; vars (#f in mvars) are 1-element lambda-lists for simplicity.
+ (let loop ((body body) (vars '()) (vals '()) (mvars '()))
(if (not (pair? body))
- (fini vars vals mvars mvals body)
+ (fini vars vals mvars body)
(let* ((x (car body))
(rest (cdr body))
(exp1 (and (pair? x) (car x)))
(head (and exp1 (symbol? exp1) exp1)))
(if (not (symbol? head))
- (fini vars vals mvars mvals body)
+ (fini vars vals mvars body)
(cond
((comp 'define head)
(##sys#check-syntax 'define x '(_ _ . #(_ 0)) #f se)
- (let loop2 ([x x])
- (let ([head (cadr x)])
- (cond [(not (pair? head))
+ (let loop2 ((x x))
+ (let ((head (cadr x)))
+ (cond ((not (pair? head))
(##sys#check-syntax 'define x '(_ variable . #(_ 0)) #f se)
(when (eq? (car x) head) ; see above
(##sys#defjam-error x))
- (loop rest (cons head vars)
+ (loop rest (cons (list head) vars)
(cons (if (pair? (cddr x))
(caddr x)
'(##core#undefined) )
vals)
- mvars mvals) ]
- [(pair? (car head))
+ (cons #f mvars)))
+ ((pair? (car head))
(##sys#check-syntax
'define x '(_ (_ . lambda-list) . #(_ 1)) #f se)
(loop2
- (##sys#expand-curried-define head (cddr x) se)) ]
- [else
+ (##sys#expand-curried-define head (cddr x) se)))
+ (else
(##sys#check-syntax
'define x
'(_ (variable . lambda-list) . #(_ 1)) #f se)
(loop rest
- (cons (car head) vars)
+ (cons (list (car head)) vars)
(cons `(##core#lambda ,(cdr head) ,@(cddr x)) vals)
- mvars mvals) ] ) ) ) )
+ (cons #f mvars)))))))
((comp 'define-syntax head)
(##sys#check-syntax 'define-syntax x '(_ _ . #(_ 1)) se)
- (fini/syntax vars vals mvars mvals body) )
+ (fini/syntax vars vals mvars body))
((comp 'define-values head)
;;XXX check for any of the variables being `define-values'
(##sys#check-syntax 'define-values x '(_ lambda-list _) #f se)
- (loop rest vars vals (cons (cadr x) mvars) (cons (caddr x) mvals)))
+ (loop rest (cons (cadr x) vars) (cons (caddr x) vals) (cons #t mvars)))
((comp '##core#begin head)
- (loop (##sys#append (cdr x) rest) vars vals mvars mvals) )
+ (loop (##sys#append (cdr x) rest) vars vals mvars))
(else
- (if (or (memq head vars) (memq head mvars))
- (fini vars vals mvars mvals body)
+ (if (member (list head) vars)
+ (fini vars vals mvars body)
(let ((x2 (##sys#expand-0 x se cs?)))
(if (eq? x x2)
- (fini vars vals mvars mvals body)
+ (fini vars vals mvars body)
(loop (cons x2 rest)
- vars vals mvars mvals) ) ) ) ) ) ) ) ) ) )
+ vars vals mvars)))))))))))
(expand body) ) )
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index ba9b3fcd..48e2116f 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -749,6 +749,7 @@
(define-values (v1 v2) (values 1 2))
(define-values (v3 . v4) (values 3 4))
(define-values v56 (values 5 6))
+ (define v56-again v56) ; ordering of assignments was broken #1274
43
(define (f1) 4)
(define ((f2)) 4)
@@ -759,7 +760,8 @@
(assert (= 2 v2))
(assert (= 3 v3))
(assert (equal? (list 4) v4))
- (assert (equal? (list 5 6) v56)))
+ (assert (equal? (list 5 6) v56))
+ (assert (equal? (list 5 6) v56-again)))
(assert (= 1 (s2)))
(assert (= 3 (f1)))
Trap