~ chicken-core (chicken-5) 40a2249b0b948682b90533eb66bea0519f251a5f
commit 40a2249b0b948682b90533eb66bea0519f251a5f
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Feb 5 16:27:16 2011 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sat Feb 5 16:27:16 2011 +0100
added patch by sjamaan for tail-pattern support in syntax-rules
diff --git a/expand.scm b/expand.scm
index 5d4f3931..f8f44318 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1995,3 +1995,27 @@
(set-module-sexports! mod sexports))))))
(define ##sys#module-table '())
+
+
+;; Used by the syntax-rules implementation (and possibly handy elsewhere)
+;; (kindly contributed by Peter Bex)
+
+(define (##sys#drop-right input temp)
+ ;;XXX use unsafe accessors
+ (let loop ((len (length input))
+ (input input))
+ (cond
+ ((> len temp)
+ (cons (car input)
+ (loop (- len 1) (cdr input))))
+ (else '()))))
+
+(define (##sys#take-right input temp)
+ ;;XXX use unsafe accessors
+ (let loop ((len (length input))
+ (input input))
+ (cond
+ ((> len temp)
+ (loop (- len 1) (cdr input)))
+ (else input))))
+
diff --git a/manual/Macros b/manual/Macros
index 858e1dbe..d4ee169c 100644
--- a/manual/Macros
+++ b/manual/Macros
@@ -42,9 +42,15 @@ is expanded into
(letrec-syntax ((foo ...) (bar ...))
...) )
-{{syntax-rules}} partially supports [[http://srfi.schemers.org/srfi-46/|SRFI-46]]
+{{syntax-rules}} supports [[http://srfi.schemers.org/srfi-46/|SRFI-46]]
in allowing the ellipsis identifier to be user-defined by passing it as the first
-argument to the {{syntax-rules}} form.
+argument to the {{syntax-rules}} form. Also, "tail" patterns of the form
+
+ (syntax-rules ()
+ ((_ (a b ... c)
+ ...
+
+are supported.
The effect of destructively modifying the s-expression passed to a
transformer procedure is undefined.
diff --git a/synrules.scm b/synrules.scm
index 0e5f66fe..32f09fbb 100644
--- a/synrules.scm
+++ b/synrules.scm
@@ -65,14 +65,17 @@
(define %and (r 'and))
(define %car '##sys#car)
(define %cdr '##sys#cdr)
+ (define %length (r 'length))
(define %vector? '##sys#vector?)
(define %vector-length '##sys#vector-length)
(define %vector-ref '##sys#vector-ref)
(define %vector->list '##sys#vector->list)
(define %list->vector '##sys#list->vector)
(define %>= '##sys#>=)
+ (define %> (r '>))
(define %= '##sys#=)
(define %+ '##sys#+)
+ (define %- '-)
(define %i (r 'i))
(define %compare (r 'compare))
(define %cond (r 'cond))
@@ -82,6 +85,7 @@
(define %equal? '##sys#equal?)
(define %input (r 'input))
(define %l (r 'l))
+ (define %len (r 'len))
(define %lambda (r 'lambda))
(define %let (r 'let))
(define %let* (r 'let*))
@@ -116,107 +120,83 @@
(null? (cddr rule)))
(let ((pattern (cdar rule))
(template (cadr rule)))
- `((,%and ,@(process-match %tail pattern))
+ `((,%and ,@(process-match %tail pattern #f))
(,%let* ,(process-pattern pattern
%tail
- (lambda (x) x))
+ (lambda (x) x) #f)
,(process-template template
0
- (meta-variables pattern 0 '())))))
+ (meta-variables pattern 0 '() #f)))))
(##sys#syntax-error-hook "ill-formed syntax rule" rule)))
;; Generate code to test whether input expression matches pattern
- (define (process-match input pattern)
+ (define (process-match input pattern seen-segment?)
(cond ((symbol? pattern)
(if (memq pattern subkeywords)
`((,%compare ,input (,%rename (##core#syntax ,pattern))))
`()))
- ((segment-pattern? pattern)
- (process-segment-match input (car pattern)))
+ ((segment-pattern? pattern seen-segment?)
+ (process-segment-match input pattern))
((pair? pattern)
`((,%let ((,%temp ,input))
- (,%and (,%pair? ,%temp)
- ,@(process-match `(,%car ,%temp) (car pattern))
- ,@(process-match `(,%cdr ,%temp) (cdr pattern))))))
+ (,%and (,%pair? ,%temp)
+ ,@(process-match `(,%car ,%temp) (car pattern) #f)
+ ,@(process-match `(,%cdr ,%temp) (cdr pattern) #f)))))
((vector? pattern)
- (process-vector-match input pattern))
+ `((,%let ((,%temp ,input))
+ (,%and (,%vector? ,%temp)
+ ,@(process-match `(,%vector->list ,%temp)
+ (vector->list pattern) #f)))))
((or (null? pattern) (boolean? pattern) (char? pattern))
`((,%eq? ,input ',pattern)))
(else
`((,%equal? ,input ',pattern)))))
(define (process-segment-match input pattern)
- (let ((conjuncts (process-match `(,%car ,%l) pattern)))
- (if (null? conjuncts)
- `((,%list? ,input)) ;+++
- `((,%let ,%loop ((,%l ,input))
- (,%or (,%null? ,%l)
- (,%and (,%pair? ,%l)
- ,@conjuncts
- (,%loop (,%cdr ,%l)))))))))
-
- (define (process-vector-match input pattern)
- (let* ((len (vector-length pattern))
- (segment? (and (>= len 2)
- (ellipsis? (vector-ref pattern (- len 1))))))
- `((,%let ((,%temp ,input))
- (,%and (,%vector? ,%temp)
- ,(if segment?
- `(,%>= (,%vector-length ,%temp) ,(- len 2))
- `(,%= (,%vector-length ,%temp) ,len))
- ,@(let lp ((i 0))
- (cond
- ((>= i len)
- '())
- ((and (= i (- len 2)) segment?)
- `((,%let ,%loop ((,%i ,i))
- (,%or (,%>= ,%i ,len)
- (,%and ,@(process-match
- `(,%vector-ref ,%temp ,%i)
- (vector-ref pattern (- len 2)))
- (,%loop (,%+ ,%i 1)))))))
- (else
- (append (process-match `(,%vector-ref ,%temp ,i)
- (vector-ref pattern i))
- (lp (+ i 1)))))))))))
-
+ (let ((conjuncts (process-match `(,%car ,%l) (car pattern) #f)))
+ `((,%and (,%list? ,input) ; Can't ask for its length if not a proper list
+ (,%let ((,%len (,%length ,input)))
+ (,%and (,%>= ,%len ,(length (cddr pattern)))
+ (,%let ,%loop ((,%l ,input)
+ (,%len ,%len))
+ (,%cond
+ ((,%= ,%len ,(length (cddr pattern)))
+ ,@(process-match %l (cddr pattern) #t))
+ (,%else
+ (,%and ,@conjuncts
+ (,%loop (,%cdr ,%l) (,%- ,%len 1))))))))))))
+
;; Generate code to take apart the input expression
;; This is pretty bad, but it seems to work (can't say why).
- (define (process-pattern pattern path mapit)
+ (define (process-pattern pattern path mapit seen-segment?)
(cond ((symbol? pattern)
(if (memq pattern subkeywords)
'()
(list (list pattern (mapit path)))))
- ((segment-pattern? pattern)
- (process-pattern (car pattern)
- %temp
- (lambda (x) ;temp is free in x
- (mapit (if (eq? %temp x)
- path ;+++
- `(,%map1 (,%lambda (,%temp) ,x)
- ,path))))))
+ ((segment-pattern? pattern seen-segment?)
+ (let* ((tail-length (length (cddr pattern)))
+ (%match (if (zero? tail-length) ; Simple segment?
+ path ; No list traversing overhead at runtime!
+ `(##sys#drop-right ,path ,tail-length))))
+ (append
+ (process-pattern (car pattern)
+ %temp
+ (lambda (x) ;temp is free in x
+ (mapit
+ (if (eq? %temp x)
+ %match ; Optimization: no map+lambda
+ `(,%map1 (,%lambda (,%temp) ,x) ,%match))))
+ #f)
+ (process-pattern (cddr pattern)
+ `(##sys#take-right ,path ,tail-length) mapit #t))))
((pair? pattern)
- (append (process-pattern (car pattern) `(,%car ,path) mapit)
- (process-pattern (cdr pattern) `(,%cdr ,path) mapit)))
+ (append (process-pattern (car pattern) `(,%car ,path) mapit #f)
+ (process-pattern (cdr pattern) `(,%cdr ,path) mapit #f)))
((vector? pattern)
- (let* ((len (vector-length pattern))
- (segment? (and (>= len 2)
- (ellipsis? (vector-ref pattern (- len 1))))))
- (if segment?
- (process-pattern (vector->list pattern)
- `(,%vector->list ,path)
- mapit)
- (let lp ((i 0))
- (cond
- ((>= i len)
- '())
- (else
- (append (process-pattern (vector-ref pattern i)
- `(,%vector-ref ,path ,i)
- mapit)
- (lp (+ i 1)))))))))
+ (process-pattern (vector->list pattern)
+ `(,%vector->list ,path) mapit #f))
(else '())))
;; Generate code to compose the output expression according to template
@@ -266,18 +246,19 @@
;; Return an association list of (var . dim)
- (define (meta-variables pattern dim vars)
+ (define (meta-variables pattern dim vars seen-segment?)
(cond ((symbol? pattern)
(if (memq pattern subkeywords)
vars
(cons (cons pattern dim) vars)))
- ((segment-pattern? pattern)
- (meta-variables (car pattern) (+ dim 1) vars))
+ ((segment-pattern? pattern seen-segment?)
+ (meta-variables (car pattern) (+ dim 1)
+ (meta-variables (cddr pattern) dim vars #t) #f))
((pair? pattern)
(meta-variables (car pattern) dim
- (meta-variables (cdr pattern) dim vars)))
+ (meta-variables (cdr pattern) dim vars #f) #f))
((vector? pattern)
- (meta-variables (vector->list pattern) dim vars))
+ (meta-variables (vector->list pattern) dim vars #f))
(else vars)))
;; Return a list of meta-variables of given higher dim
@@ -303,10 +284,14 @@
(free-meta-variables (vector->list template) dim env free))
(else free)))
- (define (segment-pattern? pattern)
- (and (segment-template? pattern)
- (or (null? (cddr pattern))
- (##sys#syntax-error-hook "segment matching not implemented" pattern))))
+ (define (segment-pattern? p seen-segment?)
+ (and (segment-template? p)
+ (cond
+ (seen-segment?
+ (##sys#syntax-error-hook "Only one segment per level is allowed" p))
+ ((not (list? p)) ; Improper list
+ (##sys#syntax-error-hook "Cannot combine dotted tail and ellipsis" p))
+ (else #t))))
(define (segment-template? pattern)
(and (pair? pattern)
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index 9200aafb..45a4d01a 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -196,7 +196,7 @@
(bar foo))))
)
-;;; alternative ellipsis test
+;;; alternative ellipsis test (SRFI-46)
(define-syntax foo
(syntax-rules
@@ -218,6 +218,56 @@
(t 3 (inc 2))
+;;; Rest patterns after ellipsis (SRFI-46)
+
+(define-syntax foo
+ (syntax-rules ()
+ ((_ (a ... b) ... (c d))
+ (list (list (list a ...) ... b ...) c d))
+ ((_ #(a ... b) ... #(c d) #(e f))
+ (list (list (vector a ...) ... b ...) c d e f))
+ ((_ #(a ... b) ... #(c d))
+ (list (list (vector a ...) ... b ...) c d))))
+
+(t '(() 1 2)
+ (foo (1 2)))
+
+(t '(((1) 2) 3 4)
+ (foo (1 2) (3 4)))
+
+(t '(((1 2) (4) 3 5) 6 7)
+ (foo (1 2 3) (4 5) (6 7)))
+
+(t '(() 1 2)
+ (foo #(1 2)))
+
+(t '((#() 1) 2 3)
+ (foo #(1) #(2 3)))
+
+(t '((#(1 2) 3) 4 5)
+ (foo #(1 2 3) #(4 5)))
+
+(t '((#(1 2) 3) 4 5 6 7)
+ (foo #(1 2 3) #(4 5) #(6 7)))
+
+(t '(() 1 2 3 4)
+ (foo #(1 2) #(3 4)))
+
+(t '((#(1) 2) 3 4 5 6)
+ (foo #(1 2) #(3 4) #(5 6)))
+
+(t '((#(1 2) #(4) 3 5) 6 7 8 9)
+ (foo #(1 2 3) #(4 5) #(6 7) #(8 9)))
+
+;;; Bug discovered during implementation of SRFI-46 rest patterns:
+
+(define-syntax foo
+ (syntax-rules ()
+ ((_ #((a) ...)) (list a ...))))
+
+(t '(1)
+ (foo #((1))))
+
;;;
(define-syntax usetmp
Trap