~ chicken-core (chicken-5) 06299f3813c471e987a10d23d1f6399ae7f5072a
commit 06299f3813c471e987a10d23d1f6399ae7f5072a
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Mar 2 13:31:21 2010 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Tue Mar 2 13:31:21 2010 +0100
qualified core-forms and syntax for if and begin
diff --git a/compiler.scm b/compiler.scm
index 242c155c..6ca15a62 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -101,8 +101,7 @@
; (##core#global-ref <variable>)
; (quote <exp>)
; ([##core#]syntax <exp>)
-; (if <exp> <exp> [<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>)
@@ -110,7 +109,7 @@
; ([##core#]lambda <variable> <body>)
; ([##core#]lambda ({<variable>}+ [. <variable>]) <body>)
; ([##core#]set! <variable> <exp>)
-; ([##core#]begin <exp> ...)
+; (##core#begin <exp> ...)
; (##core#include <string>)
; (##core#named-lambda <name> <llist> <body>)
; (##core#loop-lambda <llist> <body>)
@@ -544,8 +543,7 @@
(when ln (update-line-number-database! xexpanded ln))
(case name
- ((if)
- (##sys#check-syntax 'if x '(if _ _ . #(_)) #f se)
+ ((##core#if)
`(if
,(walk (cadr x) e se #f)
,(walk (caddr x) e se #f)
@@ -553,7 +551,7 @@
'(##core#undefined)
(walk (cadddr x) e se #f) ) ) )
- ((quote syntax ##core#syntax)
+ ((quote syntax ##core#syntax) ;XXX qualify `quote' + `syntax'
(##sys#check-syntax name x '(_ _) #f se)
`(quote ,(##sys#strip-syntax (cadr x))))
@@ -614,7 +612,7 @@
`(##core#begin ,exp ,(loop (cdr ids))) ) ) ) )
e se dest) ) )
- ((let ##core#let)
+ ((let ##core#let) ;XXX qualify `let'
(##sys#check-syntax 'let x '(_ #((variable _) 0) . #(_ 1)) #f se)
(let* ((bindings (cadr x))
(vars (unzip1 bindings))
@@ -629,7 +627,7 @@
(append aliases e)
se2 dest) ) ) )
- ((letrec ##core#letrec)
+ ((letrec ##core#letrec) ;XXX qualify `letrec'
(##sys#check-syntax 'letrec x '(_ #((symbol _) 0) . #(_ 1)))
(let ((bindings (cadr x))
(body (cddr x)) )
@@ -644,7 +642,7 @@
(##core#let () ,@body) )
e se dest)))
- ((lambda ##core#lambda)
+ ((lambda ##core#lambda) ;XXX qualify `lambda', but: (*)
(##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f se)
(let ((llist (cadr x))
(obody (cddr x)) )
@@ -669,6 +667,8 @@
(cond ((or (not dest)
(assq dest se)) ; not global?
l)
+ ;; (*) here we make a distinction between user-
+ ;; lambdas and internally created lambdas. Bad.
((and (eq? 'lambda (or (lookup name se) name))
emit-profile
(or (eq? profiled-procedures 'all)
@@ -690,7 +690,7 @@
dest (cadr body) l)
l))))))))
- ((let-syntax)
+ ((let-syntax) ;XXX qualify `let-syntax'
(##sys#check-syntax 'let-syntax x '(let-syntax #((variable _) 0) . #(_ 1)) #f se)
(let ((se2 (append
(map (lambda (b)
@@ -706,7 +706,7 @@
e se2
dest) ) )
- ((letrec-syntax)
+ ((letrec-syntax) ;XXX qualify `letrec-syntax'
(##sys#check-syntax 'letrec-syntax x '(letrec-syntax #((variable _) 0) . #(_ 1)) #f se)
(let* ((ms (map (lambda (b)
(list
@@ -915,7 +915,7 @@
(set-real-names! aliases vars)
`(##core#lambda ,aliases ,body) ) )
- ((set! ##core#set!)
+ ((set! ##core#set!) ;XXX qualify `set!'
(##sys#check-syntax 'set! x '(_ variable _) #f se)
(let* ([var0 (cadr x)]
[var (lookup var0 se)]
@@ -993,8 +993,7 @@
(eval/meta (cadr x))
'(##core#undefined) )
- ((begin ##core#begin)
- (##sys#check-syntax 'begin x '(_ . #(_ 0)) #f se)
+ ((##core#begin)
(if (pair? (cdr x))
(canonicalize-begin-body
(let fold ([xs (cdr x)])
@@ -1224,7 +1223,7 @@
(cons name (alist-cons x2 ln (if old (cdr old) '()))) ) )
x2) ) ] )
- (cond [(eq? 'location name)
+ (cond [(eq? 'location name) ;XXX qualify `location'
(##sys#check-syntax 'location x '(location _) #f se)
(let ([sym (cadr x)])
(if (symbol? sym)
diff --git a/eval.scm b/eval.scm
index 63dd823d..24afb93d 100644
--- a/eval.scm
+++ b/eval.scm
@@ -375,8 +375,7 @@
[(##core#undefined) (lambda (v) (##core#undefined))]
- [(if)
- (##sys#check-syntax 'if x '(if _ _ . #(_)) #f se)
+ [(##core#if)
(let* ([test (compile (cadr x) e #f tf cntr se)]
[cns (compile (caddr x) e #f tf cntr se)]
[alt (if (pair? (cdddr x))
@@ -384,10 +383,9 @@
(compile '(##core#undefined) e #f tf cntr se) ) ] )
(lambda (v) (if (##core#app test v) (##core#app cns v) (##core#app alt v))) ) ]
- [(begin ##core#begin)
- (##sys#check-syntax 'begin x '(_ . #(_ 0)) #f se)
- (let* ([body (##sys#slot x 1)]
- [len (length body)] )
+ [(##core#begin)
+ (let* ((body (##sys#slot x 1))
+ (len (length body)) )
(case len
[(0) (compile '(##core#undefined) e #f tf cntr se)]
[(1) (compile (##sys#slot body 0) e #f tf cntr se)]
@@ -641,8 +639,10 @@
e #f tf cntr se))
((##core#include)
- `(##core#begin
- ,@(##sys#include-forms-from-file (cadr x))))
+ (compile
+ `(##core#begin
+ ,@(##sys#include-forms-from-file (cadr x)))
+ e #f tf cntr se))
((##core#module)
(let* ((name (##sys#strip-syntax (cadr x)))
diff --git a/expand.scm b/expand.scm
index 8854aa20..bd37221c 100644
--- a/expand.scm
+++ b/expand.scm
@@ -539,13 +539,13 @@
(cons (car head) vars)
(cons `(##core#lambda ,(cdr head) ,@(cddr x)) vals)
mvars mvals) ] ) ) ) ]
- ((eq? 'define-syntax head)
+ ((eq? 'define-syntax head) ;XXX captures, should perhaps use `##core#define-syntax'?
(##sys#check-syntax 'define-syntax x '(define-syntax _ . #(_ 1)) se)
(fini/syntax vars vals mvars mvals body) )
- [(eq? 'define-values head)
+ [(eq? 'define-values head) ;XXX captures
(##sys#check-syntax 'define-values x '(define-values #(_ 0) _) #f se)
(loop rest vars vals (cons (cadr x) mvars) (cons (caddr x) mvals)) ]
- [(or (eq? 'begin head) (eq? '##core#begin head))
+ [(or (eq? 'begin head) (eq? '##core#begin head)) ;XXX only `##core#begin'?
(##sys#check-syntax 'begin x '(_ . #(_ 0)) #f se)
(loop (##sys#append (cdr x) rest) vars vals mvars mvals) ]
((or (memq head vars) (memq head mvars))
@@ -966,6 +966,22 @@
(define ##sys#initial-macro-environment (##sys#macro-environment))
+(##sys#extend-macro-environment
+ 'if
+ '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax 'if x '(_ _ _ . #(_)))
+ `(##core#if ,@(cdr x)))))
+
+(##sys#extend-macro-environment
+ 'begin
+ '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax 'begin x '(_ . #(_ 0)))
+ `(##core#begin ,@(cdr x)))))
+
(##sys#extend-macro-environment
'define
'()
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 6d58ab98..e2d77ff8 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -16,10 +16,10 @@ Warning: in toplevel procedure `foo':
(if x5 (values '1 '2) (values '1 '2 (+ ...)))
Warning: at toplevel:
- expected argument #2 of type `number' in procedure call to `bar6' (line 18), but where given an argument of type `symbol'
+ scrutiny-tests.scm:18: in procedure call to `bar6', expected argument #2 of type `number', but where given an argument of type `symbol'
Warning: at toplevel:
- expected in procedure call to `pp' (line 20) 1 argument, but where given 0 arguments
+ scrutiny-tests.scm:20: in procedure call to `pp', expected 1 argument, but where given 0 arguments
Warning: at toplevel:
expected in argument #1 of procedure call `(print (cpu-time))' a single result, but were given 2 results
@@ -28,13 +28,13 @@ Warning: at toplevel:
expected in argument #1 of procedure call `(print (values))' a single result, but were given zero results
Warning: at toplevel:
- expected in procedure call to `x7' (line 26) a value of type `(procedure () *)', but were given a value of type `fixnum'
+ scrutiny-tests.scm:26: in procedure call to `x7', expected a value of type `(procedure () *)', but were given a value of type `fixnum'
Warning: at toplevel:
- expected argument #1 of type `number' in procedure call to `+' (line 28), but where given an argument of type `symbol'
+ scrutiny-tests.scm:28: in procedure call to `+', expected argument #1 of type `number', but where given an argument of type `symbol'
Warning: at toplevel:
- expected argument #2 of type `number' in procedure call to `+' (line 28), but where given an argument of type `symbol'
+ scrutiny-tests.scm:28: in procedure call to `+', expected argument #2 of type `number', but where given an argument of type `symbol'
Warning: at toplevel:
assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(procedure car (pair) *)'
@@ -43,6 +43,6 @@ Warning: at toplevel:
expected in `let' binding of `g8' a single result, but were given 2 results
Warning: at toplevel:
- expected in procedure call to `g89' a value of type `(procedure () *)', but were given a value of type `fixnum'
+ g89: in procedure call to `g89', expected a value of type `(procedure () *)', but were given a value of type `fixnum'
Warning: redefinition of standard binding `car'
Trap