~ chicken-core (chicken-5) 22699fd729e2b1e08e8bdb2d6a5d640382d209d8
commit 22699fd729e2b1e08e8bdb2d6a5d640382d209d8
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sun May 2 01:14:02 2010 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun May 2 01:14:02 2010 +0200
map and for-each check argument types, when expanded by compiler syntax (reported by zbigniew); procedure argument is evaluated in correct order
diff --git a/compiler-syntax.scm b/compiler-syntax.scm
index 3f85aed3..78748a69 100644
--- a/compiler-syntax.scm
+++ b/compiler-syntax.scm
@@ -61,6 +61,7 @@
(let ((%let (r 'let))
(%if (r 'if))
(%loop (r 'loop))
+ (%proc (gensym))
(%begin (r 'begin))
(%and (r 'and))
(%pair? (r 'pair?))
@@ -72,14 +73,19 @@
(c %lambda (caadr x)))
(symbol? (cadr x))))
(let ((vars (map (lambda _ (gensym)) lsts)))
- `(,%let ,%loop ,(map list vars lsts)
- (,%if (,%and ,@(map (lambda (v) `(,%pair? ,v)) vars))
- (,%begin
- ((,%begin ,(cadr x))
- ,@(map (lambda (v) `(##sys#slot ,v 0)) vars))
- (##core#app
- ,%loop
- ,@(map (lambda (v) `(##sys#slot ,v 1)) vars) ) ))))
+ `(,%let ((,%proc ,(cadr x))
+ ,@(map list vars lsts))
+ ,@(map (lambda (var)
+ `(##core#check (##sys#check-list ,var 'for-each)))
+ vars)
+ (,%let ,%loop ,(map list vars vars)
+ (,%if (,%and ,@(map (lambda (v) `(,%pair? ,v)) vars))
+ (,%begin
+ (,%proc
+ ,@(map (lambda (v) `(##sys#slot ,v 0)) vars))
+ (##core#app
+ ,%loop
+ ,@(map (lambda (v) `(##sys#slot ,v 1)) vars) ) )))))
x)))
(define-internal-compiler-syntax ((map ##sys#map #%map) x r c)
@@ -87,11 +93,12 @@
(let ((%let (r 'let))
(%if (r 'if))
(%loop (r 'loop))
- (%res (r 'res))
+ (%res (gensym))
(%cons (r 'cons))
(%set! (r 'set!))
- (%result (r 'result))
- (%node (r 'node))
+ (%result (gensym))
+ (%node (gensym))
+ (%proc (gensym))
(%quote (r 'quote))
(%begin (r 'begin))
(%lambda (r 'lambda))
@@ -105,21 +112,27 @@
(symbol? (cadr x))))
(let ((vars (map (lambda _ (gensym)) lsts)))
`(,%let ((,%result (,%quote ()))
- (,%node #f))
- (,%let ,%loop ,(map list vars lsts)
- (,%if (,%and ,@(map (lambda (v) `(,%pair? ,v)) vars))
- (,%let ((,%res
- (,%cons
- ((,%begin ,(cadr x))
- ,@(map (lambda (v) `(##sys#slot ,v 0)) vars))
- (,%quote ()))))
- (,%if ,%node
- (##sys#setslot ,%node 1 ,%res)
- (,%set! ,%result ,%res))
- (,%set! ,%node ,%res)
- (,%loop
- ,@(map (lambda (v) `(##sys#slot ,v 1)) vars)))
- ,%result))))
+ (,%node #f)
+ (,%proc ,(cadr x))
+ ,@(map list vars lsts))
+ ,@(map (lambda (var)
+ `(##core#check (##sys#check-list ,var 'map)))
+ vars)
+ (,%let ,%loop ,(map list vars vars)
+ (,%if (,%and ,@(map (lambda (v) `(,%pair? ,v)) vars))
+ (,%let ((,%res
+ (,%cons
+ (,%proc
+ ,@(map (lambda (v) `(##sys#slot ,v 0)) vars))
+ (,%quote ()))))
+ (,%if ,%node
+ (##sys#setslot ,%node 1 ,%res)
+ (,%set! ,%result ,%res))
+ (,%set! ,%node ,%res)
+ (##core#app
+ ,%loop
+ ,@(map (lambda (v) `(##sys#slot ,v 1)) vars)))
+ ,%result))))
x)))
(define-internal-compiler-syntax ((o #%o) x r c) ()
diff --git a/library.scm b/library.scm
index ff3f63c5..c2137a8e 100644
--- a/library.scm
+++ b/library.scm
@@ -445,8 +445,10 @@ EOF
((eq? x (##sys#slot lst 0)) (##sys#slot lst 1))
(else (cons (##sys#slot lst 0) (loop (##sys#slot lst 1)))) ) ) )
-(define (##sys#error-not-a-proper-list arg . loc)
- (##sys#error-hook (foreign-value "C_NOT_A_PROPER_LIST_ERROR" int) (and (pair? loc) (car loc)) arg) )
+(define (##sys#error-not-a-proper-list arg #!optional loc)
+ (##sys#error-hook
+ (foreign-value "C_NOT_A_PROPER_LIST_ERROR" int)
+ loc arg))
(define ##sys#not-a-proper-list-error ##sys#error-not-a-proper-list) ;DEPRECATED
Trap