Ticket #379: srfi-46.patch

synrules.scm

@@ -65 +65 @@
   (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 +85 @@
   (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*))
@@ -99 +103 @@
   (define %temp (r 'temp))
   (define %syntax-error '##sys#syntax-error-hook)
   (define %ellipsis (r ellipsis))
+  (define %drop-right (r 'drop-right))
+  (define %take-right (r 'take-right))
 
   (define (ellipsis? x)
     (c x %ellipsis))
 
   (define (make-transformer rules)
     `(,%lambda (,%input ,%rename ,%compare)
-               (,%let ((,%tail (,%cdr ,%input)))
+               (,%let ((,%tail (,%cdr ,%input))
+                       (,%drop-right
+                         (,%lambda (,%input ,%temp)
+                            (,%let ,%loop ((,%len (,%length ,%input))
+                                           (,%input ,%input))
+                               (,%cond
+                                ((,%> ,%len ,%temp)
+                                 (,%cons (,%car ,%input)
+                                         (,%loop (,%- ,%len 1) (,%cdr ,%input))))
+                                (,%else (,%quote ()))))))
+                       (,%take-right
+                         (,%lambda (,%input ,%temp)
+                            (,%let ,%loop ((,%len (,%length ,%input))
+                                           (,%input ,%input))
+                               (,%cond
+                                ((,%> ,%len ,%temp)
+                                 (,%loop (,%- ,%len 1) (,%cdr ,%input)))
+                                (,%else ,%input))))))
                       (,%cond ,@(map process-rule rules)
                               (,%else 
                                (##sys#syntax-rules-mismatch ,%input))))))
@@ -116 +139 @@
              (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!
+                              `(,%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)
+                               `(,%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 +265 @@
 
   ;; 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 +303 @@
            (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)

tests/syntax-tests.scm

@@ -144 +144 @@
       (bar foo))))
 )
 
-;;; alternative ellipsis test
+;;; alternative ellipsis test (SRFI-46)
 
 (define-syntax foo
   (syntax-rules 
@@ -166 +166 @@
 
 (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