adding srfi-46 support

TODO

@@ -30,7 +30,7 @@
 ** TODO unsafe operations
    Possibly, don't want to make things too complicated or unstable.
 ** TODO plugin infrastructure
-** TODO type inference with warning
+** TODO type inference with warnings
 
 * macros
 ** DONE hygiene
@@ -39,7 +39,8 @@
    - State "DONE"       [2009-12-08 Tue 14:41]
 ** DONE macroexpand utility
    - State "DONE"       [2009-12-08 Tue 14:41]
-** TODO SRFI-46 basic syntax-rules extensions
+** DONE SRFI-46 basic syntax-rules extensions
+   - State "DONE"       [2009-12-26 Sat 07:59]
 ** DONE (... ...) support
    - State "DONE"       [2009-12-26 Sat 02:06]
 ** TODO compiler macros

lib/config.scm

@@ -164,5 +164,8 @@
   (list (cons '(scheme) (make-module #f (interaction-environment) '()))
         (cons '(srfi 0) (make-module (list 'cond-expand)
                                      (interaction-environment)
-                                     (list (list 'export 'cond-expand))))))
+                                     (list (list 'export 'cond-expand))))
+        (cons '(srfi 46) (make-module (list 'syntax-rules)
+                                      (interaction-environment)
+                                      (list (list 'export 'syntax-rules))))))
 

lib/init.scm

@@ -630,7 +630,9 @@
            (_append (rename 'append))      (_map (rename 'map))
            (_vector? (rename 'vector?))    (_list? (rename 'list?))
            (_lp (rename 'lp))              (_reverse (rename 'reverse))
-           (_error (rename 'error))
+           (_len (rename'len))             (_length (rename 'length))
+           (_- (rename '-))   (_>= (rename '>=))   (_error (rename 'error))
+           (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i))
            (_vector->list (rename 'vector->list))
            (_list->vector (rename 'list->vector)))
        (define ellipse (rename (if ellipse-specified? (cadr expr) '...)))
@@ -658,7 +660,28 @@
                ((ellipse? p)
                 (cond
                  ((not (null? (cddr p)))
-                  (error "non-trailing ellipse"))
+                  (cond
+                   ((not (list? (cddr p)))
+                    (error "dotted ellipse" p))
+                   ((any (lambda (x) (and (identifier? x) (compare x ellipse)))
+                         (cddr p))
+                    (error "multiple ellipses" p))
+                   (else
+                    (let ((len (length (cdr (cdr p)))))
+                      `(,_let ((,_len (,_length ,v)))
+                         (,_and (,_>= ,_len ,len)
+                                (,_let ,_lp ((,_ls ,v)
+                                             (,_i (,_- ,_len ,len))
+                                             (,_res (,_quote ())))
+                                  (,_if (,_>= 0 ,_i)
+                                      ,(lp `(,@(cdr (cdr p)) ,(car p) ,(car (cdr p)))
+                                           `(,_append ,_ls (,_reverse ,_res))
+                                           dim
+                                           vars
+                                           k)
+                                      (,_lp (,_cdr ,_ls)
+                                            (,_- ,_i 1)
+                                            (,_cons (,_car ,_ls) ,_res))))))))))
                  ((identifier? (car p))
                   (list _and (list _list? v)
                         (list _let (list (list (car p) v))

tests/r5rs-tests.scm

@@ -465,6 +465,13 @@
                      (args ::: ...)))))
           (foo 3 - 5)))
 
+(test '(5 4 1 2 3)
+    (let-syntax
+        ((foo (syntax-rules ()
+                ((foo args ... penultimate ultimate)
+                 (list ultimate penultimate args ...)))))
+      (foo 1 2 3 4 5)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (test-report)