Ticket #385: srfi-26-extension.patch

chicken-syntax.scm

@@ -985 +985 @@
   (lambda (form r c)
     (let ((%<> (r '<>))
           (%<...> (r '<...>))
-          (%apply (r 'apply)))
-      (let loop ([xs (cdr form)] [vars '()] [vals '()] [rest #f])
-        (if (null? xs)
-            (let ([rvars (reverse vars)]
-                  [rvals (reverse vals)] )
-              (if rest
-                  (let ([rv (r (gensym))])
-                    `(##core#lambda
-                      (,@rvars . ,rv)
-                      (,%apply ,(car rvals) ,@(cdr rvals) ,rv) ) )
-                  `(##core#lambda ,rvars ((##core#begin ,(car rvals)) ,@(cdr rvals)) ) ) )
-            (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))
-                  (else (loop (cdr xs) vars (cons (car xs) vals) #f)) ) ) ) ) )))
+          (%apply (r 'apply))
+          (%append (r 'append))
+          (%list (r 'list))
+          (%reverse (r 'reverse)))
+      (when (null? (cdr form))
+        (syntax-error 'cut "You need to supply at least a procedure" form))
+      (let loop ([xs (cdr form)] [vars '()] [vals '()] [vars2 '()] [vals2 '()]
+                 [rest #f])
+        (if (null? xs)
+            (let ([rvars (reverse vars)]
+                  [rvals (reverse vals)]
+                  [rvals2 (reverse vals2)])
+              (if rest
+                  (let ([rv (r (gensym))])
+                    `(##core#lambda (,@rvars . ,rv)
+                      (,%apply
+                       (##core#lambda (,@vars2 . ,rv)
+                         (,%apply ,(car rvals) ,@(cdr rvals)
+                                  (,%append (,%reverse ,rv) (,%list ,@rvals2))))
+                       (,%reverse ,rv)) ) )
+                  `(##core#lambda ,rvars ((##core#begin ,(car rvals)) ,@(cdr rvals)) ) ) )
+            (cond ((c %<> (car xs))
+                   (let ([v (r (gensym))])
+                     (if rest
+                         (loop (cdr xs) vars vals
+                               (cons v vars2) (cons v vals2) #t)
+                         (loop (cdr xs) (cons v vars) (cons v vals) '() '() #f))))
+                  ((c %<...> (car xs))
+                   (if rest
+                       (syntax-error 'cut "Only one <...> is allowed" form)
+                       (loop (cdr xs) vars vals '() '() #t)))
+                  (else
+                   (if rest
+                       (loop (cdr xs) vars vals vars2 (cons (car xs) vals2) #t)
+                       (loop (cdr xs) vars (cons (car xs) vals) '() '() #f))))))))))
 
 (##sys#extend-macro-environment
  'cute 
@@ -1009 +1028 @@
   (lambda (form r c)
     (let ((%apply (r 'apply))
           (%<> (r '<>))
-          (%<...> (r '<...>)))
-      (let loop ([xs (cdr form)] [vars '()] [bs '()] [vals '()] [rest #f])
+          (%<...> (r '<...>))
+          (%append (r 'append))
+          (%list (r 'list))
+          (%reverse (r 'reverse)))
+      (when (null? (cdr form))
+        (syntax-error 'cute "You need to supply at least a procedure" form))
+      (let loop ([xs (cdr form)] [bs '()] [vars '()] [vals '()]
+                 [vars2 '()] [vals2 '()] [rest #f])
         (if (null? xs)
             (let ([rvars (reverse vars)]
-                  [rvals (reverse vals)] )
+                  [rvals (reverse vals)]
+                  [rvals2 (reverse vals2)])
               (if rest
                   (let ([rv (r (gensym))])
                     `(##core#let 
                       ,bs
-                      (##core#lambda (,@rvars . ,rv)
-                                (,%apply ,(car rvals) ,@(cdr rvals) ,rv) ) ) )
+                      (##core#lambda (,@rvars . ,rv)
+                        (,%apply
+                         (##core#lambda (,@vars2 . ,rv)
+                           (,%apply ,(car rvals) ,@(cdr rvals)
+                                    (,%append (,%reverse ,rv) (,%list ,@rvals2))))
+                         (,%reverse ,rv)) ) ) )
                   `(##core#let ,bs
                           (##core#lambda ,rvars (,(car rvals) ,@(cdr rvals)) ) ) ) )
             (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))
+                     (if rest
+                         (loop (cdr xs) bs vars vals
+                               (cons v vars2) (cons v vals2) #t)
+                         (loop (cdr xs) bs (cons v vars) (cons v vals)
+                               '() '() #f))))
+                  ((c %<...> (car xs))
+                   (if rest
+                       (syntax-error 'cut "Only one <...> is allowed" form)
+                       (loop (cdr xs) bs vars vals vars2 vals2 #t)))
                   (else 
                    (let ([v (r (gensym))])
-                     (loop (cdr xs) 
-                           vars
-                           (cons (list v (car xs)) bs)
-                           (cons v vals) #f) ) ))))))))
+                     (if rest
+                         (loop (cdr xs) (cons (list v (car xs)) bs)
+                               vars vals vars2 (cons v vals2) #t)
+                         (loop (cdr xs) (cons (list v (car xs)) bs)
+                               vars (cons v vals) vars2 vals2 #f)) ) ))))))))
 
 
 ;;; SRFI-31

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))
+;; Extensions
+(t '(1) ((cut list <...> 1)))
+(t '(1) ((cut list <...> <>) 1))
+(t '(1 2) ((cut list <...> 2) 1))
+(t '(1 2 3 4) ((cut list <...> 4) 1 2 3))
+(t '(1 2 3 4) ((cut list <...> 1 <> 3 <>) 2 4))
+(t '(1 2 3 4 5 6) ((cut list <...> 3 <> 5 <>) 1 2 4 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))
+
+
+;; 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))
+;; Extensions
+(t '(1) ((cute list <...> 1)))
+(t '(1) ((cute list <...> <>) 1))
+(t '(1 2) ((cute list <...> 2) 1))
+(t '(1 2) ((cute list 1 <...>) 2))
+(t '(1 2 3 4) ((cute list <...> 4) 1 2 3))
+(t '(1 2 3 4) ((cute list <...> 1 <> 3 <>) 2 4))
+(t '(1 2 3 4 5 6) ((cute list <...> 3 <> 5 <>) 1 2 4 6))
+(t 1 (let ((a 0))
+       (map (cute + <...> (begin (set! a (+ a 1)) a) <>)
+            '(1 2))
+       a))
+ No newline at end of file