From a4a26478e02fbcf17ca4199102f8bb333175cff9 Mon Sep 17 00:00:00 2001 From: vsc Date: Wed, 13 Feb 2008 10:15:36 +0000 Subject: [PATCH] fix some bugs from yesterday plus improve support for modules in operators. git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@2095 b08c6af1-5177-4d33-ba66-4b1c6b8b522a --- C/init.c | 2 +- C/stdpreds.c | 47 ++++++++++++------ pl/arith.yap | 2 +- pl/modules.yap | 1 + pl/utils.yap | 130 +++++++++++++++++++++++++++++++++++++------------ 5 files changed, 133 insertions(+), 49 deletions(-) diff --git a/C/init.c b/C/init.c index 9cea478da..e7df97660 100644 --- a/C/init.c +++ b/C/init.c @@ -338,7 +338,7 @@ Yap_GetOp(OpEntry *pp, int *prio, int fix) else n = 4, *prio = p; } - return (Yap_LookupAtom(optypes[n])); + return Yap_LookupAtom(optypes[n]); } typedef struct OPSTRUCT { diff --git a/C/stdpreds.c b/C/stdpreds.c index 476808aa3..931ec9d1d 100644 --- a/C/stdpreds.c +++ b/C/stdpreds.c @@ -11,8 +11,12 @@ * File: stdpreds.c * * comments: General-purpose C implemented system predicates * * * -* Last rev: $Date: 2008-02-07 23:09:13 $,$Author: vsc $ * +* Last rev: $Date: 2008-02-13 10:15:35 $,$Author: vsc $ * * $Log: not supported by cvs2svn $ +* Revision 1.126 2008/02/07 23:09:13 vsc +* don't break ISO standard in current_predicate/1. +* Include Nicos flag. +* * Revision 1.125 2008/01/23 17:57:53 vsc * valgrind it! * enable atom garbage collection. @@ -2749,9 +2753,10 @@ static Int cont_current_op(void) { int prio; - Atom a = AtomOfTerm(EXTRA_CBACK_ARG(3,1)); - Int fix = IntOfTerm(EXTRA_CBACK_ARG(3,3)); + Atom a = AtomOfTerm(EXTRA_CBACK_ARG(4,1)); + Int fix = IntOfTerm(EXTRA_CBACK_ARG(4,3)); Term TType; + Term tmod; OpEntry *pp = NIL; /* fix hp gcc bug */ AtomEntry *at = RepAtom(a); @@ -2778,12 +2783,19 @@ cont_current_op(void) fix = 6; if (fix == 6 && pp->Infix == 0) fix = 7; + if (pp->OpModule == PROLOG_MODULE) + tmod = TermProlog; + else + tmod = pp->OpModule; READ_UNLOCK(pp->OpRWLock); - EXTRA_CBACK_ARG(3,3) = (CELL) MkIntTerm(fix); + EXTRA_CBACK_ARG(4,3) = (CELL) MkIntTerm(fix); if (fix < 7) return (Yap_unify_constant(ARG1, MkIntTerm(prio)) - && Yap_unify_constant(ARG2, TType)); - if (Yap_unify_constant(ARG1, MkIntTerm(prio)) && Yap_unify_constant(ARG2, TType)) + && Yap_unify_constant(ARG2, TType) + && Yap_unify_constant(ARG4, tmod)); + if (Yap_unify_constant(ARG1, MkIntTerm(prio)) + && Yap_unify_constant(ARG2, TType) + && Yap_unify_constant(ARG4, tmod)) cut_succeed(); else cut_fail(); @@ -2796,7 +2808,7 @@ cont_current_op(void) cut_fail(); } fix = 0; - EXTRA_CBACK_ARG(3,1) = (CELL) MkAtomTerm(at=RepAtom(a=pp->OpName)); + EXTRA_CBACK_ARG(4,1) = (CELL) MkAtomTerm(at=RepAtom(a=pp->OpName)); } READ_LOCK(pp->OpRWLock); if (fix == 0 && pp->Prefix == 0) @@ -2809,11 +2821,16 @@ cont_current_op(void) fix = 2; if (fix == 2 && pp->Infix == 0) fix = 3; + if (pp->OpModule == PROLOG_MODULE) + tmod = TermProlog; + else + tmod = pp->OpModule; READ_UNLOCK(pp->OpRWLock); - EXTRA_CBACK_ARG(3,3) = (CELL) MkIntTerm(fix); + EXTRA_CBACK_ARG(4,3) = (CELL) MkIntTerm(fix); return (Yap_unify_constant(ARG1, MkIntTerm(prio)) && Yap_unify_constant(ARG2, TType) && - Yap_unify_constant(ARG3, MkAtomTerm(a))); + Yap_unify_constant(ARG3, MkAtomTerm(a)) && + Yap_unify_constant(ARG4, tmod)); } static Int @@ -2861,15 +2878,15 @@ init_current_op(void) else cut_fail(); } - EXTRA_CBACK_ARG(3,1) = (CELL) MkAtomTerm(a); - EXTRA_CBACK_ARG(3,2) = (CELL) MkIntTerm(i); + EXTRA_CBACK_ARG(4,1) = (CELL) MkAtomTerm(a); + EXTRA_CBACK_ARG(4,2) = (CELL) MkIntTerm(i); if (IsVarTerm(top)) - EXTRA_CBACK_ARG(3,3) = (CELL) MkIntTerm(3); + EXTRA_CBACK_ARG(4,3) = (CELL) MkIntTerm(3); else if (IsAtomTerm(top)) - EXTRA_CBACK_ARG(3,3) = (CELL) MkIntTerm(4); + EXTRA_CBACK_ARG(4,3) = (CELL) MkIntTerm(4); else cut_fail(); - return (cont_current_op()); + return cont_current_op(); } #ifdef DEBUG @@ -3799,7 +3816,7 @@ Yap_InitBackCPreds(void) SafePredFlag|SyncPredFlag|HiddenPredFlag); Yap_InitCPredBack("$current_predicate_for_atom", 3, 1, init_current_predicate_for_atom, cont_current_predicate_for_atom, SafePredFlag|SyncPredFlag|HiddenPredFlag); - Yap_InitCPredBack("current_op", 3, 3, init_current_op, cont_current_op, + Yap_InitCPredBack("$current_op", 4, 3, init_current_op, cont_current_op, SafePredFlag|SyncPredFlag); #ifdef BEAM Yap_InitCPredBack("eam", 1, 0, start_eam, cont_eam, diff --git a/pl/arith.yap b/pl/arith.yap index 21bba6632..03c066652 100644 --- a/pl/arith.yap +++ b/pl/arith.yap @@ -38,7 +38,7 @@ do_not_compile_expressions :- set_value('$c_arith',[]). '$do_c_built_in'(G, M, OUT, MT) :- var(G), !, (MT = on -> NG = G ; NG = M:G), - '$do_c_built_in'(call(NG),M,OUT). + '$do_c_built_in'(call(NG), M, OUT, MT). '$do_c_built_in'(Mod:G, _, GN, MT) :- !, '$do_c_built_in'(G, Mod, GN0, MT), (GN0 = (_,_) -> GN = GN0 ; GN = Mod:GN0). diff --git a/pl/modules.yap b/pl/modules.yap index c2414fbbd..9037a9b6e 100644 --- a/pl/modules.yap +++ b/pl/modules.yap @@ -517,6 +517,7 @@ source_module(Mod) :- clause(:,?,?), compile(:), consult(:), + current_op(?,?,:), current_predicate(:), current_predicate(?,:), depth_bound_call(:,+), diff --git a/pl/utils.yap b/pl/utils.yap index 0a07d753a..13761beb7 100644 --- a/pl/utils.yap +++ b/pl/utils.yap @@ -226,43 +226,109 @@ call_cleanup(Goal, Catcher, Cleanup) :- '$execute'(Cleanup), !. '$clean_call'(_). -op(P,T,V) :- var(P), !, - '$do_error'(instantiation_error,op(P,T,V)). -op(P,T,V) :- \+integer(P), !, - '$do_error'(type_error(integer,P),op(P,T,V)). -op(P,T,V) :- (P < 0 ; P > 1200), !, - '$do_error'(domain_error(operator_priority,P),op(P,T,V)). -op(P,T,V) :- var(T), !, - '$do_error'(instantiation_error,op(P,T,V)). -op(P,T,V) :- \+atom(T), !, - '$do_error'(type_error(atom,T),op(P,T,V)). -op(P,T,V) :- var(V), !, - '$do_error'(instantiation_error,op(P,T,V)). op(P,T,V) :- - \+ atom(V), \+ '$check_list_of_operators'(V, op(P,T,V)), - '$do_error'(type_error(list,V),op(P,T,V)). -op(P,T,V) :- '$op2'(P,T,V). + '$check_op'(P,T,V,op(P,T,V)), + '$op'(P, T, V). -'$check_list_of_operators'(V, T) :- var(V), !, - '$do_error'(instantiation_error,T). -'$check_list_of_operators'([], _). -'$check_list_of_operators'([H|L], T) :- - '$check_if_operator'(H,T), - '$check_list_of_operators'(L, T). +'$check_op'(P,T,V,G) :- + ( + var(P) -> + '$do_error'(instantiation_error,G) + ; + var(T) -> + '$do_error'(instantiation_error,G) + ; + var(V) -> + '$do_error'(instantiation_error,G) + ; + \+ integer(P) -> + '$do_error'(type_error(integer,P),G) + ; + \+ atom(T) -> + '$do_error'(type_error(atom,T),G) + ; + P < 0 -> + '$do_error'(domain_error(out_of_range,P),G) + ; + P > 1200 -> + '$do_error'(domain_error(out_of_range,P),G) + ; + \+ '$associativity'(T) -> + '$do_error'(domain_error(operator_specifier,P),G) + ; + '$check_op_name'(V,G) + ). -'$check_if_operator'(H,T) :- var(H), !, - '$do_error'(instantiation_error,T). -'$check_if_operator'(H,_) :- atom(H), !. -'$check_if_operator'(H,T) :- - '$do_error'(type_error(atom,H),T). +'$associativity'(xfx). +'$associativity'(xfy). +'$associativity'(yfy). +'$associativity'(xf). +'$associativity'(yf). +'$associativity'(fx). +'$associativity'(fy). -'$op2'(_,_,[]) :- !. -'$op2'(P,T,[A|L]) :- !, '$op'(P,T,A), '$op2'(P,T,L). -'$op2'(P,T,A) :- atom(A), '$op'(P,T,A). + '$check_op_name'(V,_) :- + atom(V), !. + '$check_op_name'(M:A, G) :- + ( + var(M) -> + '$do_error'(instantiation_error,G) + ; + var(A) -> + '$do_error'(instantiation_error,G) + ; + \+ atom(A) -> + '$do_error'(instantiation_error,G) + ; + \+ atom(M) -> + '$do_error'(instantiation_error,G) + ; + true + ). + '$check_op_name'([A|As], G) :- + '$check_op_name'(A, G), + '$check_op_names'(As, G). -'$op'(P,T,',') :- !, - '$do_error'(permission_error(modify,operator,','),op(P,T,',')). -'$op'(P,T,A) :- '$opdec'(P,T,A,prolog). +'$check_op_names'([], _). +'$check_op_names'([A|As], G) :- + '$check_op_name'(A, G), + '$check_op_names'(As, G). + + +'$op'(P, T, A) :- + atom(A), !, + '$opdec'(P,T,A,prolog). +'$op'(P, T, user:A) :- !, + '$opdec'(P,T,A,prolog). +'$op'(P, T, M:A) :- + '$opdec'(P,T,A,M). +'$op'(_, _, []). +'$op'(P, T, [A|As]) :- + '$op'(P, T, A), + '$op'(P, T, As). + +current_op(X,Y,V) :- var(V), !, + '$current_module'(M), + V = M:Z, + '$do_current_op'(X,Y,Z,M). +current_op(X,Y,M:Z) :- !, + '$current_opm'(X,Y,Z,M). +current_op(X,Y,Z) :- + '$current_module'(M), + '$do_current_op'(X,Y,Z,M). + + +'$current_opm'(X,Y,Z,M) :- + var(Z), !, + '$do_current_op'(X,Y,Z,M). +'$current_opm'(X,Y,M:Z,_) :- !, + '$current_opm'(X,Y,Z,M). +'$current_opm'(X,Y,Z,M) :- + '$do_current_op'(X,Y,Z,M). + +'$do_current_op'(X,Y,Z,M) :- + '$current_op'(X,Y,Z,M1), + ( M1 = prolog -> true ; M1 = M ). %%% Operating System utilities