Fixed bug in case-lambda

parent a9c6e07a
......@@ -283,7 +283,7 @@ HELP FOR PROLOG COMMANDS
(read_term s p cc port T O)))))
(<define> (ftof X Y I H)
(<match> (#:mode +) (X Y)
(<match> (#:mode + #:name 'ftof) (X Y)
(#(XL) #(YL) (<cut> (vtosym XL YL I H)))
(_ _ (<cut> <fail>))))
......@@ -378,6 +378,7 @@ write_out([V|Vs],[N|Ns])
:- nl,write(\" \"),write(N),write(\" = \"),write(V),
write_out(Vs,Ns).
more :-
scm[(fluid-ref -all-)] == true -> fail ;
(
......
......@@ -611,7 +611,7 @@
#'(lambda (<S> <Cut> <CC> b ...)
(gp-gc)
(<with-guile-log> (<S> <Cut> <CC>)
(<match> (#:mode +) (b ...)
(<match> (#:mode + #:name '<<lambda>>) (b ...)
(a ... code) ... (r ... (<cut> <fail>))))))))))
......@@ -622,18 +622,28 @@
(lambda (x)
(syntax-case x ()
((_ ((as ... codes) ... (a ... code)) ...)
#'(<<case-lambda>> <<case-lambda>>
((as ... codes) ... (a ... code)) ...))
((_ nm ((as ... codes) ... (a ... code)) ...)
(identifier? #'nm)
(with-syntax ((((b ...) ...)
(map2 (datum->syntax #'q (gensym "q"))
(l)
#'((a ...) ...)))
(((m ...) ...)
(map2 #'_
(l)
#'((a ...) ...))))
#'(case-lambda
((<S> <Cut> <CC> b ...)
(gp-gc)
(<with-guile-log> (<S> <Cut> <CC>)
(<match> (#:mode +) (b ...)
(<match> (#:mode + #:name nm) (b ...)
(as ... codes)
...
(a ... (<cut> code)))))
(a ... (<cut> code))
(m ... (<cut> <fail>)))))
...))))))
......
......@@ -361,7 +361,7 @@
(define-guile-log <s-match>
(syntax-rules ()
((<s-match> w (x xl n m c) (p1 p2 code (... ...)) (... ...))
(<match> w (#:mode +) (x c)
(<match> w (#:mode + #:name '<s-match>) (x c)
((* * p1) p2 (<cut> (<and> code (... ...))))
(... ...)
(_ _ (<cut> <fail>))))))
......
......@@ -151,7 +151,7 @@
(<recur> lp ((l val))
(when (pair? l)
(<and!>
(<match> (#:mode -) (l)
(<match> (#:mode - #:name 'mk-fop) (l)
((((name . FX) ch-rest level . F) . u)
(<or>
(when (member FX FXS)
......@@ -176,7 +176,7 @@
(<and>
(.. (p) (fop1 _))
(<match> (#:mode -) (p)
(<match> (#:mode - #:name 'term) (p)
(('fx (= <scm> P) . _)
(when (<= P (<scm> PP))
(.. (t) (term New (- P 1)))
......@@ -201,7 +201,7 @@
(<or>
(<and>
(.. (p) (fop2 _))
(<match> (#:mode -) (p)
(<match> (#:mode - #:name 'rterm) (p)
(('xfx (= <scm> P) . _)
(when (and (<= P (<scm> PP)) (< (<scm> L) P))
(.. (t) (term T (- P 1)))
......
......@@ -407,7 +407,7 @@
(nm-store f)
(pp 'fkn
#'(define fstx
(<<case-lambda>>
(<<case-lambda>> fstx
((lhs ...
(<let> ((loc #f) ...)
(<var> (v ...)
......@@ -415,7 +415,7 @@
...))))
#'(define-or-set! fstx
(<<case-lambda>>
(<<case-lambda>> fstx
((lhs ...
(<let> ((loc #f) ...)
(<var> (v ...)
......
......@@ -147,7 +147,7 @@
(define opsym
(<p-lambda> (c)
(.. (p) (fop c))
(<match> (#:mode -) (p)
(<match> (#:mode - #:name 'opsym) (p)
((_ _ op _)
(<cut> (<and> (<p-cc> (<scm> op))))))))
......@@ -559,7 +559,7 @@
(.. (c4) (r c3))
(.. (c5) (ws c4))
(.. (u) (@tag c5))
(<match> (#:mode -) ((<scm> c3))
(<match> (#:mode - #:name 'term-binop) ((<scm> c3))
(((_ _ "," _) x y _ _)
(<cut>
(<p-cc>
......
......@@ -7,7 +7,7 @@
(<define> (<member> X L)
(<match> () (L)
(<match> (#:name '<member>) (L)
((Y . _) (<=> X Y))
((_ . U) (<cut> (<member> X U)))
(_ (<cut> <fail>))))
......@@ -45,7 +45,7 @@
(<define> (<umember> X L)
(<match> () (L)
(<match> (#:name '<umember>) (L)
((Y . _) (<cut> (if (m= S X Y) <cc> <fail>)))
((_ . U) (<cut> (<umember> X U)))
(_ (<cut> <fail>))))
......
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