only one test fails in reasoned schemer macros and umatch passes

parent be844b81
This diff is collapsed.
......@@ -231,7 +231,9 @@
((_ (cut s pr cc) (a b ...) e2 ...)
(log-code-macro? (syntax a))
#'(a (cut fi pr (parse<> (cut s pr cc) (<and> e2 ...))) b ...))
#'(a (cut s pr (parse<> (cut s pr cc)
(<and> e2 ...)))
b ...))
((_ (cut s pr cc) e1 e2 ...)
#'(let ((ccc (lambda (ss pr2) (<and> (cut ss pr2 cc) e2 ...))))
......@@ -328,21 +330,18 @@
((_ (cut s p cc) (v ...) code ...)
(let ((v (gp-var!)) ...)
(parse<> (cut s p cc) (<and> code ...))))))
(log-code-macro <var>)
(define-guile-log <let>
(syntax-rules ()
((_ (cut s p cc) (v ...) code ...)
(let (v ... )
(parse<> (cut s p cc) (<and> code ...))))))
(log-code-macro <let>)
(define-guile-log <let*>
(syntax-rules ()
((_ (cut s p cc) (v ...) code ...)
(let* (v ... )
(parse<> (cut s p cc) (<and> code ...))))))
(log-code-macro <let*>)
(define-syntax <%cc%>
(syntax-rules (last parse<>)
......@@ -381,8 +380,6 @@
(parse<> wc (<and> code ...))
(parse<> wc <fail>)))))
(log-code-macro '<when>)
(define (pp x)
(pretty-print x)
x)
......@@ -428,7 +425,7 @@
((_ wc code ...)
(begin code ...))))
(log-code-macro '<code>)
(log-code-macro '<return>)
(define-syntax parse<>
(lambda (x)
......@@ -495,14 +492,16 @@
(define-guile-log <match>
(syntax-rules ()
((_ wc as ...)
(match0 (+) wc as ...)
(match0 (+ '<match>) wc as ...)
#;(mk-syms 1 v () (find-last0 v wc (as ...))))))
(define-syntax match0
(syntax-rules ()
((_ (m) wc #:mode m0 . l)
(match0 (m0) wc . l))
((_ meta wc v . l)
((_ (m n) wc (#:mode m0 . u) . l)
(match0 (m0 n) u wc . l))
((_ (m n) wc (#:name n0 . u) . l)
(match0 (m 'n0) u wc . l))
((_ meta wc () v . l)
(mk-syms 1 v () (find-last0 v wc meta l)))))
(define-syntax <lambda>
......@@ -565,27 +564,24 @@
(define-syntax find-last**
(syntax-rules ()
((_ (m) (pr ...) args v ((a)) ((b) ...) (cut w p cc))
(umatch #:mode m #:tag <next> #:name '<match>
()
((prompt=> (pr <next>)
(<with-prolog-environment> (cut <next> pr cc) b)))
((_ (m nm) (pr ...) args v ((a)) ((b) ...) (cut s p cc))
(umatch (#:mode m #:status s #:tag <next> #:name nm) ()
((<with-guile-log> (cut s <next> cc) b))
...
((<with-prolog-environment> (cut w p cc) a))))
((<with-guile-log> (cut s p cc) a))))
((_ m pr args v (a aa ...) (b ...) wc)
(find-last** m pr args v (aa ...) (b ... a) wc))
((_ (m) (pr ...) args v ((as ...)) ((aas ...) ...) ((a)) ((b) ...)
(cut w p cc))
(umatch #:mode m #:tag <next> #:name '<match>
v
(aas ... (prompt=> (pr <next>)
(<with-prolog-environment> (cut <next> pr cc) b)))
...
((_ (m nm) (pr ...) args v ((as ...)) ((aas ...) ...) ((a)) ((b) ...)
(cut s p cc))
(umatch (#:mode m #:status s #:tag <next> #:name nm)
v
(aas ... (<with-guile-log> (cut s <next> cc) b))
...
(as ... (<with-prolog-environment> (cut w p cc) a))))
(as ... (<with-guile-log> (cut s p cc) a))))
((_ m pr args v ((as ...) (aas ...) ...) ((aass ...) ...) ((a) (aa) ...)
((b) ...) wc)
......@@ -598,7 +594,7 @@
(define-syntax let<>0
(syntax-rules ()
((_ (cut s p cc) (m pat val) code)
(umatch #:state s #:mode m #:name 'let<>/<=>/<==> (val)
(umatch (#:status s #:mode m #:name 'let<>/<=>/<==>) (val)
(pat (parse<> (cut s p cc) code ))
(_ (parse<> (cut s p cc) <fail>))))))
......@@ -639,7 +635,7 @@
(syntax-rules ()
((_ wc X Y)
(<=>q wc (gp-unify-raw! ++) X Y))))
(log-code-macro '<=>)
(log-code-macro '<r=>)
(define-guile-log <==>
(syntax-rules ()
......@@ -677,7 +673,7 @@
;;unquote logic so that we can evaluate forms in the unification
((_ wc (unify m) (unquote X) (unquote Y))
(<when> wc (unify X Y) <cc>))
(<unify> wc unify X Y))
((_ meta (unify m) (unquote X) (quote Y))
(<unify> meta unify X (quote Y)))
......@@ -729,27 +725,27 @@
(syntax-rules ()
((_ (f #:mode mode a ...) m ... (me ... codee))
(<define> (f a ...)
(<match> #:mode mode (a ...)
m ...
(me ... (<cut> codee)))))
(<match> (#:mode mode #:name f) (a ...)
m ...
(me ... (<cut> codee)))))
((_ (f a ...) m ... (me ... codee))
(<define> (f a ...)
(<match> (a ...)
m ...
(me ... (<cut> codee)))))))
(<match> (#:name f) (a ...)
m ...
(me ... (<cut> codee)))))))
(define-syntax <<define>>
(syntax-rules ()
((_ (#:mode mode f a ...) (m ... code) ...)
(<define> (f a ...)
(<match> #:mode mode (a ...)
(m ... (<cut> code)) ...)))
(<match> (#:mode mode #:name f) (a ...)
(m ... (<cut> code)) ...)))
((_ (f a ...) (m ... code) ...)
(<define> (f a ...)
(<match> (a ...)
(m ... (<cut> code)) ...)))))
(<match> (#:name f) (a ...)
(m ... (<cut> code)) ...)))))
(define-guile-log <dynwind>
......
......@@ -81,6 +81,23 @@
(define gpmun! gp-m-unify!)
(define (gp-m-unify! x y s) (if (gpmun! x y) s #f))
(define gpnull! gp-null!?)
(define (gp-null!? x s)
(if (gpnull! x) s #f))
(define gpnull gp-null?)
(define (gp-null? x s)
(if (gpnull x) s #f))
(define gppair! gp-pair!?)
(define (gp-pair!? x s)
(if (gppair! x) s #f))
(define gppair gp-pair?)
(define (gp-pair? x s)
(if (gppair x) s #f))
(define-syntax **um** (syntax-rules () ((_ . l) (umatch . l))))
(define dyn gp-dynwind)
......@@ -196,7 +213,7 @@
(define (get-line x u)
(if (gp? x)
(let ((x (gp-lookup x)))
(if (and (gp? x) (gp-pair? x))
(if (and (gp? x) (gppair x))
(get-line (gp-cdr x) (cons (gp-car x) u))
(if (null? x)
(values (reverse u) '())
......@@ -212,7 +229,7 @@
(let ((x (gp-lookup x)))
(if (gp? x)
(if (gp-pair? x)
(if (gppair x)
(let-values (((l d) (get-line x '())))
(if (null? x)
(f l "")
......@@ -289,20 +306,25 @@
(define (id x) x)
(define (ppair? x s)
(if (pair? x) s #f))
(define (nnull? x s)
(if (null? x) s #f))
(define (eequal? x y s)
(if (equal? x y) s #f))
(make-phd-matcher umatch0
( (gp-car gp-cdr gp-pair!? gp-null!? gp-unify! gp-lookup)
( (+ (gp-car gp-cdr gp-pair!? gp-null!? gp-unify! gp-lookup))
(++ (gp-car gp-cdr gp-pair!? gp-null!? gp-unify-raw! gp-lookup))
(- (gp-car gp-cdr gp-pair? gp-null? gp-m-unify! gp-lookup))
(* ( car cdr pair? null? equal? id)))))
(* ( car cdr ppair? nnull? eequal? id)))))
(define-syntax umatch
(lambda (x)
(syntax-case x ()
((umatch . l)
(with-syntax ((w (datum->syntax (syntax l) '*gp-fi*)))
(syntax (umatch* "anon" w #f * . l)))))))
(syntax (umatch* #f "anon" w #f * . l)))))))
;;unsyntax construct that works quite ok
(define (pp x) (pretty-print x) x)
......@@ -311,20 +333,23 @@
(define-syntax umatch*
(lambda (x)
(syntax-case x ()
((umatch* nn tt rr mm #:name n . l)
(syntax (umatch* n tt rr mm . l)))
((umatch* ss nn tt rr mm (#:status s . u) . l)
(syntax (umatch* s n tt rr mm u . l)))
((umatch* ss nn tt rr mm (#:name n . u) . l)
(syntax (umatch* ss n tt rr mm u . l)))
((umatch* nn tt rr mm #:tag t . l)
(syntax (umatch* nn t rr mm . l)))
((umatch* ss nn tt rr mm (#:tag t . u) . l)
(syntax (umatch* ss nn t rr mm u . l)))
((umatch* nn tt rr mm #:raw . l)
(syntax (umatch* nn tt #t mm . l)))
((umatch* ss nn tt rr mm (#:raw . u) . l)
(syntax (umatch* ss nn tt #t mm u . l)))
((umatch* nn tt rr mm #:mode m . l)
(syntax (umatch* nn tt rr m . l)))
((umatch* ss nn tt rr mm (#:mode m . u) . l)
(syntax (umatch* ss nn tt rr m u . l)))
((umatch* n t r m args a ...)
(syntax (umatch** (a ...) () args (n t r m)))))))
((umatch* s n t r m () args a ...)
(syntax (umatch** (a ...) () args (s n t r m)))))))
(define-syntax umatch**
......@@ -367,29 +392,33 @@
(define-syntax umatch***+
(syntax-rules (+)
((_ (code ...) () () (n t _ _))
(let ((frame (gp-newframe)))
(umatch0 (#:args)
((arguments) (-> t (mk-failure frame))
((_ a b c (#f . l))
(let ((s #f))
(umatch***+ a b c (s . l))))
((_ (code ...) () () (s n t _ _))
(let ((s (gp-newframe s)))
(umatch0 s (#:args)
((arguments) (-> t (mk-failure s))
code)
...
(_ (error (format #f "umatch ~a did not match" n))))))
((_ (code ...) ((a ...) ...) arg (n t #t +))
(let ((frame (gp-newframe)))
(umatch0 (#:args . arg)
((_ (code ...) ((a ...) ...) arg (s n t #t +))
(let ((s (gp-newframe s)))
(umatch0 s (#:args . arg)
((arguments (++ ++ a) ...)
(-> t (mk-failure frame))
(-> t (mk-failure s))
code)
...
(_ (error (format #f "umatch ~a did not match" n))))))
((_ (code ...) ((a ...) ...) arg (n t r m))
(let ((frame (gp-newframe)))
(umatch0 (#:args . arg)
((_ (code ...) ((a ...) ...) arg (s n t r m))
(let ((s (gp-newframe s)))
(umatch0 s (#:args . arg)
((arguments (m m a) ...)
(-> t (mk-failure frame))
(-> t (mk-failure s))
code)
...
(_ (error (format #f "umatch ~a did not match" n))))))))
......
......@@ -9,7 +9,7 @@
(queens3 Ns '() Qs))))
(<define> (queens3 UnplacedQs SafeQs Qs)
(<match> (UnplacedQs)
(<match> () (UnplacedQs)
( _ (<var> (Q UnplacedQs1)
(<and> (selectq Q UnplacedQs UnplacedQs1)
(<not> (attack Q SafeQs))
......@@ -20,20 +20,20 @@
(<define> (attack X Xs) (attack3 X 1 Xs))
(<define> (attack3 X N V)
(<match> (V)
(<match> () (V)
((Y . _) (<or> (<when> (eq? (u-scm X) (+ (u-scm Y) N)))
(<when> (eq? (u-scm X) (- (u-scm Y) N)))))
((_ . Y) (attack3 X (+ N 1) Y))
(_ <fail>)))
(<define> (range-list M N U)
(<match> (U)
(<match> () (U)
((,M) (<when> (>= M N) <cut>))
((,M . L) (range-list (+ M 1) N L))
(_ <fail>)))
(<define> (selectq X U Xs)
(<match> (U Xs)
(<match> () (U Xs)
((,X . ,Xs) _ <cc>)
(( Y . Ys) ( Y . Zs) (selectq X Ys Zs))
(_ _ <fail>)))
......@@ -86,7 +86,7 @@
(<define> (<map> rel base arg out)
(<recur> loop ((a arg) (o out))
(<match> (a)
(<match> () (a)
((x . l) (<var> (res)
(<and>
(rel x res o)
......@@ -95,7 +95,7 @@
(_ <fail>))))
(<define> (<append> l s out)
(<match> (l out)
(<match> () (l out)
(() ,s <cc>)
((x . l) (x . res) (<append> l s res))
(_ _ <fail>)))
......
......@@ -3,17 +3,17 @@
:use-module (test-suite lib) )
;;This umatch does not support anything but tail call position yet, soo.
(define (f1) (umatch (1) (X X)))
(define (f2) (umatch ('(1 a)) ((X _) X)))
(define (f3) (umatch ('(1 1)) ((X X) X)))
(define (f4) (umatch ('(a b)) ((X X) X) (_ 1)))
(define (f5) (umatch ('(a a)) ((and X (Y Y)) X)))
(define (f6) (umatch ("hello") (_ #t)))
(define (f7) (umatch ('foo) ('foo #t)))
(define (f8) (umatch ("bar") ("bar" #t)))
(define (f9) (umatch (777) (777 #t)))
(define (f10) (umatch (#\g) (#\g #t)))
(define (f11) (umatch ('(a b c)) ('(a b c) #t)))
(define (f1) (umatch () (1) (X X)))
(define (f2) (umatch () ('(1 a)) ((X _) X)))
(define (f3) (umatch () ('(1 1)) ((X X) X)))
(define (f4) (umatch () ('(a b)) ((X X) X) (_ 1)))
(define (f5) (umatch () ('(a a)) ((and X (Y Y)) X)))
(define (f6) (umatch () ("hello") (_ #t)))
(define (f7) (umatch () ('foo) ('foo #t)))
(define (f8) (umatch () ("bar") ("bar" #t)))
(define (f9) (umatch () (777) (777 #t)))
(define (f10) (umatch () (#\g) (#\g #t)))
(define (f11) (umatch () ('(a b c)) ('(a b c) #t)))
(with-test-prefix "basic mode *, 1 arg, umatch usage *"
(pass-if "(X X)"
......@@ -48,9 +48,9 @@
(pass-if "sexp" (f11)))
(define (g1) (umatch (3 -2) (X Y (+ X Y) )))
(define (g2) (umatch ('(3 a) -2) ((X _) Y (+ X Y))))
(define (g3) (umatch ('(3 3) -2) ((X X) Y (+ X Y))))
(define (g1) (umatch () (3 -2) (X Y (+ X Y) )))
(define (g2) (umatch () ('(3 a) -2) ((X _) Y (+ X Y))))
(define (g3) (umatch () ('(3 3) -2) ((X X) Y (+ X Y))))
(with-test-prefix "basic mode *, 2 arg, umatch usage *"
(pass-if "(X X)"
......@@ -64,17 +64,17 @@
(define (f1) (umatch #:mode + (1) (X X)))
(define (f2) (umatch #:mode + ('(1 a)) ((X _) X)))
(define (f3) (umatch #:mode + ('(1 1)) ((X X) X)))
(define (f4) (umatch #:mode + ('(a b)) ((X X) X) (_ 1)))
(define (f5) (umatch #:mode + ('(a a)) ((and X (Y Y)) X)))
(define (f6) (umatch #:mode + ("hello") (_ #t)))
(define (f7) (umatch #:mode + ('foo) ('foo #t)))
(define (f8) (umatch #:mode + ("bar") ("bar" #t)))
(define (f9) (umatch #:mode + (777) (777 #t)))
(define (f10) (umatch #:mode + (#\g) (#\g #t)))
(define (f11) (umatch #:mode + ('(a b c)) ('(a b c) #t)))
(define (f1) (umatch (#:mode +) (1) (X X)))
(define (f2) (umatch (#:mode +) ('(1 a)) ((X _) X)))
(define (f3) (umatch (#:mode +) ('(1 1)) ((X X) X)))
(define (f4) (umatch (#:mode +) ('(a b)) ((X X) X) (_ 1)))
(define (f5) (umatch (#:mode +) ('(a a)) ((and X (Y Y)) X)))
(define (f6) (umatch (#:mode +) ("hello") (_ #t)))
(define (f7) (umatch (#:mode +) ('foo) ('foo #t)))
(define (f8) (umatch (#:mode +) ("bar") ("bar" #t)))
(define (f9) (umatch (#:mode +) (777) (777 #t)))
(define (f10) (umatch (#:mode +) (#\g) (#\g #t)))
(define (f11) (umatch (#:mode +) ('(a b c)) ('(a b c) #t)))
(with-test-prefix "basic mode +, 1 arg, umatch usage *"
(pass-if "(X X)"
......@@ -109,17 +109,17 @@
(pass-if "sexp" (f11)))
(define (f1) (umatch #:mode - (1) (X X)))
(define (f2) (umatch #:mode - ('(1 a)) ((X _) X)))
(define (f3) (umatch #:mode - ('(1 1)) ((X X) X)))
(define (f4) (umatch #:mode - ('(a b)) ((X X) X) (_ 1)))
(define (f5) (umatch #:mode - ('(a a)) ((and X (Y Y)) X)))
(define (f6) (umatch #:mode - ("hello") (_ #t)))
(define (f7) (umatch #:mode - ('foo) ('foo #t)))
(define (f8) (umatch #:mode - ("bar") ("bar" #t)))
(define (f9) (umatch #:mode - (777) (777 #t)))
(define (f10) (umatch #:mode - (#\g) (#\g #t)))
(define (f11) (umatch #:mode - ('(a b c)) ('(a b c) #t)))
(define (f1) (umatch (#:mode -) (1) (X X)))
(define (f2) (umatch (#:mode -) ('(1 a)) ((X _) X)))
(define (f3) (umatch (#:mode -) ('(1 1)) ((X X) X)))
(define (f4) (umatch (#:mode -) ('(a b)) ((X X) X) (_ 1)))
(define (f5) (umatch (#:mode -) ('(a a)) ((and X (Y Y)) X)))
(define (f6) (umatch (#:mode -) ("hello") (_ #t)))
(define (f7) (umatch (#:mode -) ('foo) ('foo #t)))
(define (f8) (umatch (#:mode -) ("bar") ("bar" #t)))
(define (f9) (umatch (#:mode -) (777) (777 #t)))
(define (f10) (umatch (#:mode -) (#\g) (#\g #t)))
(define (f11) (umatch (#:mode -) ('(a b c)) ('(a b c) #t)))
(with-test-prefix "basic mode -, 1 arg, umatch usage *"
(pass-if "(X X)"
......@@ -155,17 +155,17 @@
(pass-if "sexp" (f11)))
(define (f1) (umatch #:raw #:mode + (1) (X X)))
(define (f2) (umatch #:raw #:mode + ('(1 a)) ((X _) X)))
(define (f3) (umatch #:raw #:mode + ('(1 1)) ((X X) X)))
(define (f4) (umatch #:raw #:mode + ('(a b)) ((X X) X) (_ 1)))
(define (f5) (umatch #:raw #:mode + ('(a a)) ((and X (Y Y)) X)))
(define (f6) (umatch #:raw #:mode + ("hello") (_ #t)))
(define (f7) (umatch #:raw #:mode + ('foo) ('foo #t)))
(define (f8) (umatch #:raw #:mode + ("bar") ("bar" #t)))
(define (f9) (umatch #:raw #:mode + (777) (777 #t)))
(define (f10) (umatch #:raw #:mode + (#\g) (#\g #t)))
(define (f11) (umatch #:raw #:mode + ('(a b c)) ('(a b c) #t)))
(define (f1) (umatch (#:raw #:mode +) (1) (X X)))
(define (f2) (umatch (#:raw #:mode +) ('(1 a)) ((X _) X)))
(define (f3) (umatch (#:raw #:mode +) ('(1 1)) ((X X) X)))
(define (f4) (umatch (#:raw #:mode +) ('(a b)) ((X X) X) (_ 1)))
(define (f5) (umatch (#:raw #:mode +) ('(a a)) ((and X (Y Y)) X)))
(define (f6) (umatch (#:raw #:mode +) ("hello") (_ #t)))
(define (f7) (umatch (#:raw #:mode +) ('foo) ('foo #t)))
(define (f8) (umatch (#:raw #:mode +) ("bar") ("bar" #t)))
(define (f9) (umatch (#:raw #:mode +) (777) (777 #t)))
(define (f10) (umatch (#:raw #:mode +) (#\g) (#\g #t)))
(define (f11) (umatch (#:raw #:mode +) ('(a b c)) ('(a b c) #t)))
(with-test-prefix "basic #raw mode +, 1 arg, umatch usage *"
(pass-if "(X X)"
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment