~ chicken-core (chicken-5) 5aab750e2388fde60b5fd0c07f1157c23fb254a7
commit 5aab750e2388fde60b5fd0c07f1157c23fb254a7
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Jul 15 15:05:48 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Jul 15 15:05:48 2011 +0200
compiler-syntax fixes; removed uses of define-syntax with implicit lambda
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index e57148dd..aea116fd 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -141,22 +141,22 @@
(##sys#extend-macro-environment
'time '()
(##sys#er-transformer
- (lambda (form r c)
- (let ((rvar (r 't)))
- `(##core#begin
- (##sys#start-timer)
- (##sys#call-with-values
- (##core#lambda () ,@(cdr form))
- (##core#lambda
- ,rvar
- (##sys#display-times (##sys#stop-timer))
- (##sys#apply ##sys#values ,rvar) ) ) ) ) ) ) )
+ (lambda (form r c)
+ (let ((rvar (r 't)))
+ `(##core#begin
+ (##sys#start-timer)
+ (##sys#call-with-values
+ (##core#lambda () ,@(cdr form))
+ (##core#lambda
+ ,rvar
+ (##sys#display-times (##sys#stop-timer))
+ (##sys#apply ##sys#values ,rvar) ) ) ) ) ) ) )
(##sys#extend-macro-environment
'declare '()
(##sys#er-transformer
- (lambda (form r c)
- `(##core#declare ,@(cdr form)))))
+ (lambda (form r c)
+ `(##core#declare ,@(cdr form)))))
(##sys#extend-macro-environment
'include '()
@@ -1093,21 +1093,20 @@
(##sys#extend-macro-environment
'define-compiler-syntax '()
- (##sys#er-transformer
- (syntax-rules ()
- ((_ name)
- (##core#define-compiler-syntax name #f))
- ((_ (name . llist) body ...)
- (define-compiler-syntax name (lambda llist body ...)))
- ((_ name transformer)
- (##core#define-compiler-syntax name transformer)))))
+ (syntax-rules ()
+ ((_ name)
+ (##core#define-compiler-syntax name #f))
+ ((_ (name . llist) body ...) ; DEPRECATED
+ (define-compiler-syntax name
+ (##sys#er-transformer (lambda llist body ...) 'name)))
+ ((_ name transformer)
+ (##core#define-compiler-syntax name transformer))))
(##sys#extend-macro-environment
'let-compiler-syntax '()
- (##sys#er-transformer
- (syntax-rules ()
- ((_ (binding ...) body ...)
- (##core#let-compiler-syntax (binding ...) body ...)))))
+ (syntax-rules ()
+ ((_ (binding ...) body ...)
+ (##core#let-compiler-syntax (binding ...) body ...))))
;;; interface definition
diff --git a/compiler-syntax.scm b/compiler-syntax.scm
index 76fb4e85..835d161f 100644
--- a/compiler-syntax.scm
+++ b/compiler-syntax.scm
@@ -44,8 +44,8 @@
(define (r-c-s names transformer #!optional (se '()))
(let ((t (cons (##sys#ensure-transformer
- (##sys#er-transformer transformer)
- 'define-compiler-syntax)
+ (##sys#er-transformer transformer)
+ (car names))
se)))
(for-each
(lambda (name)
diff --git a/compiler.scm b/compiler.scm
index 2217bc6d..7c979a34 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -668,7 +668,7 @@
se
(##sys#ensure-transformer
(##sys#eval/meta (cadr b))
- 'let-syntax)))
+ (car b))))
(cadr x) )
se) ) )
(walk
@@ -683,7 +683,7 @@
#f
(##sys#ensure-transformer
(##sys#eval/meta (cadr b))
- 'letrec-syntax)))
+ (car b))))
(cadr x) ) )
(se2 (append ms se)) )
(for-each
@@ -727,14 +727,15 @@
(set! compiler-syntax
(alist-cons
name
- (##sys#get name '##compiler#compiler-syntax) compiler-syntax)))
+ (##sys#get name '##compiler#compiler-syntax)
+ compiler-syntax)))
(##sys#put!
name '##compiler#compiler-syntax
(and body
(##sys#cons
(##sys#ensure-transformer
(##sys#eval/meta body)
- 'define-compiler-syntax)
+ var)
(##sys#current-environment))))
(walk
(if ##sys#enable-runtime-macros
@@ -745,7 +746,7 @@
`(##sys#cons
(##sys#ensure-transformer
,body
- 'define-compiler-syntax)
+ ',var)
(##sys#current-environment))))
'(##core#undefined) )
e se dest ldest h)))
@@ -760,7 +761,7 @@
(and (pair? (cdr b))
(cons (##sys#ensure-transformer
(##sys#eval/meta (cadr b))
- 'let-compiler-syntax)
+ (car b))
se))
(##sys#get name '##compiler#compiler-syntax) ) ) )
(cadr x))))
diff --git a/eval.scm b/eval.scm
index c2d942f8..e2701566 100644
--- a/eval.scm
+++ b/eval.scm
@@ -557,7 +557,7 @@
se
(##sys#ensure-transformer
(##sys#eval/meta (cadr b))
- 'let-syntax)))
+ (car b))))
(cadr x) )
se) ) )
(compile
@@ -571,7 +571,7 @@
#f
(##sys#ensure-transformer
(##sys#eval/meta (cadr b))
- 'letrec-syntax)))
+ (car b))))
(cadr x) ) )
(se2 (append ms se)) )
(for-each
diff --git a/expand.scm b/expand.scm
index 697e3205..9fd21346 100644
--- a/expand.scm
+++ b/expand.scm
@@ -142,7 +142,7 @@
(define (##sys#extend-macro-environment name se transformer)
(let ((me (##sys#macro-environment))
- (handler (##sys#ensure-transformer transformer 'define-syntax)))
+ (handler (##sys#ensure-transformer transformer name)))
(cond ((lookup name me) =>
(lambda (a)
(set-car! a se)
@@ -487,10 +487,11 @@
(let ((def (car body)))
(loop
(cdr body)
- (cons (cond ((pair? (cadr def))
+ (cons (cond ((pair? (cadr def)) ; DEPRECATED
`(define-syntax ; (the first element is actually ignored)
,(caadr def)
- (##core#lambda ,(cdadr def) ,@(cddr def))))
+ (##sys#er-transformer
+ (##core#lambda ,(cdadr def) ,@(cddr def)))))
;; insufficient, if introduced by different expansions, but
;; better than nothing:
((eq? (car def) (cadr def))
@@ -983,7 +984,7 @@
(when (c (r 'define-syntax) head)
(##sys#defjam-error form))
`(##core#define-syntax ,head ,(car body)))
- (else
+ (else ; DEPRECATED
(##sys#check-syntax 'define-syntax head '(_ . lambda-list))
(##sys#check-syntax 'define-syntax body '#(_ 1))
(when (eq? (car form) (car head))
@@ -992,7 +993,7 @@
form))
`(##core#define-syntax
,(car head)
- (##core#lambda ,(cdr head) ,@body)))))))))
+ (##sys#er-transformer (##core#lambda ,(cdr head) ,@body))))))))))
(##sys#extend-macro-environment
'let
diff --git a/modules.scm b/modules.scm
index f42972b1..6188286a 100644
--- a/modules.scm
+++ b/modules.scm
@@ -335,17 +335,17 @@
(map (lambda (se)
(if (symbol? se)
(find-reexport se)
- (list (car se) #f (##sys#ensure-transformer (cdr se)))))
+ (list (car se) #f (##sys#ensure-transformer (cdr se) (car se)))))
sexports))
(iexps
(map (lambda (ie)
(if (pair? (cdr ie))
- (list (car ie) (cadr ie) (##sys#ensure-transformer (caddr ie)))
+ (list (car ie) (cadr ie) (##sys#ensure-transformer (caddr ie) (car ie)))
ie))
iexports))
(nexps
(map (lambda (ne)
- (list (car ne) #f (##sys#ensure-transformer (cdr ne))))
+ (list (car ne) #f (##sys#ensure-transformer (cdr ne) (car ne))))
sdefs))
(mod (make-module name '() vexports sexps))
(senv (merge-se
diff --git a/srfi-13.import.scm b/srfi-13.import.scm
index b2748d66..562df13c 100644
--- a/srfi-13.import.scm
+++ b/srfi-13.import.scm
@@ -128,4 +128,5 @@
,@body)
`(,%receive ,s-e-r
(,%string-parse-final-start+end ,proc ,s-exp ,args-exp)
- ,@body) ) )))))))
+ ,@body) ) )))
+ 'let-string-start+end))))
Trap