From c105fb3432e02406d188abaa7fbf3145ba9add4d Mon Sep 17 00:00:00 2001
From: Masaya Tojo <masaya@tojo.tokyo>
Date: Sun, 15 Nov 2020 18:16:18 +0900
Subject: wip17

---
 vikalpa.scm | 32 +++++++++++++++++++-------------
 1 file changed, 19 insertions(+), 13 deletions(-)

diff --git a/vikalpa.scm b/vikalpa.scm
index bec7c61..2b45012 100644
--- a/vikalpa.scm
+++ b/vikalpa.scm
@@ -183,18 +183,17 @@
               preconds
               fail))
 
-(define (match-expr f expr1 expr2 acc context preconds fail)
+(define (match-expr f g expr1 expr2 acc context preconds fail)
   (cond
-   ((and (expr-quoted? expr1)
-         (expr-quoted? expr2)
-         (equal? expr1 expr2))
-    (f expr1 expr2 acc context preconds fail))
-   ((variable? expr1)
+   ((or (and (expr-quoted? expr1)
+             (expr-quoted? expr2)
+             (equal? expr1 expr2))
+        (variable? expr1))
     (f expr1 expr2 acc context preconds fail))
    ((and (expr-if? expr1)
          (expr-if? expr2))
     (let*-values (((expr/test acc/test)
-                   (match-expr f
+                   (match-expr f g
                                (expr-if-test expr1)
                                (expr-if-test expr2)
                                acc
@@ -202,7 +201,7 @@
                                preconds
                                fail))
                   ((expr/then acc/then)
-                   (match-expr f
+                   (match-expr f g
                                (expr-if-then expr1)
                                (expr-if-then expr2)
                                acc/test
@@ -210,7 +209,7 @@
                                (cons (expr-if-test expr2) preconds)
                                fail))
                   ((expr/else acc/else)
-                   (match-expr f
+                   (match-expr f g
                                (expr-if-else expr1)
                                (expr-if-else expr2)
                                acc/then
@@ -218,8 +217,11 @@
                                (cons (expr-not (expr-if-test expr2))
                                      preconds)
                                fail)))
-      (values (expr-if expr/test expr/then expr/else)
-              acc/else)))
+      (g (expr-if expr/test expr/then expr/else)
+         acc/else
+         context
+         preconds
+         fail)))
    ((and (form? expr1)
          (form? expr2)
          (eq? (form-name expr1)
@@ -254,8 +256,12 @@
                        expr2
                        acc
                        context))))
-      (values (cons (form-name expr1) args-expr)
-              args-acc)))
+      (g expr1
+         (cons (form-name expr1) args-expr)
+         acc/else
+         context
+         preconds
+         fail)))
    (else
     (fail expr1
           expr2
-- 
cgit v1.2.3