Gauche:matchcomp

matchcompのパッチ

matchcomp.tar.gzのmatchcomp.scmをGaucheで動かすパッチです。モジュールにしたかったのですが、cut,extendが被っていたのでパッチにしました。--hira

• 関連ページ
  • ML: define-macroをdefine-syntaxに直すには？

• Shiro: ありゃ。今、Andrew Wrightのmatchを移植してるところです。 どうしようかなあ。matchcompはライセンスに「無償」が入っちゃってるんで、 Gauche本体に入れるのは微妙です。別パッケージならいいけど。
• hira: 確かに「無償」はイヤですね。それにしてもmatchの移植とはヘビーなことやってますね。今日の私はRubyのDir.globが作りたくて、それでパターン周りをごそごそやっていたのでした。まず最初にmatchの移植を試みたのですが一瞬で挫折したと。matchcompはすぐに移植できたけど、使い方がよく分からず。patmatはProlog？な感じがして・・・結局自作かなぁと思っていたところです。mitのYentaのslib移植版matchはご覧になりましたか？これが使えるかもと思って眺めていたのですが、とんでもないインデントでS式が宙に浮いているのが笑えます。
• Shiro: matchはもともとmatchマクロを使って書かれているんで、 bootstrapのために、一度展開したソースが必要になります。 そのソースをprettyprintしたらああなっちゃったんでしょう。

--- matchcomp.scm.org   2004-04-12 19:06:18.898875000 +0900
+++ matchcomp.scm       2004-04-12 19:07:51.930125000 +0900
@@ -58,6 +58,14 @@
 ;;;===========================================================1
 ;;; The pattern compiler
 
+(define-syntax defmacro
+  (syntax-rules ()
+    ((_ name clause expr ...) (define-macro name (lambda clause expr ...)))))
+    
+(define t #t)
+
+(define (atom? obj) (not (pair? obj)))
+
 (define (compile-match-meaning f)
   (case (car f)
     ((*sexp) (compile-match-sexp-meaning))
@@ -120,7 +128,7 @@
      e r a m (lambda (ee rr)
                (if (eq? (lookup rr n) unbound-pattern)
                    `(let ((,n ,e))
-                         ,(k e (extend rr n n)) )
+                         ,(k e (extends rr n n)) )
                    (match-wrong "Cannot rebind pattern" n) ) ) ) ) )
 
 (define (compile-match-eval-meaning n)
@@ -128,7 +136,7 @@
     (let ((form (lookup r n)))
       (if (eq? form unbound-pattern)
           (match-wrong "Unbound pattern" n)
-          (if (pair? form) ;; here form = (cut head tail promise)
+          (if (pair? form) ;; here form = (kut head tail promise)
               `(segment-check ,e ,(cadr form) ,(caddr form)
                        ,(let ((g (gensym)))
                            `(lambda (,g) 
@@ -138,14 +146,14 @@
 (define (compile-match-ssetq-append-meaning n f1 f2)
   (lambda (e r a m k)
     ((compile-match-meaning f1)
-     e r (extend a.init n 
+     e r (extends a.init n 
             (lambda (ee rr)
               (if (eq? (lookup rr n) unbound-pattern)
                   (let ((g (gensym)))
-                    `(letrec ((,g (delay (set! ,n (cut ,e ,ee))))
+                    `(letrec ((,g (delay (set! ,n (kut ,e ,ee))))
                               (,n 'wait) )
                        ,((compile-match-meaning f2)
-                         ee (extend rr n `(cut ,e ,ee ,g)) a m k ) ) )
+                         ee (extends rr n `(kut ,e ,ee ,g)) a m k ) ) )
                   (match-wrong "cannot rebind pattern" n) ) ) )
      m.init (lambda (ee rr)
               (match-wrong "*ssetq-append not ended" f1) ) ) ) )
@@ -156,7 +164,7 @@
       (if (eq? (lookup r n) unbound-pattern)
           (match-wrong "Unbound segment" n)
           (let ((g (gensym)))
-            (if (pair? form)  ;; here form = (cut head tail promise)
+            (if (pair? form)  ;; here form = (kut head tail promise)
               `(segment-check ,e ,(cadr form) ,(caddr form)
                        (lambda (,g)
                          ,((compile-match-meaning f)
@@ -180,7 +188,7 @@
                    g r a m k )
                  ,((compile-match-meaning f1)
                    g r a.init 
-                       (extend m.init n 
+                       (extends m.init n 
                           (lambda (ee rr)
                             (if (eq? rr r)
                                 `(,try ,ee)
@@ -218,7 +226,7 @@
 
 (define unbound-pattern (gensym))
 
-(define (extend fn pt im)
+(define (extends fn pt im)
   (cons (cons pt im) fn) )
 
 (define (lookup r n)
@@ -232,7 +240,7 @@
 (define (force-all-segments r)
   (if (pair? r)
       (let ((form (cdar r)))
-        (if (pair? form) ;; here form = (cut head tail promise)
+        (if (pair? form) ;; here form = (kut head tail promise)
             (cons `(force ,(cadddr form))
                   (force-all-segments (cdr r)) )
             (force-all-segments (cdr r)) ) )
@@ -259,9 +267,9 @@
               #f )
           #f ) ) )
 
-(define (cut e ee)
+(define (kut e ee)
   (if (eq? e ee) '()
-      (cons (car e) (cut (cdr e) ee)) ) )
+      (cons (car e) (kut (cdr e) ee)) ) )
 
 ;;;===========================================================3
 ;;; The matching macros. Match failure return #f as is usual in Lisp.
@@ -327,7 +335,7 @@
 (defmacro defmacro-pattern (name variables . body)
   `(begin
     (set! r.macro-pattern
-         (extend r.macro-pattern
+         (extends r.macro-pattern
                  ',name
                  (lambda ,variables . ,body) ) )
     ',name ) )
@@ -456,7 +464,7 @@
     (let ((name (term-variable-true-name e)))
       (if (eq? (lookup r name) unbound-pattern)
           (c `(*setq ,name (*sexp)) 
-             (extend r name 'term) )
+             (extends r name 'term) )
           (c `(*eval ,name) r) ) ) ) )
 
 (define (standardize-quote e)
@@ -468,7 +476,7 @@
     (let ((name (segment-variable-true-name e)))
       (if (eq? (lookup r name) unbound-pattern)
           ((standardize-patterns f*)
-           (extend r name 'segment)
+           (extends r name 'segment)
            (lambda (pattern rr)
              (let ((label (gensym)))
                (c `(*ssetq-append 
@@ -489,7 +497,7 @@
         (let ((name (lispish-segment-variable-true-name e)))
           (if (eq? (lookup r name) unbound-pattern)
               (c `(*setq ,name (*sexp))
-                 (extend r name 'segment) )
+                 (extends r name 'segment) )
               (c `(*eval ,name) r) ) ) )
       (standardize-segment-variable e f*) ) )