Ticket #385: srfi-26-error.patch

chicken-syntax.scm

@@ -986 +986 @@
     (let ((%<> (r '<>))
           (%<...> (r '<...>))
           (%apply (r 'apply)))
+      (when (null? (cdr form))
+        (syntax-error 'cute "You need to supply at least a procedure" form))
       (let loop ([xs (cdr form)] [vars '()] [vals '()] [rest #f])
         (if (null? xs)
             (let ([rvars (reverse vars)]
@@ -999 +1001 @@
             (cond ((c %<> (car xs))
                    (let ([v (r (gensym))])
                      (loop (cdr xs) (cons v vars) (cons v vals) #f) ) )
-                  ((c %<...> (car xs)) (loop '() vars vals #t))
+                  ((c %<...> (car xs))
+                   (if (null? (cdr xs))
+                       (loop '() vars vals #t)
+                       (syntax-error 'cut
+                                     "Tail patterns after <...> are not supported"
+                                     form)))
                   (else (loop (cdr xs) vars (cons (car xs) vals) #f)) ) ) ) ) )))
 
 (##sys#extend-macro-environment
@@ -1010 +1017 @@
     (let ((%apply (r 'apply))
           (%<> (r '<>))
           (%<...> (r '<...>)))
+      (when (null? (cdr form))
+        (syntax-error 'cute "You need to supply at least a procedure" form))
       (let loop ([xs (cdr form)] [vars '()] [bs '()] [vals '()] [rest #f])
         (if (null? xs)
             (let ([rvars (reverse vars)]
@@ -1025 +1034 @@
             (cond ((c %<> (car xs))
                    (let ([v (r (gensym))])
                      (loop (cdr xs) (cons v vars) bs (cons v vals) #f) ) )
-                  ((c %<...> (car xs)) (loop '() vars bs vals #t))
+                  ((c %<...> (car xs))
+                   (if (null? (cdr xs))
+                       (loop '() vars bs vals #t)
+                       (syntax-error 'cute
+                                     "Tail patterns after <...> are not supported"
+                                     form)))
                   (else 
                    (let ([v (r (gensym))])
                      (loop (cdr xs) 

tests/syntax-tests.scm

@@ -22 +22 @@
 (t 3 3)
 
 (f abc)
-
+#|
 (f (t 3 4))
 
 ;; test syntax-rules
@@ -478 +478 @@
 
 (import (prefix rfoo f:))
 (f:rbar 1)
+|#
+;;; SRFI-26
+
+;; Cut
+(t '() ((cut list)))
+(t '() ((cut list <...>)))
+(t '(1) ((cut list 1)))
+(t '(1) ((cut list <>) 1))
+(t '(1) ((cut list <...>) 1))
+(t '(1 2) ((cut list 1 2)))
+(t '(1 2) ((cut list 1 <>) 2))
+(t '(1 2) ((cut list 1 <...>) 2))
+(t '(1 2 3 4) ((cut list 1 <...>) 2 3 4))
+(t '(1 2 3 4) ((cut list 1 <> 3 <>) 2 4))
+(t '(1 2 3 4 5 6) ((cut list 1 <> 3 <...>) 2 4 5 6))
+(t '(ok) (let* ((x 'wrong)
+                (y (cut list x)))
+           (set! x 'ok)
+           (y)))
+(t 2 (let ((a 0))
+       (map (cut + (begin (set! a (+ a 1)) a) <>)
+            '(1 2))
+       a))
+(f (eval '((cut + <...> 1) 1)))
+
+;; Cute
+(t '() ((cute list)))
+(t '() ((cute list <...>)))
+(t '(1) ((cute list 1)))
+(t '(1) ((cute list <>) 1))
+(t '(1) ((cute list <...>) 1))
+(t '(1 2) ((cute list 1 2)))
+(t '(1 2) ((cute list 1 <>) 2))
+(t '(1 2) ((cute list 1 <...>) 2))
+(t '(1 2 3 4) ((cute list 1 <...>) 2 3 4))
+(t '(1 2 3 4) ((cute list 1 <> 3 <>) 2 4))
+(t '(1 2 3 4 5 6) ((cute list 1 <> 3 <...>) 2 4 5 6))
+(t 1 (let ((a 0))
+       (map (cute + (begin (set! a (+ a 1)) a) <>)
+            '(1 2))
+       a))
+(f (eval '((cute + <...> 1) 1)))
+ No newline at end of file