~ chicken-core (chicken-5) 24dd015c316ef1318c11f169ffd635c844df370a
commit 24dd015c316ef1318c11f169ffd635c844df370a
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Jul 15 14:44:34 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Jul 15 14:44:34 2011 +0200
use er-macro-transformer everywhere
diff --git a/irregex-core.scm b/irregex-core.scm
index 4f4656b5..c4245cac 100644
--- a/irregex-core.scm
+++ b/irregex-core.scm
@@ -82,8 +82,10 @@
(cond-expand
(chicken-bootstrap
(begin
- (define-syntax (internal x r c)
- `(,(with-input-from-string (cadr x) read) ,@(cddr x)))
+ (define-syntax internal
+ (er-macro-transformer
+ (lambda (x r c)
+ `(,(with-input-from-string (cadr x) read) ,@(cddr x)))))
;; make-irregex defined elsewhere
(define (irregex? x)
(internal "##sys#structure?" x 'regexp))
diff --git a/irregex.scm b/irregex.scm
index ba35d48b..4c521f64 100644
--- a/irregex.scm
+++ b/irregex.scm
@@ -86,43 +86,45 @@
(register-feature! 'irregex)
-(define-syntax (build-cache x r c)
- ;; (build-cache N ARG FAIL)
- (let* ((n (cadr x))
- (n2 (* n 2))
- (arg (caddr x))
- (fail (cadddr x))
- (%cache (r 'cache))
- (%index (r 'index))
- (%arg (r 'arg))
- (%let (r 'let))
- (%let* (r 'let*))
- (%if (r 'if))
- (%fx+ (r 'fx+))
- (%fxmod (r 'fxmod))
- (%equal? (r 'equal?))
- (%quote (r 'quote))
- (%tmp (r 'tmp))
- (%begin (r 'begin))
- (cache (make-vector (add1 n2) #f)))
- (##sys#setslot cache n2 0) ; last slot: current index
- `(,%let* ((,%cache (,%quote ,cache)) ; we mutate a literal vector
- (,%arg ,arg))
- ,(let fold ((i 0))
- (if (fx>= i n)
- ;; this should be thread-safe: a context-switch can only
- ;; happen before this code and in the call to FAIL.
- `(,%let ((,%tmp ,fail)
- (,%index (##sys#slot ,%cache ,n2)))
- (##sys#setslot ,%cache ,%index ,%arg)
- (##sys#setslot ,%cache (,%fx+ ,%index 1) ,%tmp)
- (##sys#setislot
- ,%cache ,n2
- (##core#inline "C_u_fixnum_modulo" (,%fx+ ,%index 2) ,n2))
- ,%tmp)
- `(,%if (,%equal? (##sys#slot ,%cache ,(* i 2)) ,%arg)
- (##sys#slot ,%cache ,(add1 (* i 2)))
- ,(fold (add1 i))))))))
+(define-syntax build-cache
+ (er-macro-transformer
+ (lambda (x r c)
+ ;; (build-cache N ARG FAIL)
+ (let* ((n (cadr x))
+ (n2 (* n 2))
+ (arg (caddr x))
+ (fail (cadddr x))
+ (%cache (r 'cache))
+ (%index (r 'index))
+ (%arg (r 'arg))
+ (%let (r 'let))
+ (%let* (r 'let*))
+ (%if (r 'if))
+ (%fx+ (r 'fx+))
+ (%fxmod (r 'fxmod))
+ (%equal? (r 'equal?))
+ (%quote (r 'quote))
+ (%tmp (r 'tmp))
+ (%begin (r 'begin))
+ (cache (make-vector (add1 n2) #f)))
+ (##sys#setslot cache n2 0) ; last slot: current index
+ `(,%let* ((,%cache (,%quote ,cache)) ; we mutate a literal vector
+ (,%arg ,arg))
+ ,(let fold ((i 0))
+ (if (fx>= i n)
+ ;; this should be thread-safe: a context-switch can only
+ ;; happen before this code and in the call to FAIL.
+ `(,%let ((,%tmp ,fail)
+ (,%index (##sys#slot ,%cache ,n2)))
+ (##sys#setslot ,%cache ,%index ,%arg)
+ (##sys#setslot ,%cache (,%fx+ ,%index 1) ,%tmp)
+ (##sys#setislot
+ ,%cache ,n2
+ (##core#inline "C_u_fixnum_modulo" (,%fx+ ,%index 2) ,n2))
+ ,%tmp)
+ `(,%if (,%equal? (##sys#slot ,%cache ,(* i 2)) ,%arg)
+ (##sys#slot ,%cache ,(add1 (* i 2)))
+ ,(fold (add1 i))))))))))
(define-compiler-syntax %%string-copy!
(syntax-rules ()
diff --git a/posix-common.scm b/posix-common.scm
index 283e6da5..3892b875 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -127,14 +127,16 @@ EOF
(define-foreign-variable _stat_st_dev unsigned-int "C_statbuf.st_dev")
(define-foreign-variable _stat_st_rdev unsigned-int "C_statbuf.st_rdev")
-(define-syntax (stat-mode x r c)
- ;; no need to rename here
- (let ((name (cadr x)))
- `(##core#begin
- (declare
- (foreign-declare
- ,(sprintf "#ifndef ~a~%#define ~a S_IFREG~%#endif~%" name name)))
- (define-foreign-variable ,name unsigned-int))))
+(define-syntax stat-mode
+ (er-macro-transformer
+ (lambda (x r c)
+ ;; no need to rename here
+ (let ((name (cadr x)))
+ `(##core#begin
+ (declare
+ (foreign-declare
+ ,(sprintf "#ifndef ~a~%#define ~a S_IFREG~%#endif~%" name name)))
+ (define-foreign-variable ,name unsigned-int))))))
(stat-mode S_IFLNK)
(stat-mode S_IFREG)
diff --git a/srfi-4.scm b/srfi-4.scm
index 3413ddfe..83df6718 100644
--- a/srfi-4.scm
+++ b/srfi-4.scm
@@ -394,24 +394,26 @@ EOF
;;; Creating vectors from a list:
-(define-syntax (list->NNNvector x r c)
- (let* ((tag (##sys#strip-syntax (cadr x)))
- (tagstr (symbol->string tag))
- (name (string->symbol (string-append "list->" tagstr)))
- (make (string->symbol (string-append "make-" tagstr)))
- (set (string->symbol (string-append tagstr "-set!"))))
- `(define ,name
- (let ((,make ,make))
- (lambda (lst)
- (##sys#check-list lst ',tag)
- (let* ((n (##core#inline "C_i_length" lst))
- (v (,make n)) )
- (do ((p lst (##core#inline "C_slot" p 1))
- (i 0 (##core#inline "C_fixnum_plus" i 1)) )
- ((##core#inline "C_eqp" p '()) v)
- (if (and (##core#inline "C_blockp" p) (##core#inline "C_pairp" p))
- (,set v i (##core#inline "C_slot" p 0))
- (##sys#error-not-a-proper-list lst) ) ) ) )))))
+(define-syntax list->NNNvector
+ (er-macro-transformer
+ (lambda (x r c)
+ (let* ((tag (##sys#strip-syntax (cadr x)))
+ (tagstr (symbol->string tag))
+ (name (string->symbol (string-append "list->" tagstr)))
+ (make (string->symbol (string-append "make-" tagstr)))
+ (set (string->symbol (string-append tagstr "-set!"))))
+ `(define ,name
+ (let ((,make ,make))
+ (lambda (lst)
+ (##sys#check-list lst ',tag)
+ (let* ((n (##core#inline "C_i_length" lst))
+ (v (,make n)) )
+ (do ((p lst (##core#inline "C_slot" p 1))
+ (i 0 (##core#inline "C_fixnum_plus" i 1)) )
+ ((##core#inline "C_eqp" p '()) v)
+ (if (and (##core#inline "C_blockp" p) (##core#inline "C_pairp" p))
+ (,set v i (##core#inline "C_slot" p 0))
+ (##sys#error-not-a-proper-list lst) ) ) ) )))))))
(list->NNNvector u8vector)
(list->NNNvector s8vector)
@@ -452,21 +454,23 @@ EOF
;;; Creating lists from a vector:
-(define-syntax (NNNvector->list x r c)
- (let* ((tag (##sys#strip-syntax (cadr x)))
- (alloc? (pair? (cddr x)))
- (name (string->symbol (string-append (symbol->string tag) "->list"))))
- `(define (,name v)
- (##sys#check-structure v ',tag ',name)
- (let ((len (##core#inline ,(conc "C_u_i_" tag "_length") v)))
- (let loop ((i 0))
- (if (fx>= i len)
- '()
- (cons
- ,(if alloc?
- `(##core#inline_allocate (,(conc "C_a_i_" tag "_ref") 4) v i)
- `(##core#inline ,(conc "C_u_i_" tag "_ref") v i))
- (loop (fx+ i 1)) ) ) ) ) ) ) )
+(define-syntax NNNvector->list
+ (er-macro-transformer
+ (lambda (x r c)
+ (let* ((tag (##sys#strip-syntax (cadr x)))
+ (alloc? (pair? (cddr x)))
+ (name (string->symbol (string-append (symbol->string tag) "->list"))))
+ `(define (,name v)
+ (##sys#check-structure v ',tag ',name)
+ (let ((len (##core#inline ,(conc "C_u_i_" tag "_length") v)))
+ (let loop ((i 0))
+ (if (fx>= i len)
+ '()
+ (cons
+ ,(if alloc?
+ `(##core#inline_allocate (,(conc "C_a_i_" tag "_ref") 4) v i)
+ `(##core#inline ,(conc "C_u_i_" tag "_ref") v i))
+ (loop (fx+ i 1)) ) ) ) ) ) ) )))
(NNNvector->list u8vector)
(NNNvector->list s8vector)
diff --git a/tests/meta-syntax-test.scm b/tests/meta-syntax-test.scm
index b9905abe..2b5e4666 100755
--- a/tests/meta-syntax-test.scm
+++ b/tests/meta-syntax-test.scm
@@ -6,14 +6,17 @@
(begin-for-syntax
(define (baz x)
(list (cadr x))))
- (define-syntax (bar x r c)
- `(,(r 'list) (baz (list 1 ,(cadr x)))))
+ (define-syntax bar
+ (er-macro-transformer
+ (lambda (x r c)
+ `(,(r 'list) (baz (list 1 ,(cadr x)))))))
(begin-for-syntax
(define-syntax call-it-123
(syntax-rules ()
((_ x)
'(x 'x 1 2 3)))))
(define-syntax listify
- (lambda (e r c)
- (call-it-123 list))))
+ (er-macro-transformer
+ (lambda (e r c)
+ (call-it-123 list)))))
diff --git a/tests/srfi-4-tests.scm b/tests/srfi-4-tests.scm
index 126fc294..435f879f 100644
--- a/tests/srfi-4-tests.scm
+++ b/tests/srfi-4-tests.scm
@@ -4,21 +4,23 @@
(use srfi-1 srfi-4)
-(define-syntax (test1 x r c)
- (let* ((t (strip-syntax (cadr x)))
- (name (symbol->string (strip-syntax t))))
- (define (conc op)
- (string->symbol (string-append name op)))
- `(let ((x (,(conc "vector") 100 101)))
- (print x)
- (assert (= 100 (,(conc "vector-ref") x 0)))
- (,(conc "vector-set!") x 1 99)
- (assert (= 99 (,(conc "vector-ref") x 1)))
- (assert (= 2 (,(conc "vector-length") x)))
- (assert
- (every =
- '(100 99)
- (,(conc "vector->list") x))))))
+(define-syntax test1
+ (er-macro-transformer
+ (lambda (x r c)
+ (let* ((t (strip-syntax (cadr x)))
+ (name (symbol->string (strip-syntax t))))
+ (define (conc op)
+ (string->symbol (string-append name op)))
+ `(let ((x (,(conc "vector") 100 101)))
+ (print x)
+ (assert (= 100 (,(conc "vector-ref") x 0)))
+ (,(conc "vector-set!") x 1 99)
+ (assert (= 99 (,(conc "vector-ref") x 1)))
+ (assert (= 2 (,(conc "vector-length") x)))
+ (assert
+ (every =
+ '(100 99)
+ (,(conc "vector->list") x))))))))
(test1 u8)
(test1 u16)
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index b20ca7b4..21f57e58 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -955,8 +955,10 @@
(import foonumbers)
-(define-syntax (foo x r c)
- `(print ,(+ (cadr x) 1)))
+(define-syntax foo
+ (er-macro-transformer
+ (lambda (x r c)
+ `(print ,(+ (cadr x) 1)))))
(foo 3)
Trap