adding (... ...) escapes and SRFI-46 ellipse specifiers to syntax-rules

TODO

@@ -39,9 +39,10 @@
    - State "DONE"       [2009-12-08 Tue 14:41]
 ** DONE macroexpand utility
    - State "DONE"       [2009-12-08 Tue 14:41]
-** TODO compiler macros
 ** TODO SRFI-46 basic syntax-rules extensions
-** TODO (... ...) support
+** DONE (... ...) support
+   - State "DONE"       [2009-12-26 Sat 02:06]
+** TODO compiler macros
 ** TODO syntax-rules common pattern reduction
 ** TODO syntax-rules loop optimization
 
@@ -61,6 +62,9 @@
    - State "DONE"       [2009-07-07 Tue 14:42]
 ** TODO unicode
 ** TODO threads
+** DONE dynamic-wind
+   - State "DONE"       [2009-12-26 Sat 01:51]
+   Adapted a version from Scheme48.
 ** DONE recursive disasm
    - State "DONE"       [2009-12-18 Fri 14:15]
 
@@ -69,13 +73,16 @@
    - State "DONE"       [2009-12-08 Tue 14:45]
 ** DONE opcode generation interface
    - State "DONE"       [2009-11-15 Sun 14:45]
-** TODO stub generator
+** DONE stub generator
+   - State "DONE"       [2009-12-26 Sat 01:50]
 *** DONE define-c-struct
     - State "DONE"       [2009-11-29 Sun 14:48]
 *** DONE define-c
     - State "DONE"       [2009-11-29 Sun 14:48]
-*** TODO array return types
+*** DONE array return types
-*** TODO pre-buffered string types (like getcwd)
+    - State "DONE"       [2009-12-26 Sat 01:49]
+*** DONE pre-buffered string types (like getcwd)
+    - State "DONE"       [2009-12-26 Sat 01:49]
 
 * module system
 ** DONE scheme48-like config language
@@ -85,7 +92,8 @@
 ** DONE only/except/rename/prefix modifiers
    - State "DONE"       [2009-12-16 Wed 18:57]
 ** TODO scheme-complete.el support
-** TODO access individual modules from repl
+** DONE access individual modules from repl
+   - State "DONE"       [2009-12-26 Sat 01:49]
 
 * core modules
 ** DONE SRFI-0 cond-expand
@@ -100,6 +108,14 @@
    - State "DONE"       [2009-12-08 Tue 14:54]
 ** TODO network interface
 ** TODO posix interface
+   Splitting this into several parts.
+*** DONE filesystem interface
+    - State "DONE"       [2009-12-26 Sat 01:50]
+*** DONE process interface
+    - State "DONE"       [2009-12-26 Sat 01:50]
+*** DONE time interface
+    - State "DONE"       [2009-12-26 Sat 01:50]
+*** TODO host system interface
 ** DONE pathname library
    - State "DONE"       [2009-12-16 Wed 18:58]
 ** DONE uri library

lib/init.scm

@@ -615,8 +615,7 @@
 (define-syntax syntax-rules
   (er-macro-transformer
    (lambda (expr rename compare)
-     (let ((lits (cadr expr))
+     (let ((ellipse-specified? (identifier? (cadr expr)))
-           (forms (cddr expr))
            (count 0)
            (_er-macro-transformer (rename 'er-macro-transformer))
            (_lambda (rename 'lambda))      (_let (rename 'let))
@@ -634,6 +633,9 @@
            (_error (rename 'error))
            (_vector->list (rename 'vector->list))
            (_list->vector (rename 'list->vector)))
+       (define ellipse (rename (if ellipse-specified? (cadr expr) '...)))
+       (define lits (if ellipse-specified? (caddr expr) (cadr expr)))
+       (define forms (if ellipse-specified? (cdddr expr) (cddr expr)))
        (define (next-v)
          (set! count (+ count 1))
          (rename (string->symbol (string-append "v." (number->string count)))))
@@ -708,8 +710,9 @@
                       (lp (vector->list p) (list _vector->list v) dim vars k)))
                ((null? p) (list _and (list _null? v) (k vars)))
                (else (list _and (list _equal? v p) (k vars))))))))
+       (define (ellipse-escape? x) (and (pair? x) (compare ellipse (car x))))
        (define (ellipse? x)
-         (and (pair? x) (pair? (cdr x)) (compare (rename '...) (cadr x))))
+         (and (pair? x) (pair? (cdr x)) (compare ellipse (cadr x))))
        (define (ellipse-depth x)
          (if (ellipse? x)
              (+ 1 (ellipse-depth (cdr x)))
@@ -753,28 +756,33 @@
               (else
                (list _rename (list _quote t)))))
             ((pair? t)
-             (if (ellipse? t)
+             (cond
-                 (let* ((depth (ellipse-depth t))
+              ((ellipse-escape? t)
-                        (ell-dim (+ dim depth))
+               (if (pair? (cdr t))
-                        (ell-vars (free-vars (car t) vars ell-dim)))
+                   (if (pair? (cddr t)) (cddr t) (cadr t))
-                   (if (null? ell-vars)
+                   (cdr t)))
-                       (error "too many ...'s")
+              ((ellipse? t)
-                       (let* ((once (lp (car t) ell-dim))
+               (let* ((depth (ellipse-depth t))
-                              (nest (if (and (null? (cdr ell-vars))
+                      (ell-dim (+ dim depth))
-                                             (identifier? once)
+                      (ell-vars (free-vars (car t) vars ell-dim)))
-                                             (eq? once (car vars)))
+                 (if (null? ell-vars)
-                                        once ;; shortcut
+                     (error "too many ...'s")
-                                        (cons _map
+                     (let* ((once (lp (car t) ell-dim))
-                                              (cons (list _lambda ell-vars once)
+                            (nest (if (and (null? (cdr ell-vars))
-                                                    ell-vars))))
+                                           (identifier? once)
-                              (many (do ((d depth (- d 1))
+                                           (eq? once (car vars)))
-                                         (many nest
+                                      once ;; shortcut
-                                               (list _apply _append many)))
+                                      (cons _map
-                                        ((= d 1) many))))
+                                            (cons (list _lambda ell-vars once)
-                         (if (null? (ellipse-tail t))
+                                                  ell-vars))))
-                             many ;; shortcut
+                            (many (do ((d depth (- d 1))
-                             (list _append many (lp (ellipse-tail t) dim))))))
+                                       (many nest
-                 (list _cons (lp (car t) dim) (lp (cdr t) dim))))
+                                             (list _apply _append many)))
+                                      ((= d 1) many))))
+                       (if (null? (ellipse-tail t))
+                           many ;; shortcut
+                           (list _append many (lp (ellipse-tail t) dim)))))))
+              (else (list _cons (lp (car t) dim) (lp (cdr t) dim)))))
             ((vector? t) (list _list->vector (lp (vector->list t) dim)))
             ((null? t) (list _quote '()))
             (else t))))

tests/r5rs-tests.scm

@@ -459,6 +459,12 @@
             (c 'talk2)
             (reverse path)))))
 
+(test 2 (let-syntax
+            ((foo (syntax-rules ::: ()
+                    ((foo ... args :::)
+                     (args ::: ...)))))
+          (foo 3 - 5)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (test-report)