new version of attributed varibales + prolog output is not namespaced

parent 5652d0bb
......@@ -10,6 +10,7 @@
gp-get-attr
gp-del-attr
gp-att-data
gp-att-raw-var
))
(define *printers* (make-weak-key-hash-table))
......
......@@ -103,6 +103,7 @@
gp-del-attr
gp-att-put-data
gp-set-attribute-trampoline
gp-att-raw-var
))
;; Tos silence the compiler, those are fetched from the .so file
......
......@@ -2,17 +2,18 @@
#:use-module (logic guile-log)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog names)
#:export (attvar put_attr get_attr del_attr construct_attr))
#:export (attvar put_attr get_attr del_attr raw_attvar
construct_attr))
(<define> (attvar X) (<attvar?> X))
(<define> (put_attr Var Mod Val)
(<let> ((Mod (<lookup> Mod))
(Var (<lookup> Var)))
(<if> (<attvar?> Var)
(<if> (atom CUT Mod)
(<put-attr> Var Mod Val)
(type_error Mod atom))
(representation_error Var))))
(<let> ((Mod (<lookup> Mod))
(Var (<lookup> Var)))
(<if> (<attvar?> Var)
(<if> (atom CUT Mod)
(<put-attr> Var Mod Val)
(type_error Mod atom))
(representation_error Var))))
(<define> (get_attr Var Mod Val)
(<let> ((Mod (<lookup> Mod))
......@@ -21,11 +22,6 @@
(<get-attr> Var Mod Val)
(type_error Mod atom))))
(<define> (del_attr Var Mod)
(<let> ((Mod (<lookup> Mod)))
(<if> (atom CUT Mod)
(<del-attr> Var Mod)
(type_error Mod atom))))
(<define> (construct_attr Y L)
(<recur> lp ((L L))
......@@ -37,3 +33,17 @@
(()
(<cut> <cc>)))))
(<define> (raw_attvar x z)
(<let> ((x (<lookup> x)))
(<if> (attvar x)
(<and>
(<values> (y) (<raw-attvar> x))
(<=> z x))
(type_error x attvar))))
(<define> (del_attr Var Mod)
(<let> ((Mod (<lookup> Mod)))
(<if> (atom CUT Mod)
(<del-attr> Var Mod)
(type_error Mod atom))))
......@@ -13,39 +13,36 @@ do_all_atts([]).
% The unification algorithm
freezeId(Val, Var, #t) :-
var(Val);attvar(Val);
((var(Val);attvar(Val)),!);
(
get_attr(Var,freezeId, Atts),
write(Atts),nl,
get_attr(Var,freezeId, Atts),!,
do_all_atts(Atts),
del_attr(Var, freezeId),
Var = Val
).
freeze(Var,Goal) :-
(var(Var),
(
((var(Var);attvar(Var)),
((
get_attr(Var, freezeId, Att),!,
Att2 = [Goal|Att],
put_attr(Var, freezeId, Att2)
);
(
put_attr(Var, freezeId, [Goal])
)
),!)
);
call(Goal).
combine_atts([G,U |L], (G;GL)) :- combine_atts([U|L], GL),!.
combine_atts([G,U |L], (G,GL)) :- combine_atts([U|L], GL).
combine_atts([G], G).
combine_atts([],true).
frozen(Var,Goal) :-
(
get_attr(Var, freezeId, Atts),!,
combine_atts(Atts,Goal)
) ;
Goal = true.
get_attr(Var, freezeId, Atts) ->
combine_atts(Atts,Goal);
Goal = true.
%when(Condition, Goal)
......@@ -61,14 +58,14 @@ whenId(Val,Var,#t) :-
(
get_attr(Var,whenId,Atts),!,
del_attr(Var, whenId),
Var = Val,
Var = Val,!,
do_all_atts_when(Atts)
);
(
get_attr(Var,whenId,[VV|_]), VV=Val
)
)
),!.
).
difId(Val, Var, #t) :-
......
......@@ -33,7 +33,8 @@
<define-guile-log-rule>
<get-fixed> <cp> <lookup> <wrap>
<with-bind>
<attvar?> <put-attr> <get-attr> <del-attr>
<attvar?> <put-attr> <get-attr> <del-attr> <get-attrs>
<raw-attvar>
))
......@@ -1082,6 +1083,20 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(<define> (<attvar?> x) (if (gp-attvar? x S) <cc> <fail>))
(<define> (<put-attr> x m v) (<let> ((s (gp-put-attr x m v S)))
(<with-s> s <cc>)))
(<define> (<get-attrs> x m v)
(<let> ((x (<lookup> x)))
(when (gp-attvar-raw? x S)
(<let> ((l (gp-att-data x S)))
(<recur> lp ((l l))
(<match> (#:mode +) (l)
(((,m . ,v) . l)
(lp l))
(_ (<cut> <fail>))))))))
(<define> (<raw-attvar> x)
(<let> ((x (gp-att-raw-var x S)))
(when x (<cc> x))))
(<define> (<get-attr> x m v)
(<let> ((ret (gp-get-attr x m S)))
(when ret (<=> v ret))))
......
......@@ -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))))
......
......@@ -292,7 +292,7 @@
((unify-tr stx n m x y)
(match x
((#:variable v id nn mm)
(if (and (first-variable? v id) (pk 'first v) (variable-not-included? v y))
(if (and (first-variable? v id) v (variable-not-included? v y))
(begin
(local-variable! v)
#`(<code>
......
......@@ -461,19 +461,42 @@
(format #f "~a| ~a" (lp a) (lp b)))))
(define (gen@ ll a)
(match ll
(('language 'prolog 'modules x)
(format #f "~a@@~a"
(procedure-name a) x))
(("language" "prolog" "modules" x)
(format #f "~a@@~a"
(procedure-name a) x))
((_ . _)
(format #f "~a@@(~a~{, ~a~})"
(procedure-name a) (car ll) (cdr ll)))
(_
(format #f "~a" (procedure-name a)))))
(cond
((not ns?)
(format #f "~a" (procedure-name a)))
((and ns? (not quoted))
(let ((m (current-module))
(n (procedure-name a)))
(if (and (module-defined? m n) (eq? (module-ref m n) a))
(format #f "~a" n)
(match ll
(('language 'prolog 'modules x)
(format #f "~a@@~a"
(procedure-name a) x))
(("language" "prolog" "modules" x)
(format #f "~a@@~a"
(procedure-name a) x))
((_ . _)
(format #f "~a@@(~a~{, ~a~})"
(procedure-name a) (car ll) (cdr ll)))
(_
(format #f "~a" (procedure-name a)))))))
(else
(match ll
(('language 'prolog 'modules x)
(format #f "~a@@~a"
(procedure-name a) x))
(("language" "prolog" "modules" x)
(format #f "~a@@~a"
(procedure-name a) x))
((_ . _)
(format #f "~a@@(~a~{, ~a~})"
(procedure-name a) (car ll) (cdr ll)))
(_
(format #f "~a" (procedure-name a)))))))
(define (lp x)
(umatch (#:mode - #:status s #:name scm->pl) (x)
(#((f a . l))
......
......@@ -510,7 +510,7 @@
(<let> ((n N) (m M))
(.. (c) (tag c0))
(<p-cc>
`(#:keyword ,(if (equal? (pk 'true/false c) "#t") #t #f) ,n ,m))))
`(#:keyword ,(if (equal? c "#t") #t #f) ,n ,m))))
mk-id)))
(define termvar-tok
......
......@@ -31,13 +31,46 @@ SCM_DEFINE(gp_attdata, "gp-att-data", 2, 0, 0, (SCM x, SCM s),
ref = gp_lookup2(GP_GETREF(x), l);
if(GP(x) && GP_ATTR(ref))
{
return ref[1];
return SCM_CDR(ref[1]);
}
}
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_DEFINE(gp_att_rawvar, "gp-att-raw-var", 2, 0, 0, (SCM x, SCM s),
"check to see if variable is an attributed variable")
#define FUNC_NAME s_gp_att_rawvar
{
SCM l;
UNPACK_S0(l,s,"cannot unpack s in gp_ref_set");
SCM *ref;
if(GP(x))
{
ref = gp_lookup2(GP_GETREF(x), l);
if(GP(x))
{
if(GP_ATTR(ref))
{
return SCM_CAR(ref[1]);
}
else
{
if(GP_UNBOUND(ref))
{
return x;
}
else
return SCM_BOOL_F;
}
}
return SCM_BOOL_F;
}
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_DEFINE(gp_put_attdata, "gp-att-put-data", 3, 0, 0, (SCM x, SCM v, SCM s),
"check to see if variable is an attributed variable")
#define FUNC_NAME s_gp_put_attdata
......@@ -105,18 +138,21 @@ SCM_DEFINE(gp_put_attr, "gp-put-attr", 4, 0, 0,
{
if(GP_ATTR(ref) || GP_UNBOUND(ref))
{
SCM it = ref[1];
if(GP_UNBOUND(ref))
{
SCM newvar = GP_IT(gp_mk_var(s));
SCM newvar1 = GP_IT(gp_mk_var(s));
SCM newvar2 = GP_IT(gp_mk_var(s));
s = gp_ref_attr_set
(GP_UNREF(ref), scm_cons(scm_cons(lam, newvar),SCM_EOL), s);
s = gp_ref_set(newvar, val, s);
(GP_UNREF(ref), scm_cons(newvar2,
scm_cons(scm_cons(lam,
newvar1),
SCM_EOL)), s);
s = gp_ref_set(newvar1, val, s);
}
else
{
int found = 0;
SCM l = it;
SCM l = SCM_CDR(ref[1]), it = l;
while(SCM_CONSP(l))
{
if(SCM_CONSP(SCM_CAR(l)))
......@@ -136,7 +172,9 @@ SCM_DEFINE(gp_put_attr, "gp-put-attr", 4, 0, 0,
{
SCM newvar = GP_IT(gp_mk_var(s));
s = gp_ref_set
(GP_UNREF(ref), scm_cons(scm_cons(lam, newvar), it), s);
(GP_UNREF(ref),
scm_cons(SCM_CAR(ref[1]),
scm_cons(scm_cons(lam, newvar), it)), s);
s = gp_ref_attr_set(newvar, val, s);
}
}
......@@ -172,7 +210,7 @@ SCM_DEFINE(gp_get_attr, "gp-get-attr", 3, 0, 0, (SCM x, SCM lam, SCM s),
{
if(GP_ATTR(ref))
{
SCM it = ref[1];
SCM it = SCM_CDR(ref[1]);
if(GP_UNBOUND(ref))
{
return x;
......@@ -221,7 +259,7 @@ SCM_DEFINE(gp_del_attr, "gp-del-attr", 3, 0, 0, (SCM x, SCM lam, SCM s),
gp_debug0("a gp~%");
if(GP_ATTR(ref))
{
SCM it = ref[1];
SCM it = SCM_CDR(ref[1]);
gp_debug0("a an attr~%");
if(GP_UNBOUND(ref))
{
......@@ -270,7 +308,7 @@ SCM_DEFINE(gp_del_attr, "gp-del-attr", 3, 0, 0, (SCM x, SCM lam, SCM s),
}
gp_format1("tt: ~a~%",r);
s = gp_ref_set(x, r, s);
s = gp_ref_set(x, scm_cons(SCM_CAR(ref[1]), r), s);
}
}
}
......
......@@ -1406,7 +1406,7 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
SCM s = gp_make_s(ci,l);
SCM xl = id1[1];
SCM xl = SCM_CDR(id1[1]);
while(SCM_CONSP(xl))
{
gp_format1("processing ~a~%", SCM_CAR(xl));
......
......@@ -128,3 +128,4 @@ SCM_API SCM gp_get_attr(SCM x, SCM lam, SCM s);
SCM_API SCM gp_del_attr(SCM x, SCM lam, SCM s);
SCM_API SCM gp_set_attributed_trampoline(SCM x);
SCM_API SCM gp_put_attdata(SCM x, SCM v, SCM s);
SCM_API SCM gp_att_rawvar(SCM x, SCM s);
......@@ -44,7 +44,6 @@ gp_mark_variable (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)),
mark_stack_ptr,
mark_stack_limit, NULL);
}
}
//else
......@@ -59,7 +58,6 @@ gp_mark_variable (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)),
mark_stack_ptr,
mark_stack_limit, NULL);
}
#endif
......
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