diff --git a/boot/attvar.pl b/boot/attvar.pl
index aa5f29a..9b6a969 100644
--- a/boot/attvar.pl
+++ b/boot/attvar.pl
@@ -52,13 +52,27 @@ in pl-attvar.c
%
% Called from the kernel if assignments have been made to
% attributed variables.
+:- module_transparent('$wakeup'/1).
+:- module_transparent(call_all_attr_uhooks/2).
+:- module_transparent(user:meta_unify/3).
+:- module_transparent(uhook/3).
+:- module_transparent(user:attvar_variant/2).
'$wakeup'([]).
'$wakeup'(wakeup(Attribute, Value, Rest)) :-
call_all_attr_uhooks(Attribute, Value),
'$wakeup'(Rest).
+'$wakeup'(unify(Attribute, Value, Rest)) :-
+ call_all_attr_uhooks(Attribute, Value),
+ '$wakeup'(Rest).
+'$wakeup'(variant(AttVar, Value, Rest)) :-
+ user:attvar_variant(AttVar,Value),
+ '$wakeup'(Rest).
+
+
call_all_attr_uhooks([], _).
+call_all_attr_uhooks(att(unify, AttVal, Rest), Value) :- !, user:meta_unify(AttVal,Rest,Value).
call_all_attr_uhooks(att(Module, AttVal, Rest), Value) :-
uhook(Module, AttVal, Value),
call_all_attr_uhooks(Rest, Value).
diff --git a/boot/toplevel.pl b/boot/toplevel.pl
index cd6bcfe..6f3f901 100644
--- a/boot/toplevel.pl
+++ b/boot/toplevel.pl
@@ -1072,6 +1072,7 @@ toplevel_call(Goal) :-
no_lco.
no_lco.
+:- '$hide'(no_lco).
%! write_bindings(+Bindings, +ResidueVars, +Deterministic) is semidet.
%
diff --git a/src/ATOMS b/src/ATOMS
index 0e200d7..afbd5c4 100644
--- a/src/ATOMS
+++ b/src/ATOMS
@@ -768,6 +768,7 @@ A var_prefix "var_prefix"
A variable "variable"
A variable_names "variable_names"
A variables "variables"
+A variant "variant"
A very_deep "very_deep"
A vmi "vmi"
A volatile "volatile"
@@ -1062,6 +1063,9 @@ F undefinterc 4
F unify_determined 2
F uninstantiation_error 1
F var 1
+F references 3
+F unify 3
+F variant 3
F wakeup 3
F warning 3
F write_errors 1
diff --git a/src/pl-attvar.c b/src/pl-attvar.c
old mode 100644
new mode 100755
index f570309..54ddd12
--- a/src/pl-attvar.c
+++ b/src/pl-attvar.c
@@ -99,16 +99,15 @@ which must run in constant space.
SHIFT-SAFE: Caller must ensure 6 global and 4 trail-cells
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
-static void
-registerWakeup(Word name, Word value ARG_LD)
+void
+registerWakeup(word functor, Word name, Word value ARG_LD)
{ Word wake;
Word tail = valTermRef(LD->attvar.tail);
-
assert(gTop+6 <= gMax && tTop+4 <= tMax);
wake = gTop;
gTop += 4;
- wake[0] = FUNCTOR_wakeup3;
+ wake[0] = functor;
wake[1] = needsRef(*name) ? makeRef(name) : *name;
wake[2] = needsRef(*value) ? makeRef(value) : *value;
wake[3] = ATOM_nil;
@@ -178,20 +177,30 @@ assignAttVar(Word av, Word value ARG_LD)
print_addr(av, buf2));
});
- if ( isAttVar(*value) )
- { if ( value > av )
- { Word tmp = av;
- av = value;
- value = tmp;
- } else if ( av == value )
- return;
+ bool both = isAttVar(*value);
+ if (both && av == value ) return;
+
+ { Word vp;
+ if(find_attr(av,ATOM_unify, &vp PASS_LD))
+ { Word g0;
+ deRef2(vp, g0);
+ if(g0==av)
+ {
+ a = valPAttVar(*av);
+ registerWakeup(FUNCTOR_unify3, a, value PASS_LD);
+ } else
+ {
+ TrailAssignment(av);
}
+ return;
+ }}
+
a = valPAttVar(*av);
- registerWakeup(a, value PASS_LD);
+ registerWakeup(FUNCTOR_wakeup3, a, value PASS_LD);
TrailAssignment(av);
- if ( isAttVar(*value) )
+ if ( both )
{ DEBUG(1, Sdprintf("Unifying two attvars\n"));
*av = makeRef(value);
} else
@@ -324,7 +333,7 @@ list is invalid.
Caller must ensure 4 cells space on global stack.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
-static int
+int
find_attr(Word av, atom_t name, Word *vp ARG_LD)
{ Word l;
@@ -1389,6 +1398,33 @@ PRED_IMPL("$call_residue_vars_end", 0, call_residue_vars_end, 0)
#endif /*O_CALL_RESIDUE*/
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ attv_bind_trail(+AttVar, +Value, +NilOrTrail) is det.
+ Binds AttVar with Value without calling wakeup
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+static
+PRED_IMPL("attv_bind_trail", 3, attv_bind_trail, 0)
+{ PRED_LD
+ Word av;
+
+ /* Maybe Not needed */
+ if ( !hasGlobalSpace(0) )
+ { int rc;
+ if ( (rc=ensureGlobalSpace(0, ALLOW_GC)) != TRUE )
+ return raiseStackOverflow(rc);
+ }
+
+ deRef2(valTermRef(A1), av);
+ if (!isAttVar(*av) )
+ { return PL_error("attvar_bind_trail", 3, NULL, ERR_UNINSTANTIATION, 1, A1);
+ }
+
+ /* 3rd arg is for a little experiment */
+ if(!PL_get_nil(A3)) TrailAssignment(av);
+ *av = linkVal(valTermRef(A2));
+ return TRUE;
+}
+
/*******************************
* REGISTRATION *
@@ -1410,6 +1446,7 @@ BeginPredDefs(attvar)
PRED_DEF("$call_residue_vars_start", 0, call_residue_vars_start, 0)
PRED_DEF("$call_residue_vars_end", 0, call_residue_vars_end, 0)
#endif
+ PRED_DEF("attv_bind_trail", 3, attv_bind_trail, 0)
EndPredDefs
#endif /*O_ATTVAR*/
diff --git a/src/pl-funcs.h b/src/pl-funcs.h
index eb5ffab..d54c314 100644
--- a/src/pl-funcs.h
+++ b/src/pl-funcs.h
@@ -43,6 +43,8 @@ symbol lookup and relocations.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* pl-attvar.c */
+COMMON(void) registerWakeup(word functor, Word name, Word value ARG_LD);
+COMMON(int) find_attr(Word av, atom_t name, Word *vp ARG_LD);
COMMON(void) assignAttVar(Word av, Word value ARG_LD);
COMMON(int) saveWakeup(wakeup_state *state, int forceframe ARG_LD);
COMMON(void) restoreWakeup(wakeup_state *state ARG_LD);
diff --git a/src/pl-variant.c b/src/pl-variant.c
index 5526605..fc1d8ad 100644
--- a/src/pl-variant.c
+++ b/src/pl-variant.c
@@ -204,6 +204,11 @@ reset_terms(node * r)
{ *(r->bp) = r->orig;
}
+
+#ifndef ATTVAR_ISOMORPIC
+#define ATTVAR_ISOMORPIC
+#endif
+
/* isomorphic (==) */
static int
@@ -239,6 +244,17 @@ isomorphic(argPairs *a, int i, int j, Buffer buf ARG_LD)
wl = *l;
wr = *r;
+#ifdef ATTVAR_ISOMORPIC
+ if(tag(wr) == TAG_ATTVAR)
+ {
+ Word swap0 = l;
+ l = r;
+ r = swap0;
+ wl = *l;
+ wr = *r;
+ } else /*skip difference tests */
+
+#endif
if ( tag(wl) != tag(wr) )
return FALSE;
@@ -249,7 +265,21 @@ isomorphic(argPairs *a, int i, int j, Buffer buf ARG_LD)
}
if ( tag(wl) == TAG_ATTVAR )
- { l = valPAttVar(wl);
+ {
+#ifdef ATTVAR_ISOMORPIC
+ { Word vp;
+ if(find_attr(l,ATOM_references, &vp PASS_LD))
+ { registerWakeup(FUNCTOR_references3, l, r PASS_LD);
+ continue;
+ }}
+ if(!isAttVar(wr)) return FALSE;
+ { Word vp;
+ if(find_attr(r,ATOM_references, &vp PASS_LD))
+ { registerWakeup(FUNCTOR_references3, r, l PASS_LD);
+ continue;
+ }}
+#endif
+ l = valPAttVar(wl);
r = valPAttVar(wr);
goto attvar;
}
@@ -325,6 +355,12 @@ variant(argPairs *agenda, Buffer buf ARG_LD)
wl = *l;
wr = *r;
+ if(tag(*r) == TAG_ATTVAR)
+ {
+ Word swap0 = l;
+ l = r; wl = *l;
+ r = swap0; wr = *r;
+ } else /*skip difference tests */
if ( tag(wl) != tag(wr) )
return FALSE;
@@ -356,7 +392,20 @@ variant(argPairs *agenda, Buffer buf ARG_LD)
}
if ( tag(wl) == TAG_ATTVAR )
- { l = valPAttVar(wl);
+ {
+ { Word vp;
+ if(find_attr(l,ATOM_variant, &vp PASS_LD))
+ { registerWakeup(FUNCTOR_variant3, vp, r PASS_LD);
+ continue;
+ }}
+ if(!isAttVar(wr)) return FALSE;
+ { Word vp;
+ if(find_attr(r,ATOM_variant, &vp PASS_LD))
+ { registerWakeup(FUNCTOR_variant3, vp, l PASS_LD);
+ continue;
+ }}
+
+ l = valPAttVar(wl);
r = valPAttVar(wr);
goto attvar;
}
@@ -429,21 +478,41 @@ PRED_IMPL("=@=", 2, variant, 0)
Word p2 = valTermRef(A2);
node new = {NULL, 0, 0, 0}; /* dummy node as 0-th element*/
+attvar:
+
deRef(p1);
deRef(p2);
if ( *p1 == *p2 ) /* same term */
return TRUE;
+ if(tag(*p2) == TAG_ATTVAR)
+ {
+ Word swap0 = p2;
+ p2 = p1;
+ p1 = swap0;
+ } else /*skip difference tests */
if ( tag(*p1) != tag(*p2) ) /* different type */
return FALSE;
-again:
+/*again: not gone to anymore*/
switch(tag(*p1)) /* quick tests */
{ case TAG_VAR:
return TRUE;
case TAG_ATTVAR:
+ { Word vp;
+ if(find_attr(p1,ATOM_variant, &vp PASS_LD))
+ { registerWakeup(FUNCTOR_variant3, p1, p2 PASS_LD);
+ return TRUE;
+ }}
+ if(!isAttVar(*p2)) return FALSE;
+ { Word vp;
+ if(find_attr(p2,ATOM_variant, &vp PASS_LD))
+ { registerWakeup(FUNCTOR_variant3, p2, p1 PASS_LD);
+ return TRUE;
+ }}
+
p1 = valPAttVar(*p1);
p2 = valPAttVar(*p2);
- goto again;
+ goto attvar;
case TAG_ATOM:
return FALSE;
case TAG_INTEGER: