~ chicken-core (chicken-5) 1f2722cd053d23292fca29508e7fb23187652dfa
commit 1f2722cd053d23292fca29508e7fb23187652dfa
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Mar 13 13:45:16 2010 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Mar 24 07:28:22 2010 +0100
various syntax bugfixes
diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index ad925223..7c33e446 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -70,7 +70,7 @@
'location
'()
(##sys#er-transformer
- (lambda (form r c)
+ (lambda (x r c)
(##sys#check-syntax 'location x '(location _))
`(##core#location ,(cadr x)))))
diff --git a/chicken.scm b/chicken.scm
index 167e2284..55eadbd8 100644
--- a/chicken.scm
+++ b/chicken.scm
@@ -35,7 +35,7 @@
(include "compiler-namespace")
(include "tweaks")
-(eval-when (load)
+(eval-when (load)
(include "chicken-ffi-syntax") )
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index d3c26717..ceedc546 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -194,8 +194,7 @@
load-type-database
local-definitions
location-pointer-map
- loop-lambda-names
- make-argument-list
+ make-argument-list
make-block-variable-literal
make-random-name
make-variable-list
diff --git a/compiler.scm b/compiler.scm
index 1550493c..09ad645f 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -99,19 +99,18 @@
; (##core#declare {<spec>})
; (##core#immutable <exp>)
; (##core#global-ref <variable>)
-; (quote <exp>)
-; ([##core#]syntax <exp>)
+; (##core#quote <exp>)
+; (##core#syntax <exp>)
; (##core#if <exp> <exp> [<exp>])
-; ([##core#]let <variable> ({(<variable> <exp>)}) <body>)
-; ([##core#]let ({(<variable> <exp>)}) <body>)
-; ([##core#]letrec ({(<variable> <exp>)}) <body>)
+; (##core#let <variable> ({(<variable> <exp>)}) <body>)
+; (##core#let ({(<variable> <exp>)}) <body>)
+; (##core#letrec ({(<variable> <exp>)}) <body>)
; (##core#let-location <symbol> <type> [<init>] <exp>)
-; ([##core#]lambda <variable> <body>)
-; ([##core#]lambda ({<variable>}+ [. <variable>]) <body>)
-; ([##core#]set! <variable> <exp>)
+; (##core#lambda <variable> <body>)
+; (##core#lambda ({<variable>}+ [. <variable>]) <body>)
+; (##core#set! <variable> <exp>)
; (##core#begin <exp> ...)
; (##core#include <string>)
-; (##core#named-lambda <name> <llist> <body>)
; (##core#loop-lambda <llist> <body>)
; (##core#undefined)
; (##core#primitive <name>)
@@ -140,12 +139,11 @@
; (##core#require-for-syntax <exp> ...)
; (##core#require-extension (<id> ...) <bool>)
; (##core#app <exp> {<exp>})
-; ([##core#]syntax <exp>)
-; (<exp> {<exp>})
; (##core#define-syntax <symbol> <expr>)
; (##core#define-compiler-syntax <symbol> <expr>)
; (##core#let-compiler-syntax ((<symbol> <expr>) ...) <expr> ...)
; (##core#module <symbol> #t | (<name> | (<name> ...) ...) <body>)
+; (<exp> {<exp>})
; - Core language:
;
@@ -367,7 +365,6 @@
(define foreign-lambda-stubs '())
(define foreign-callback-stubs '())
(define external-variables '())
-(define loop-lambda-names '())
(define profile-lambda-list '())
(define profile-lambda-index 0)
(define profile-info-vector-name #f)
@@ -550,7 +547,7 @@
'(##core#undefined)
(walk (cadddr x) e se #f) ) ) )
- ((##core#syntax)
+ ((##core#syntax ##core#quote)
`(quote ,(##sys#strip-syntax (cadr x))))
((##core#check)
@@ -638,8 +635,7 @@
(##core#let () ,@body) )
e se dest)))
- ((lambda ##core#lambda) ;XXX qualify `lambda', but: (*)
- (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f se)
+ ((lambda ##core#lambda)
(let ((llist (cadr x))
(obody (cddr x)) )
(when (##sys#extended-lambda-list? llist)
@@ -825,7 +821,8 @@
(##sys#strip-syntax (caddr x)))))
(csyntax compiler-syntax))
(when (##sys#current-module)
- (##sys#syntax-error-hook 'module "modules may not be nested" name))
+ (##sys#syntax-error-hook
+ 'module "modules may not be nested" name))
(let-values (((body mreg)
(parameterize ((##sys#current-module
(##sys#register-module name exports) )
@@ -894,10 +891,7 @@
(set! compiler-syntax csyntax)
body))))
- ((##core#named-lambda)
- (walk `(##core#lambda ,@(cddr x)) e se (cadr x)) )
-
- ((##core#loop-lambda)
+ ((##core#loop-lambda) ;XXX is this really needed?
(let* ([vars (cadr x)]
[obody (cddr x)]
[aliases (map gensym vars)]
@@ -1262,8 +1256,7 @@
,(begin
(set! extended-bindings (append internal-bindings extended-bindings))
exp) )
- '() (##sys#current-environment)
- #f) ) )
+ '() (##sys#current-environment) #f) ) )
(define (process-declaration spec se) ; se unused in the moment
diff --git a/eval.scm b/eval.scm
index 0633b20e..5581ccff 100644
--- a/eval.scm
+++ b/eval.scm
@@ -689,9 +689,6 @@
[(##core#loop-lambda)
(compile `(,(rename 'lambda se) ,@(cdr x)) e #f tf cntr se) ]
- [(##core#named-lambda)
- (compile `(,(rename 'lambda se) ,@(cddr x)) e (cadr x) tf cntr se) ]
-
[(##core#require-for-syntax)
(let ([ids (map (lambda (x)
(eval/meta x))
@@ -745,7 +742,7 @@
[(##core#app)
(compile-call (cdr x) e tf cntr se) ]
- [else (compile-call x e tf cntr se)] ) ] ) ) ]
+ [else (compile-call x e tf cntr se)] ) ) ) ) ]
[else
(emit-syntax-trace-info tf x cntr)
@@ -821,8 +818,8 @@
(##sys#check-structure env 'environment)
(set! e (##sys#slot env 1))
(set! mut (##sys#slot env 2)) ) ) )
- ((fluid-let ([##sys#environment-is-mutable mut]
- [##sys#eval-environment e] )
+ ((fluid-let ((##sys#environment-is-mutable mut)
+ (##sys#eval-environment e) )
(##sys#compile-to-closure x '() (##sys#current-environment)) )
'() ) ) ) ) )
diff --git a/expand.scm b/expand.scm
index 19487840..11d87ce9 100644
--- a/expand.scm
+++ b/expand.scm
@@ -249,7 +249,9 @@
(values
`(##core#app
(##core#letrec
- ([,bindings (##core#loop-lambda ,(map (lambda (b) (car b)) bs) ,@(cddr body))])
+ ([,bindings
+ (##core#loop-lambda
+ ,(map (lambda (b) (car b)) bs) ,@(cddr body))])
,bindings)
,@(##sys#map cadr bs) )
#t) ) ]
@@ -1035,15 +1037,17 @@
'let
'()
(##sys#er-transformer
- (lambda (form r c)
- (##sys#check-syntax 'let x '(_ #((symbol _) 0) . #(_ 1)))
+ (lambda (x r c)
+ (if (and (pair? (cdr x)) (symbol? (cadr x)))
+ (##sys#check-syntax 'let x '(_ symbol #((symbol _) 0) . #(_ 1)))
+ (##sys#check-syntax 'let x '(_ #((symbol _) 0) . #(_ 1))))
`(##core#let ,@(cdr x)))))
(##sys#extend-macro-environment
'letrec
'()
(##sys#er-transformer
- (lambda (form r c)
+ (lambda (x r c)
(##sys#check-syntax 'letrec x '(_ #((symbol _) 0) . #(_ 1)))
`(##core#letrec ,@(cdr x)))))
@@ -1051,7 +1055,7 @@
'let-syntax
'()
(##sys#er-transformer
- (lambda (form r c)
+ (lambda (x r c)
(##sys#check-syntax 'let-syntax x '(_ #((symbol _) 0) . #(_ 1)))
`(##core#let-syntax ,@(cdr x)))))
@@ -1059,7 +1063,7 @@
'letrec-syntax
'()
(##sys#er-transformer
- (lambda (form r c)
+ (lambda (x r c)
(##sys#check-syntax 'letrec-syntax x '(_ #((symbol _) 0) . #(_ 1)))
`(##core#letrec-syntax ,@(cdr x)))))
@@ -1067,7 +1071,7 @@
'set!
'()
(##sys#er-transformer
- (lambda (form r c)
+ (lambda (x r c)
(##sys#check-syntax 'set! x '(_ _ _))
(let ((dest (cadr x))
(val (caddr x)))
@@ -1124,10 +1128,10 @@
((null? (cdr clause)) `(,%or ,(car clause) ,(expand rclauses)))
((c %=> (cadr clause))
(let ((tmp (r 'tmp)))
- `(,%let ((,tmp ,(car clause)))
- (,%if ,tmp
- (,(caddr clause) ,tmp)
- ,(expand rclauses) ) ) ) )
+ `(##core#let ((,tmp ,(car clause)))
+ (##core#if ,tmp
+ (,(caddr clause) ,tmp)
+ ,(expand rclauses) ) ) ) )
((and (list? clause) (fx= (length clause) 4)
(c %=> (caddr clause)))
(let ((tmp (r 'tmp)))
@@ -1232,7 +1236,7 @@
(let ((hx (car tail)))
(if (eq? n 0)
hx
- (list '##sys#list `(,%quote ,%unquote)
+ (list '##sys#list `(##core#quote ,%unquote)
(walk hx (fx- n 1)) ) ) )
`(##core#quote ,%unquote) ) )
((c %quasiquote head)
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index 23bcf601..65ebcb89 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -1,6 +1,9 @@
;;;; compiler-tests.scm
+(import foreign)
+
+
;; test dropping of previous toplevel assignments
(define (foo) (define (bar) 1) (bar 2)) ; will trigger error later
@@ -26,17 +29,16 @@
; - canonicalization of assignment to location didn't walk expansion recursively
(define test-location
- (let-location
- ((again bool #f))
- (lambda ()
- ((foreign-lambda*
- int
- (((c-pointer bool) again))
- "*again=1; return(1);")
- (location again))
- again)))
+ (let-location ((again bool #f))
+ (lambda ()
+ ((foreign-lambda*
+ int
+ (((c-pointer bool) again))
+ "*again=1; return(1);")
+ (location again))
+ again)))
-(print (test-location))
+(assert (test-location))
;;; rev. 12188 (reported by Jörg Wittenberger)
@@ -49,17 +51,18 @@
(import scheme chicken foreign)
(define (bar n)
- (let-location
- ((off integer 0))
- (lambda () ((foreign-lambda*
- void
- (((c-pointer integer) i))
- "(*i)++;")
- (location off)) off)))
+ (let-location ((off integer 0))
+ (lambda ()
+ ((foreign-lambda*
+ void
+ (((c-pointer integer) i))
+ "(*i)++;")
+ (location off))
+ off)))
)
(import x)
-(bar 42)
+(assert (= 1 ((bar 42))))
;;; rev. 14574 (reported by Peter Bex)
;
diff --git a/tests/runtests.sh b/tests/runtests.sh
index ba915f24..1e41afb9 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -121,6 +121,18 @@ $interpret matchable.scm -s match-test.scm
echo "======================================== syntax tests (loopy-loop) ..."
$interpret -s loopy-test.scm
+echo "======================================== r4rstest ..."
+echo "(expect mult-float-print-test to fail)"
+$interpret -e '(set! ##sys#procedure->string (constantly "#<procedure>"))' \
+ -i -s r4rstest.scm >r4rstest.log
+
+if test -n "$MSYSTEM"; then
+ # the windows runtime library prints flonums differently
+ tail r4rstest.log
+else
+ diff -bu r4rstest.out r4rstest.log || true
+fi
+
echo "======================================== syntax tests (r5rs_pitfalls) ..."
echo "(expect two failures)"
$interpret -i -s r5rs_pitfalls.scm
@@ -181,18 +193,6 @@ echo "======================================== regular expression tests ..."
$interpret -bnq test-irregex.scm
$interpret -bnq test-glob.scm
-echo "======================================== r4rstest ..."
-echo "(expect mult-float-print-test to fail)"
-$interpret -e '(set! ##sys#procedure->string (constantly "#<procedure>"))' \
- -i -s r4rstest.scm >r4rstest.log
-
-if test -n "$MSYSTEM"; then
- # the windows runtime library prints flonums differently
- tail r4rstest.log
-else
- diff -bu r4rstest.out r4rstest.log || true
-fi
-
echo "======================================== compiler/nursery stress test ..."
for s in 100000 120000 200000 250000 300000 350000 400000 450000 500000; do
echo " $s"
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index fb4b9a39..19097481 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -403,3 +403,33 @@
(let-syntax ((s1 (syntax-rules () ((_ x) x))))
(assert (equal? '#((99)) (s2 99))))
+
+;;; local definitions
+
+(define-syntax s2
+ (syntax-rules ()
+ ((_) 1)))
+
+(define (f1) 3)
+(define v1 9)
+(define v2 10)
+
+(let ()
+ (define-syntax s2
+ (syntax-rules ()
+ ((_) 2)))
+ 42
+ (define-values (v1 v2) (values 1 2))
+ 43
+ (define (f1) 4)
+ (define ((f2)) 4)
+ (assert (= 4 (f1)))
+ (assert (= 4 ((f2))))
+ (assert (= 2 (s2)))
+ (assert (= 1 v1))
+ (assert (= 2 v2)))
+
+(assert (= 1 (s2)))
+(assert (= 3 (f1)))
+(assert (= 9 v1))
+(assert (= 10 v2))
Trap