add vector patterns

2 files changed, 47 insertions, 2 deletions

diff --git a/multisyntax/pattern/producer.scm b/multisyntax/pattern/producer.scm
index 93d6221..ca98d62 100644
--- a/multisyntax/pattern/producer.scm
+++ b/multisyntax/pattern/producer.scm
@@ -194,7 +194,7 @@
       ((pair? pattern) (compile-pair (unwrap-syntax (car pattern))
                                      (unwrap-syntax (cdr pattern))))
       ;; TODO: Vectors
-      #;((vector? pattern) (compile-vector pattern))
+      ((vector? pattern) (compile-vector pattern))
       ((actual-ellipsis? pattern)
        (error "ellipsis in location where it is not allowed" pattern))
       ((literal? pattern)
@@ -214,6 +214,17 @@
        (values (lambda (bindings) pattern) (empty-map)))
       (else (error "not syntax" pattern)))))
 
+;;; ;;;;;;;;;;;;;;;
+;;; Vectors
+
+(define (compile-vector pattern)
+  (let*-values (((as-list) (vector->list pattern))
+                ((produce-as-list open-identifiers)
+                 (compile-regular-pair (unwrap-syntax (car as-list))
+                                       (unwrap-syntax (cdr as-list)))))
+    (values (lambda (bindings) (list->vector (produce-as-list bindings)))
+            open-identifiers)))
+
 ;;; ;;;;;;;;;
 ;;; Lists
 ;;; ;;;;;;;;;
diff --git a/test/pattern/producer.scm b/test/pattern/producer.scm
index e7b9f20..7b61fd8 100644
--- a/test/pattern/producer.scm
+++ b/test/pattern/producer.scm
@@ -147,9 +147,43 @@
                   (producer (idmap (empty-wrap 'x)
                                    '((4 3) (2 1))))))))
 
+(define (test-vector)
+  (let ((producer
+         (compile-producer '()
+                           (vector 1 2 3 4)
+                           (idmap))))
+    (test-equal "#(1 2 3 4)"
+                #(1 2 3 4)
+                (producer (idmap))))
+  (let ((producer
+         (compile-producer '()
+                           (vector (empty-wrap 'x) (empty-wrap 'y))
+                           (idmap (empty-wrap 'x) 0
+                                  (empty-wrap 'y) 0))))
+    (test-equal "#(x y)"
+                #(10 20)
+                (producer (idmap (empty-wrap 'x) 10
+                                 (empty-wrap 'y) 20))))
+  (let ((producer
+         (compile-producer '()
+                           (vector (empty-wrap 'x) (empty-wrap '...))
+                           (idmap (empty-wrap 'x) 1))))
+    (test-equal "#(x ...)"
+                #(10 20 30)
+                (producer (idmap (empty-wrap 'x) '(30 20 10)))))
+  (let ((producer
+         (compile-producer '()
+                           (vector (empty-wrap 'x) (empty-wrap '...) 100)
+                           (idmap (empty-wrap 'x) 1))))
+    (test-equal "#(x ... 100)"
+                #(80 90 100)
+                (producer (idmap (empty-wrap 'x) '(90 80))))))
+
 (define (test-producers)
   (test-group "producers"
     (test-group "self-syntax"
       (test-self-syntax))
     (test-group "list ellipses"
-      (test-list-ellipses))))
\ No newline at end of file
+      (test-list-ellipses))
+    (test-group "vector patterns"
+      (test-vector))))
\ No newline at end of file