changed coroutines to be of the delayed kind

parent 88f265bc
......@@ -14,6 +14,7 @@
gp-del-attr
gp-att-data
gp-att-raw-var
multibute
))
(define attvars '() #;(gp-make-weak-list))
......
......@@ -108,6 +108,7 @@
gp-set-attribute-trampoline
gp-att-raw-var
gp-add-unwind-hook
multibute
))
;; Tos silence the compiler, those are fetched from the .so file
......@@ -301,7 +302,17 @@
(define gp->scm- gp->scm)
(define delayed-id (cons 'delayed 'unifier))
(define *delayers* (make-fluid '()))
(define (multibute f)
(set-object-property! f delayed-id #t))
(gp-set-attribute-trampoline (lambda (lam val var x s)
(lam s (lambda () #f) (lambda (s . l) s)
val var x)))
(if (object-property lam delayed-id)
(begin
(fluid-set! *delayers*
(cons (list lam val var x)
(fluid-ref *delayers*)))
s)
(lam s (lambda () #f) (lambda (s . l) s)
val var x))))
......@@ -3,6 +3,8 @@
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log attributed)
#:re-export (multibute)
#:export (attvar put_attr get_attr get_attrs del_attr raw_attvar
construct_attr))
......
......@@ -88,6 +88,7 @@ do_all_atts([[Unw],G|L]) :- !,
% The unification algorithm
-multibute.
freezeId(Val, Var, #f) :- !, eq(Var, Val).
freezeId(Val, Var, #t) :-
(var(Val) , !);
......@@ -175,7 +176,7 @@ do_all_when(R,[[[Pre,Unwinder],G,M,[K,O],Vs,Ns,Gs]|L]) :- !,
); true
), do_all_when(R,L).
-multibute.
whenId(Val,Var,#f) :- eq(Val,Var) ; (raw_attvar(Var, Raw), Val == Raw).
whenId(Val,Var,#t) :-
raw_attvar(Var, Raw) ->
......
......@@ -809,6 +809,32 @@
;;TODO, this will unify with a cyclic check!
;;Not possible to use a pure raw form here
(define delayers (@@ (logic guile-log code-load) *delayers*))
(<define> (dls old)
(<recur> lp ((l (fluid-ref delayers)))
(if (eq? l old)
(<code> (fluid-set! delayers old))
(<let> ((x (car l)))
(<apply> (car x) (cdr x))
(lp (cdr l))))))
(define-syntax-rule (dls-wrap (cut s p cc) code)
(let ((old (fluid-ref delayers))
(p2 (lambda ()
(fluid-set! delayers old)
(P)))
(cut2 (lambda ()
(fluid-set! delayers old)
(CUT))))
(<and> (cut2 s p2 cc)
code
(if (eq? (fluid-ref delayers) old)
<cc>
(dls old)))))
(define-guile-log <=>
(syntax-rules ()
((_ wc X Y)
......@@ -1155,10 +1181,16 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(<define> (<del-attr> x m) (<with-s> (gp-del-attr x m S) <cc>))
(define (tr-meta f fnew)
(set-object-properties! fnew (object-properties f))
(if (procedure? f)
(set-procedure-properties! fnew (procedure-properties f)))
fnew)
(define-syntax-rule (functorize f g l ...)
(let ((goal g)
(fu f))
(let ((res (<lambda> x (<apply> goal fu l ... x))))
(let ((res (tr-meta fu (<lambda> x (<apply> goal fu l ... x)))))
res)))
(define-syntax-rule (adaptable_vars f)
......
......@@ -106,13 +106,22 @@
((trace f)
(syntax-parameterize ((Trace (lambda (x) #'#t)))
(mktr Fkn f)))))
(define (tr-meta f fnew)
(set-object-properties! fnew (object-properties f))
(if (procedure? f)
(set-procedure-properties! fnew (procedure-properties f)))
fnew)
(define-syntax-rule (mktr f xx)
(if Trace
(<lambda> x
(<apply> trace-fkn f Level x)
(<apply> xx x))
xx))
(let ((ff f))
(if Trace
(tr-meta
ff
(<lambda> x
(<apply> trace-fkn ff Level x)
(<apply> xx x)))
xx)))
(define-syntax-rule (define-or-set! x)
(let* ((xx x))
......@@ -436,10 +445,10 @@
(let* ((syms (get-syms))
(syms (union syms syms)))
(ppp 'res #`(begin
(eval-when (compile load eval)
(add-non-defined
(quote #,(datum->syntax stx syms))))
(pp 'res #`(begin
(eval-when (compile load eval)
(add-non-defined
(quote #,(datum->syntax stx syms))))
#,@ini
lam-def ... #,@l #,@evl))))))))))
#''compile-error))
......
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