~ chicken-core (chicken-5) 8fd98f5083b0f8e53a454d0fcbfdecc59774b34a
commit 8fd98f5083b0f8e53a454d0fcbfdecc59774b34a
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Jan 13 10:51:52 2010 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Jan 13 10:51:52 2010 +0100
proper restoration of compiler-syntax; optional removal of the same
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 31db6dff..7283b427 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1091,6 +1091,8 @@
'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)
diff --git a/compiler.scm b/compiler.scm
index f9f31cd2..a728f9e4 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -411,6 +411,7 @@
;;; Expand macros and canonicalize expressions:
(define (canonicalize-expression exp)
+ (let ((compiler-syntax '()))
(define (find-id id se) ; ignores macro bindings
(cond ((null? se) #f)
@@ -749,35 +750,45 @@
(let* ((var (cadr x))
(body (caddr x))
(name (##sys#strip-syntax var se #t)))
+ (when body
+ (set! compiler-syntax
+ (alist-cons
+ name
+ (##sys#get name '##compiler#compiler-syntax) compiler-syntax)))
(##sys#put!
name '##compiler#compiler-syntax
- (##sys#cons
- (##sys#er-transformer (eval/meta body))
- (##sys#current-environment)))
+ (and body
+ (##sys#cons
+ (##sys#er-transformer (eval/meta body))
+ (##sys#current-environment))))
(walk
(if ##sys#enable-runtime-macros
`(##sys#put!
(##core#syntax ,name)
'##compiler#compiler-syntax
- (##sys#cons
- (##sys#er-transformer ,body)
- (##sys#current-environment)))
+ ,(and body
+ `(##sys#cons
+ (##sys#er-transformer ,body)
+ (##sys#current-environment))))
'(##core#undefined) )
e se dest)))
((##core#let-compiler-syntax)
- (let ((bs (map (lambda (b)
- (##sys#check-syntax 'let-compiler-syntax b '(symbol _))
- (let ((name (##sys#strip-syntax (car b) se #t)))
- (list
- name
- (cons (##sys#er-transformer (eval/meta (cadr b))) se)
- (##sys#get name '##compiler#compiler-syntax) ) ) )
- (cadr x))))
- (dynamic-wind ; this ain't thread safe
+ (let ((bs (map
+ (lambda (b)
+ (##sys#check-syntax 'let-compiler-syntax b '(symbol . #(_ 0 1)))
+ (let ((name (##sys#strip-syntax (car b) se #t)))
+ (list
+ name
+ (and (pair? (cdr b))
+ (cons (##sys#er-transformer (eval/meta (cadr b))) se))
+ (##sys#get name '##compiler#compiler-syntax) ) ) )
+ (cadr x))))
+ (dynamic-wind
(lambda ()
(for-each
- (lambda (b) (##sys#put! (car b) '##compiler#compiler-syntax (cadr b)))
+ (lambda (b)
+ (##sys#put! (car b) '##compiler#compiler-syntax (cadr b)))
bs) )
(lambda ()
(walk
@@ -785,7 +796,8 @@
e se dest) )
(lambda ()
(for-each
- (lambda (b) (##sys#put! (car b) '##compiler#compiler-syntax (caddr b)))
+ (lambda (b)
+ (##sys#put! (car b) '##compiler#compiler-syntax (caddr b)))
bs) ) ) ) )
((##core#module)
@@ -804,7 +816,8 @@
(##sys#syntax-error-hook
'module
"invalid export syntax" exp name))))
- (##sys#strip-syntax (caddr x))))))
+ (##sys#strip-syntax (caddr x)))))
+ (csyntax compiler-syntax))
(when (##sys#current-module)
(##sys#syntax-error-hook 'module "modules may not be nested" name))
(let-values (((body mreg)
@@ -856,18 +869,24 @@
(##sys#current-environment)
#f)
xs))))))))
- (canonicalize-begin-body
- (append
- (parameterize ((##sys#current-module #f)
- (##sys#macro-environment (##sys#meta-macro-environment)))
- (map
- (lambda (x)
- (walk
- x
- e ;?
- (##sys#current-meta-environment) #f) )
- mreg))
- body)))))
+ (let ((body
+ (canonicalize-begin-body
+ (append
+ (parameterize ((##sys#current-module #f)
+ (##sys#macro-environment (##sys#meta-macro-environment)))
+ (map
+ (lambda (x)
+ (walk
+ x
+ e ;?
+ (##sys#current-meta-environment) #f) )
+ mreg))
+ body))))
+ (do ((cs compiler-syntax (cdr cs)))
+ ((eq? cs csyntax))
+ (##sys#put! (caar cs) '##compiler#compiler-syntax (cdar cs)))
+ (set! compiler-syntax csyntax)
+ body))))
((##core#named-lambda)
(walk `(##core#lambda ,@(cddr x)) e se (cadr x)) )
@@ -1245,7 +1264,7 @@
(set! extended-bindings (append internal-bindings extended-bindings))
exp) )
'() (##sys#current-environment)
- #f) )
+ #f) ) )
(define (process-declaration spec se) ; se unused in the moment
diff --git a/manual/Non-standard macros and special forms b/manual/Non-standard macros and special forms
index 79f8fb5e..33e41c72 100644
--- a/manual/Non-standard macros and special forms
+++ b/manual/Non-standard macros and special forms
@@ -297,6 +297,7 @@ for example.
==== define-compiler-syntax
+<macro>(define-compiler-syntax NAME)</macro><br>
<macro>(define-compiler-syntax NAME TRANSFORMER)</macro><br>
<macro>(define-compiler-syntax (NAME VAR ...) BODY ...)</macro>
@@ -324,12 +325,17 @@ can be defined with {{let-compiler-syntax}}.
((_ x 0) x) ) )
</scheme>
+If no transformer is given, then {{(define-compiler-syntax NAME)}} removes
+any compiler-syntax definitions for {{NAME}}.
+
==== let-compiler-syntax
-<macro>(let-compiler-syntax ((NAME TRANSFORMER) ...) BODY ...)</macro>
+<macro>(let-compiler-syntax ((NAME [TRANSFORMER]) ...) BODY ...)</macro>
Allows definition local compiler macros, which are only applicable inside {{BODY ...}}.
+By not providing a transformer expression, compiler-syntax for specific identifiers
+can be temporarily disabled.
=== Conditional forms
Trap