~ chicken-core (chicken-5) d9cdb524431da58ec108100d7d0268d11fa49507
commit d9cdb524431da58ec108100d7d0268d11fa49507
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Mar 12 14:33:21 2010 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Mar 24 07:27:04 2010 +0100
started work on fully consistent syntax
diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index 6c27dd18..ad925223 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -66,6 +66,14 @@
;;; External locations:
+(##sys#extend-macro-environment
+ 'location
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'location x '(location _))
+ `(##core#location ,(cadr x)))))
+
(##sys#extend-macro-environment
'define-location
'()
diff --git a/compiler.scm b/compiler.scm
index a1109947..0759261a 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -550,8 +550,7 @@
'(##core#undefined)
(walk (cadddr x) e se #f) ) ) )
- ((quote syntax ##core#syntax) ;XXX qualify `quote' + `syntax'
- (##sys#check-syntax name x '(_ _) #f se)
+ ((##core#syntax)
`(quote ,(##sys#strip-syntax (cadr x))))
((##core#check)
@@ -611,8 +610,7 @@
`(##core#begin ,exp ,(loop (cdr ids))) ) ) ) )
e se dest) ) )
- ((let ##core#let) ;XXX qualify `let'
- (##sys#check-syntax 'let x '(_ #((variable _) 0) . #(_ 1)) #f se)
+ ((##core#let)
(let* ((bindings (cadr x))
(vars (unzip1 bindings))
(aliases (map gensym vars))
@@ -626,8 +624,7 @@
(append aliases e)
se2 dest) ) ) )
- ((letrec ##core#letrec) ;XXX qualify `letrec'
- (##sys#check-syntax 'letrec x '(_ #((symbol _) 0) . #(_ 1)))
+ ((##core#letrec)
(let ((bindings (cadr x))
(body (cddr x)) )
(walk
@@ -689,8 +686,7 @@
dest (cadr body) l)
l))))))))
- ((let-syntax) ;XXX qualify `let-syntax'
- (##sys#check-syntax 'let-syntax x '(let-syntax #((variable _) 0) . #(_ 1)) #f se)
+ ((##core#let-syntax)
(let ((se2 (append
(map (lambda (b)
(list
@@ -705,8 +701,7 @@
e se2
dest) ) )
- ((letrec-syntax) ;XXX qualify `letrec-syntax'
- (##sys#check-syntax 'letrec-syntax x '(letrec-syntax #((variable _) 0) . #(_ 1)) #f se)
+ ((##core#letrec-syntax)
(let* ((ms (map (lambda (b)
(list
(car b)
@@ -915,8 +910,7 @@
(set-real-names! aliases vars)
`(##core#lambda ,aliases ,body) ) )
- ((set! ##core#set!) ;XXX qualify `set!'
- (##sys#check-syntax 'set! x '(_ variable _) #f se)
+ ((##core#set!)
(let* ([var0 (cadr x)]
[var (lookup var0 se)]
[ln (get-line x)]
@@ -1210,37 +1204,32 @@
rtype) ) )
e se #f) ) ) ) )
- (else
- (let ([handle-call
- (lambda ()
- (let* ([x2 (mapwalk x e se)]
- [head2 (car x2)]
- [old (##sys#hash-table-ref line-number-database-2 head2)] )
- (when ln
- (##sys#hash-table-set!
- line-number-database-2
- head2
- (cons name (alist-cons x2 ln (if old (cdr old) '()))) ) )
- x2) ) ] )
-
- (cond [(eq? 'location name) ;XXX qualify `location'
- (##sys#check-syntax 'location x '(location _) #f se)
- (let ([sym (cadr x)])
- (if (symbol? sym)
- (cond [(assq (lookup sym se) location-pointer-map)
- => (lambda (a)
- (walk
- `(##sys#make-locative ,(second a) 0 #f 'location)
- e se #f) ) ]
- [(assq sym external-to-pointer)
- => (lambda (a) (walk (cdr a) e se #f)) ]
- [(memq sym callback-names)
- `(##core#inline_ref (,(symbol->string sym) c-pointer)) ]
- [else
- (walk `(##sys#make-locative ,sym 0 #f 'location) e se #f) ] )
- (walk `(##sys#make-locative ,sym 0 #f 'location) e se #f) ) ) ]
+ ((##core#location)
+ (let ([sym (cadr x)])
+ (if (symbol? sym)
+ (cond [(assq (lookup sym se) location-pointer-map)
+ => (lambda (a)
+ (walk
+ `(##sys#make-locative ,(second a) 0 #f 'location)
+ e se #f) ) ]
+ [(assq sym external-to-pointer)
+ => (lambda (a) (walk (cdr a) e se #f)) ]
+ [(memq sym callback-names)
+ `(##core#inline_ref (,(symbol->string sym) c-pointer)) ]
+ [else
+ (walk `(##sys#make-locative ,sym 0 #f 'location) e se #f) ] )
+ (walk `(##sys#make-locative ,sym 0 #f 'location) e se #f) ) ) )
- [else (handle-call)] ) ) ) ) ] ) ) ) )
+ (else
+ (let* ([x2 (mapwalk x e se)]
+ [head2 (car x2)]
+ [old (##sys#hash-table-ref line-number-database-2 head2)] )
+ (when ln
+ (##sys#hash-table-set!
+ line-number-database-2
+ head2
+ (cons name (alist-cons x2 ln (if old (cdr old) '()))) ) )
+ x2) ) ) ] ) ) ) )
((not (proper-list? x))
(syntax-error "malformed expression" x) )
@@ -1609,16 +1598,17 @@
((if) (let* ((t1 (gensym 'k))
(t2 (gensym 'r))
(k1 (lambda (r) (make-node '##core#call '(#t) (list (varnode t1) r)))) )
- (make-node 'let
- (list t1)
- (list (make-node '##core#lambda (list (gensym-f-id) #f (list t2) 0)
- (list (k (varnode t2))) )
- (walk (car subs)
- (lambda (v)
- (make-node 'if '()
- (list v
- (walk (cadr subs) k1)
- (walk (caddr subs) k1) ) ) ) ) ) ) ) )
+ (make-node
+ 'let
+ (list t1)
+ (list (make-node '##core#lambda (list (gensym-f-id) #f (list t2) 0)
+ (list (k (varnode t2))) )
+ (walk (car subs)
+ (lambda (v)
+ (make-node 'if '()
+ (list v
+ (walk (cadr subs) k1)
+ (walk (caddr subs) k1) ) ) ) ) ) ) ) )
((let)
(let loop ((vars params) (vals subs))
(if (null? vars)
diff --git a/eval.scm b/eval.scm
index 8224c040..0633b20e 100644
--- a/eval.scm
+++ b/eval.scm
@@ -345,8 +345,7 @@
;; a normal walking of the operator)
(case head
- [(quote)
- (##sys#check-syntax 'quote x '(quote _) #f se)
+ [(##core#quote)
(let* ((c (##sys#strip-syntax (cadr x))))
(case c
[(-1) (lambda v -1)]
@@ -358,7 +357,7 @@
[(()) (lambda v '())]
[else (lambda v c)] ) ) ]
- ((syntax ##core#syntax)
+ ((##core#syntax)
(let ((c (cadr x)))
(lambda v c)))
@@ -400,8 +399,7 @@
[x3 (compile `(##core#begin ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr se)] )
(lambda (v) (##core#app x1 v) (##core#app x2 v) (##core#app x3 v)) ) ] ) ) ]
- [(set! ##core#set!)
- (##sys#check-syntax 'set! x '(_ variable _) #f se)
+ [(##core#set!)
(let ((var (cadr x)))
(receive (i j) (lookup var e se)
(let ((val (compile (caddr x) e var tf cntr se)))
@@ -424,8 +422,7 @@
(##sys#setslot
(##core#inline "C_u_i_list_ref" v i) j (##core#app val v)) ) ] ) ) ) ) ]
- [(let ##core#let)
- (##sys#check-syntax 'let x '(_ #((variable _) 0) . #(_ 1)) #f se)
+ [(##core#let)
(let* ([bindings (cadr x)]
[n (length bindings)]
[vars (map (lambda (x) (car x)) bindings)]
@@ -476,8 +473,7 @@
(##sys#setslot v2 i (##core#app (##sys#slot vlist 0) v)) )
(##core#app body (cons v2 v)) ) ) ) ] ) ) ]
- ((letrec ##core#letrec)
- (##sys#check-syntax 'letrec x '(_ #((symbol _) 0) . #(_ 1)))
+ ((##core#letrec)
(let ((bindings (cadr x))
(body (cddr x)) )
(compile
@@ -491,7 +487,7 @@
(##core#let () ,@body) )
e h tf cntr se)))
- [(lambda ##core#lambda)
+ [(lambda ##core#lambda) ;XXX qualified only
(##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f se)
(let* ([llist (cadr x)]
[body (cddr x)]
@@ -586,8 +582,7 @@
(##core#app body (##sys#cons (apply ##sys#vector as) v)))))
info h cntr) ) ) ] ) ) ) ) ) ]
- ((let-syntax)
- (##sys#check-syntax 'let-syntax x '(let-syntax #((variable _) 0) . #(_ 1)) #f se)
+ ((##core#let-syntax)
(let ((se2 (append
(map (lambda (b)
(list
@@ -601,8 +596,7 @@
(##sys#canonicalize-body (cddr x) se2 #f)
e #f tf cntr se2)))
- ((letrec-syntax)
- (##sys#check-syntax 'letrec-syntax x '(letrec-syntax #((variable _) 0) . #(_ 1)) #f se)
+ ((##core#letrec-syntax)
(let* ((ms (map (lambda (b)
(list
(car b)
@@ -744,18 +738,14 @@
[(##core#primitive ##core#inline ##core#inline_allocate ##core#foreign-lambda
##core#define-foreign-variable
##core#define-external-variable ##core#let-location
- ##core#foreign-primitive
+ ##core#foreign-primitive ##core#location
##core#foreign-lambda* ##core#define-foreign-type)
(##sys#syntax-error-hook "cannot evaluate compiler-special-form" x) ]
[(##core#app)
(compile-call (cdr x) e tf cntr se) ]
- [else
- (cond [(eq? head 'location)
- (##sys#syntax-error-hook "cannot evaluate compiler-special-form" x) ]
-
- [else (compile-call x e tf cntr se)] ) ] ) ) ) ) ]
+ [else (compile-call x e tf cntr se)] ) ] ) ) ]
[else
(emit-syntax-trace-info tf x cntr)
diff --git a/expand.scm b/expand.scm
index 207cd256..fed712c5 100644
--- a/expand.scm
+++ b/expand.scm
@@ -240,7 +240,7 @@
(let ((head2 (or (lookup head dse) head)))
(unless (pair? head2)
(set! head2 (or (lookup head2 (##sys#macro-environment)) head2)) )
- (cond [(memq head2 '(let ##core#let))
+ (cond [(eq? head2 '##core#let)
(##sys#check-syntax 'let body '#(_ 2) #f dse)
(let ([bindings (car body)])
(cond [(symbol? bindings) ; expand named let
@@ -254,16 +254,6 @@
,@(##sys#map cadr bs) )
#t) ) ]
[else (values exp #f)] ) ) ]
- [(and (memq head2 '(set! ##core#set!)) ; "setter" syntax
- (pair? body)
- (pair? (car body)) )
- (let ([dest (car body)])
- (##sys#check-syntax 'set! body '(#(_ 1) _) #f dse)
- (values
- (append (list (list '##sys#setter (car dest)))
- (cdr dest)
- (cdr body) )
- #t) ) ]
((and cs? (symbol? head2) (##sys#get head2 '##compiler#compiler-syntax)) =>
(lambda (cs)
(let ((result (call-handler head (car cs) exp (cdr cs) #t)))
@@ -465,8 +455,9 @@
(let* ((vars (reverse vars))
(result
`(##core#let
- ,(##sys#map (lambda (v) (##sys#list v (##sys#list '##core#undefined)))
- (apply ##sys#append vars mvars) )
+ ,(##sys#map
+ (lambda (v) (##sys#list v (##sys#list '##core#undefined)))
+ (apply ##sys#append vars mvars) )
,@(map (lambda (v x) `(##core#set! ,v ,x)) vars (reverse vals))
,@(map (lambda (vs x)
(let ([tmps (##sys#map gensym vs)])
@@ -486,7 +477,7 @@
(fini
vars vals mvars mvals
(let loop ((body body) (defs '()) (done #f))
- (cond (done `((,(macro-alias 'letrec-syntax se)
+ (cond (done `((##core#letrec-syntax
,(map cdr (reverse defs)) ,@body) ))
((not (pair? body)) (loop body defs #t))
((and (list? (car body))
@@ -497,9 +488,9 @@
(loop
(cdr body)
(cons (if (pair? (cadr def))
- `(,(macro-alias 'define-syntax se)
+ `(##core#define-syntax
,(caadr def)
- (,(macro-alias 'lambda se) ,(cdadr def) ,@(cddr def)))
+ (##core#lambda ,(cdadr def) ,@(cddr def)))
def)
defs)
#f)))
@@ -515,12 +506,12 @@
(symbol? exp1)
(or (lookup exp1 se) exp1))))
(cond [(not (symbol? head)) (fini vars vals mvars mvals body)]
- [(eq? 'define head)
- (##sys#check-syntax 'define x '(define _ . #(_ 0)) #f se)
+ [(eq? 'define (or (lookup head se) head))
+ (##sys#check-syntax 'define x '(_ _ . #(_ 0)) #f se)
(let loop2 ([x x])
(let ([head (cadr x)])
(cond [(not (pair? head))
- (##sys#check-syntax 'define x '(define variable . #(_ 0)) #f se)
+ (##sys#check-syntax 'define x '(_ variable . #(_ 0)) #f se)
(loop rest (cons head vars)
(cons (if (pair? (cddr x))
(caddr x)
@@ -528,25 +519,24 @@
vals)
mvars mvals) ]
[(pair? (car head))
- (##sys#check-syntax 'define x '(define (_ . lambda-list) . #(_ 1)) #f se)
+ (##sys#check-syntax 'define x '(_ (_ . lambda-list) . #(_ 1)) #f se)
(loop2 (cons (macro-alias 'define se)
(##sys#expand-curried-define head (cddr x) se))) ]
[else
(##sys#check-syntax
'define x
- '(define (variable . lambda-list) . #(_ 1)) #f se)
+ '(_ (variable . lambda-list) . #(_ 1)) #f se)
(loop rest
(cons (car head) vars)
(cons `(##core#lambda ,(cdr head) ,@(cddr x)) vals)
mvars mvals) ] ) ) ) ]
- ((eq? 'define-syntax head) ;XXX captures, should perhaps use `##core#define-syntax'?
- (##sys#check-syntax 'define-syntax x '(define-syntax _ . #(_ 1)) se)
+ ((eq? 'define-syntax (or (lookup head se) head))
+ (##sys#check-syntax 'define-syntax x '(_ _ . #(_ 1)) se)
(fini/syntax vars vals mvars mvals body) )
- [(eq? 'define-values head) ;XXX captures
- (##sys#check-syntax 'define-values x '(define-values #(_ 0) _) #f se)
+ [(eq? 'define-values (or (lookup head se) head))
+ (##sys#check-syntax 'define-values x '(_ #(_ 0) _) #f se)
(loop rest vars vals (cons (cadr x) mvars) (cons (caddr x) mvals)) ]
- [(or (eq? 'begin head) (eq? '##core#begin head)) ;XXX only `##core#begin'?
- (##sys#check-syntax 'begin x '(_ . #(_ 0)) #f se)
+ [(eq? '##core#begin head)
(loop (##sys#append (cdr x) rest) vars vals mvars mvals) ]
((or (memq head vars) (memq head mvars))
(fini vars vals mvars mvals body))
@@ -966,6 +956,22 @@
(define ##sys#initial-macro-environment (##sys#macro-environment))
+(##sys#extend-macro-environment
+ 'quote
+ '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax 'quote x '(_ _))
+ `(##core#quote ,(cadr x)))))
+
+(##sys#extend-macro-environment
+ 'syntax
+ '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax 'syntax x '(_ _))
+ `(##core#syntax ,(cadr x)))))
+
(##sys#extend-macro-environment
'if
'()
@@ -1025,6 +1031,50 @@
,(car head)
(,(r 'lambda) ,(cdr head) ,@body))))))))
+(##sys#extend-macro-environment
+ 'let
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'let x '(_ #((symbol _) 0) . #(_ 1)))
+ `(##core#let ,@(cdr x)))))
+
+(##sys#extend-macro-environment
+ 'letrec
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'letrec x '(_ #((symbol _) 0) . #(_ 1)))
+ `(##core#letrec ,@(cdr x)))))
+
+(##sys#extend-macro-environment
+ 'let-syntax
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'let-syntax x '(_ #((symbol _) 0) . #(_ 1)))
+ `(##core#let-syntax ,@(cdr x)))))
+
+(##sys#extend-macro-environment
+ 'letrec-syntax
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'letrec-syntax x '(_ #((symbol _) 0) . #(_ 1)))
+ `(##core#letrec-syntax ,@(cdr x)))))
+
+(##sys#extend-macro-environment
+ 'set!
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'set! x '(_ _ _))
+ (let ((dest (cadr x))
+ (val (caddr x)))
+ (cond ((pair? dest)
+ `((##sys#setter ,(car dest)) ,@(cdr dest) ,val))
+ (else `(##core#set! ,dest ,val)))))))
+
(##sys#extend-macro-environment
'and
'()
Trap