coroutines compiles negations condition for when

parent 5a569564
......@@ -5,18 +5,6 @@
#:export (freeze frozen when dif))
(define doWhen (gp-make-var))
#|
(define do_all_atts #f)
(define freezeId #f)
(define combine_atts #f)
(define do_all_atts_when #f)
(define whenId #f)
(define process_cond #f)
(define do_when #f)
(define diffId #f)
(define mk_cond #f)
(define membereq #f)
|#
(compile-prolog-string
"
......@@ -104,9 +92,12 @@ process_cond((X;Y), Vars) :- !,
% This is very non multithreading, let doWhen be a kanren style variable and
% we are golden.
process_cond(X=Y, [X], (\\+(X = true, X=Y) -> false ; true)) :- !.
process_cond(nonvar(X), [X], nonvar(X)) :- !.
%process_cond(ground(X), [X], ground(X)) :- !.
process_cond(X=Y, [X], ((\\+(scm[doWhen] = true, X=Y)) -> false ; true))
:- !.
process_cond(nonvar(X), [X], nonvar(X))
:- !.
%process_cond(ground(X), [X], ground(X))
% :- !.
mk_cond(V, Cond, Goal, Res) :- Res = Cond.
......
......@@ -405,7 +405,7 @@
(syntax-rules ()
((_ (cut s p cc) code ...)
(let* ((ss (gp-newframe s))
(ccc (lambda (sss pp) (p)))
(ccc (lambda x (p)))
(ppp (lambda ()
(gp-unwind ss)
(cc ss p))))
......
......@@ -322,7 +322,7 @@
(let* ((syms (get-syms))
(syms (union syms syms)))
(ppp 'res #`(begin
(pp 'res #`(begin
(eval-when (compile load eval)
(add-non-defined
(quote #,(datum->syntax stx syms))))
......
......@@ -13,7 +13,7 @@
#:use-module ((logic guile-log) #:select (<let> <pp> <scm> <code> <let*>
<var> <=> <fail> <match>
<cut> <and> <or> <define>
<cc>
<cc> <not>
(_ . GL:_)))
#:re-export (*prolog-file* get-refstr)
#:export (prolog-parse define-parser-directive add-op rem-op
......@@ -143,6 +143,7 @@
(fluid-set! *prolog-ops* *standard-opmap*))
(define fop ((mk-fop *prolog-ops*) '(fy fx xfx xfy yfx yf xf)))
(define funop ((mk-fop *prolog-ops*) '(fy fx)))
(define fbinop ((mk-fop *prolog-ops*) '(xfx xfy yfx)))
(define opsym
(<p-lambda> (c)
......@@ -151,8 +152,6 @@
((_ _ op _)
(<cut> (<and> (<p-cc> (<scm> op))))))))
(define symbolic-1 (f-not! (f-or! wf-char special rest-var )))
(define symbolic (letrec ((sym* (f-or f-true (f-seq symbolic-1 (Ds sym*)))))
(f-or (mk-token (f-seq symbolic-1 sym*)))))
......@@ -529,8 +528,10 @@
(<p-lambda> (c)
(.. (c0) (ws c))
(<let> ((n N) (m M))
(.. (c1) (symbolic c0 ))
(.. (c2) (l c1))
(xx (cx) (<and> (<not> (.. (q) (funop c0)))
(<p-cc> 1)))
(.. (c1) (symbolic c0))
(.. (c2) (l (pk c1)))
(.. (c3) ((f-or expr ws) c2))
(.. (c4) (r c3))
(.. (c5) (ws c4))
......@@ -541,8 +542,8 @@
(_
#f))
(<p-cc>
(wrap@ u `(#:term (#:atom ,(string->symbol c1) ,n ,m)
,(<scm> c3) #f ,n ,m)))
(wrap@ u (pk `(#:term (#:atom ,(string->symbol c1) ,n ,m)
,(<scm> c3) #f ,n ,m))))
<fail>)))
mk-id)))
......
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