Andrew Wright の match を移植する その2 - Scheme VMを書く

昨日の続き。

• (cond (3)) => 3 は Scheme の仕様上正しいものだった。ごめんなさい。
• quasiquote の展開に仕様の違いが見られると思ったが勘違いで、僕のコンパイラが特定の場合に quasiquote の展開し忘れたいただけだった。

というわけでほぼ完全に動くようになりました。 match-lambda とか match-let1 （Gauche 由来のもの）が動くようになって幸せです。
このライブラリのコンパイルに時間がかかるようになったのでいずれはプリコンパイルしよう。
コンパイラをプリコンパイルしてCの配列にして内蔵することはやっていたのだけど、ライブラリをプリコンパイルして内蔵する発想は無かった。Gauche.Nightの2次会で shiroさんに教えてもらい気づかされた＞＜。

以下 本家との diff です。

--- match-slib.scm.orig	1995-07-18 00:51:14.000000000 +0900
+++ match-slib.scm	2008-03-10 13:11:18.000000000 +0900
@@ -1,3 +1,18 @@
+;;
+;; match - Andrew Wright's pattern matching macro.
+;;
+;;   Ported to Mona Scheme by higepon@users.sourceforge.jp.
+
+(define-macro (gentemp)
+  `(gensym))
+
+(define-macro (defmacro . args)
+  `(define-macro (,(first args) . ,(second args))
+     ,@(cddr args)))
+
+(define-macro (match-let1 pat exp . body) ;; Extension from Gauche by shiro kawai.
+  `(match ,exp (,pat ,@body)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Pattern Matching Syntactic Extensions for Scheme
 ;;
@@ -142,18 +157,17 @@
 ;; End of user visible/modifiable stuff.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(require 'pretty-print)
 (define match:error
   (lambda (val . args)
     (for-each pretty-print args)
-    (slib:error "no matching clause for " val)))
+    (error "no matching clause for " val)))
 (define match:andmap
   (lambda (f l)
     (if (null? l)
         (and)
         (and (f (car l)) (match:andmap f (cdr l))))))
 (define match:syntax-err
-  (lambda (obj msg) (slib:error msg obj)))
+  (lambda (obj msg) (error msg obj)))
 (define match:disjoint-structure-tags '())
 (define match:make-structure-tag
   (lambda (name)
@@ -2446,44 +2460,53 @@
                           (g242))))
                 (g242)))
         (g242))))
+
+(define-macro (field? id)
+  `(if (symbol? ,id)
+      ((lambda () #t))
+      (if (and (pair? ,id)
+               (equal? (car ,id) '!)
+               (pair? (cdr ,id))
+               (symbol? (cadr ,id))
+               (null? (cddr ,id)))
+          ((lambda () #t))
+          ((lambda () #f)))))
+
+(define-macro (field-name x)
+  `(if (symbol? ,x) ,x (cadr ,x)))
+
+
+(define-macro (has-mutator? x)
+  `(not (symbol? ,x)))
+
+(define-macro (filter-map-with-index f l)
+  `(letrec ((mapi (lambda (l i)
+                   (cond
+                    ((null? l) '())
+                    ((,f (car l) i) =>
+                     (lambda (x)
+                       (cons x
+                             (mapi (cdr l)
+                                   (+ 1
+                                      i)))))
+                    (else (mapi (cdr l)
+                                (+ 1 i)))))))
+    (mapi ,l 1)))
+
+(define-macro (symbol-append . l)
+  `(string->symbol
+    (apply
+     string-append
+     (map (lambda (x)
+            (cond
+             ((symbol? x) (symbol->string x))
+             ((number? x) (number->string x))
+             (else x)))
+          ,l))))
+
 (defmacro
   define-const-structure
   args
-  (let ((field? (lambda (id)
-                  (if (symbol? id)
-                      ((lambda () #t))
-                      (if (and (pair? id)
-                               (equal? (car id) '!)
-                               (pair? (cdr id))
-                               (symbol? (cadr id))
-                               (null? (cddr id)))
-                          ((lambda () #t))
-                          ((lambda () #f))))))
-        (field-name (lambda (x) (if (symbol? x) x (cadr x))))
-        (has-mutator? (lambda (x) (not (symbol? x))))
-        (filter-map-with-index (lambda (f l)
-                                 (letrec ((mapi (lambda (l i)
-                                                  (cond
-                                                    ((null? l) '())
-                                                    ((f (car l) i) =>
-                                                     (lambda (x)
-                                                       (cons x
-                                                             (mapi (cdr l)
-                                                                   (+ 1
-                                                                      i)))))
-                                                    (else (mapi (cdr l)
-                                                                (+ 1 i)))))))
-                                   (mapi l 1))))
-        (symbol-append (lambda l
-                         (string->symbol
-                           (apply
-                             string-append
-                             (map (lambda (x)
-                                    (cond
-                                      ((symbol? x) (symbol->string x))
-                                      ((number? x) (number->string x))
-                                      (else x)))
-                                  l))))))
     (let ((g266 (lambda ()
                   (match:syntax-err
                     `(define-const-structure ,@args)
@@ -2614,4 +2637,4 @@
                             (g259 (cdr g260) (cons (car g260) g258))
                             (g266))))
                   (g266)))
-          (g266)))))
+          (g266))))