~ chicken-core (chicken-5) 6992762995792a0668107c85b89b85b122f9fa1b
commit 6992762995792a0668107c85b89b85b122f9fa1b
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:18:12 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 8bf15342..40ac6d48 100644
--- a/NEWS
+++ b/NEWS
@@ -99,6 +99,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 b87f4644..43c090e7 100644
--- a/expand.scm
+++ b/expand.scm
@@ -481,14 +481,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)
@@ -498,26 +498,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) ))
@@ -543,60 +549,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
(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
- (expand-curried-define head (cddr x) se))]
- [else
+ (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 a20aa567..da626ab7 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -748,6 +748,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)
@@ -758,7 +759,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