WIP

match-test.scm

@@ -9,6 +9,7 @@
       (scheme cyclone test)))
   (chibi
     (import
+      (chibi ast)
       (chibi match)
       (chibi test)))
 )
@@ -75,8 +76,19 @@
 ;(expand (match-two$267 v$1 (and$262 s) ("test" (set! "test")) (match-drop-ids$9 (begin s)) (failure$5) ()))*/
 
 ;;TODO: this does not work, try expanding it manually like we did with the other failing macros. maybe we can discover what's going wrong...
+;; NOTE there is a warning in chibi on this one. maybe this is not a big deal
 ;(display (match 1 ((or x 2) x)) )(newline)
 (display
+    (let ()
+      (define-record-type employee
+        (make-employee name title)
+        employee?
+        (name get-name)
+        (title get-title))
+      (match (make-employee "Bob" "Doctor")
+        (($ employee n t) (list t n))))
+)
+#;(display
 ;  (let ((v 1))
 ;    (let ((failure (lambda () (match-next v (1 (set! 1)) (else #f)))))
 ;    (match-two v (or x 2) (1 (set! 1)) (match-drop-ids (begin x)) (failure) ())))
@@ -96,12 +108,24 @@
 ;     (let ((sk2 (lambda (x) (begin (x)))))
 ;       (match-gen-or-step v (x 2) (1 (set! 1)) (match-drop-ids (sk2 x)) (failure) ()))))
 
-  (let ((v 1))
+  ;(let ((v 1))
-    (let ((failure (lambda () (match-next v (1 (set! 1)) (else #f)))))
+  ;  (let ((failure (lambda () (match-next v (1 (set! 1)) (else #f)))))
-     ;(match-gen-or v (x 2) (1 (set! 1)) (begin x) (failure) () ((x p-ls)))))
+  ;   (let ((sk2 (lambda (x) (begin (x)))))
-     (let ((sk2 (lambda (x) (begin (x)))))
+  ;     (let ((fk2 (lambda () (match-gen-or-step v (2) (1 (set! 1)) (match-drop-ids (sk2 x)) (failure) ()))))
-       (let ((fk2 (lambda () (match-gen-or-step v (2) (1 (set! 1)) (match-drop-ids (sk2 x)) (failure) ()))))
+  ;       (match-one v x (1 (set! 1)) (match-drop-ids (sk2 x)) (fk2) ())))))
-         (match-one v x (1 (set! 1)) (match-drop-ids (sk2 x)) (fk2) ())))))
+
+; Broken, but is this the wrong expansion? Did we already fail?
+;  (let ((v 1))
+;    (let ((failure (lambda () (match-next v (1 (set! 1)) (else #f)))))
+;     (let ((sk2 (lambda (x) (begin (x)))))
+;       (match-gen-or-step v (2) (1 (set! 1)) (match-drop-ids (sk2 x)) (failure) ()))))
+
+  ;; Errs out but does not choke on macro expansion
+  ;(let ((v 1))
+  ; (let ((sk2 (lambda (x) (begin (x)))))
+  ;  (let ((failure (lambda () (match-next v (1 (set! 1)) (else #f)))))
+  ;       (match-one v x (1 (set! 1)) (match-drop-ids (sk2 x)) (failure) ()))))
+
 )
 
 #;(test-group

match-test2.scm

@@ -208,8 +208,25 @@
   (syntax-rules ()
     ((_ expr ids ...) expr)))
 
+(define-syntax match-gen-or-step
+  (syntax-rules ()
+    ((_ v () g+s sk fk . x)
+     ;; no OR clauses, call the failure continuation
+     fk)
+    ((_ v (p) . x)
+     ;; last (or only) OR clause, just expand normally
+     (match-one v p . x))
+    ((_ v (p . q) g+s sk fk i)
+     ;; match one and try the remaining on failure
+     (let ((fk2 (lambda () (match-gen-or-step v q g+s sk fk i))))
+       (match-one v p g+s sk (fk2) i)))
+    ))
 
 (display
+  (let ((v 1))
+    (let ((failure (lambda () (match-next v (1 (set! 1)) (else #f)))))
+     (let ((sk2 (lambda (x) (begin (x)))))
+       (match-gen-or-step v (2) (1 (set! 1)) (match-drop-ids (sk2 x)) (failure) ()))))
   ;; Works fine with my-and, but change back to and (and above in match-two) and it is broken
   ;(match-two 1 (my-and x) (1 (set! 1)) (match-drop-ids (begin x)) (begin) ())
 ;; With my-and the initial expansions are:
@@ -219,7 +236,7 @@
 ;/* (expand (match-check-identifier$2105 x (let-syntax ((new-sym?$2100 (syntax-rules$2104 () ((new-sym?$2100 x sk2$2102 fk2$2101) sk2$2102) ((new-sym?$2100 y$2103 sk2$2102 fk2$2101) fk2$2101)))) (new-sym?$2100 random-sym-to-match$2099 (let$2098 ((x 1)) (match-one$2095 1 (my-and$2094) (1 (set! 1)) (match-drop-ids (begin x)) (begin) (x))) (if (equal? 1 x) (match-one$2095 1 (my-and$2094) (1 (set! 1)) (match-drop-ids (begin x)) (begin) ()) (begin)))) (if (equal? 1 x) (match-one$2095 1 (my-and$2094) (1 (set! 1)) (match-drop-ids (begin x)) (begin) ()) (begin))))*/ 
 
   ;; Alternatively, with and the initial expansions are:
-  (match-two 1 (and x) (1 (set! 1)) (match-drop-ids (begin x)) (begin) ())
+;  (match-two 1 (and x) (1 (set! 1)) (match-drop-ids (begin x)) (begin) ())
 ;/* (expand (match-two 1 (and x) (1 (set! 1)) (match-drop-ids (begin x)) (begin) ()))*/ 
 ;/* (expand (if (pair? 1) (let$2108 ((w$2107 (car 1)) (x$2105 (cdr 1))) (match-one$2106 w$2107 and ((car 1) (set-car! 1)) (match-one$2106 x$2105 (x) ((cdr 1) (set-cdr! 1)) (match-drop-ids (begin x)) (begin)) (begin) ())) (begin)))*/ 
 ;/* (expand (pair? 1))*/