diff --git a/C/errors.c b/C/errors.c index 966506618..ba07a68c2 100755 --- a/C/errors.c +++ b/C/errors.c @@ -1250,30 +1250,25 @@ static Int is_atom(USES_REGS1) { } static Int must_be_callable(USES_REGS1) { - Term G = Deref(ARG1); + Term mod = CurrentModule; + Term G = Yap_StripModule(Deref(ARG1), &mod); // Term Context = Deref(ARG2); - while (true) { - if (IsVarTerm(G)) { - Yap_ThrowError(INSTANTIATION_ERROR, G, NULL); - return false; - } - if (IsApplTerm(G)) { - Functor f = FunctorOfTerm(G); - if (IsExtensionFunctor(f)) { - Yap_ThrowError(TYPE_ERROR_CALLABLE, G, NULL); - } - if (f == FunctorModule) { - Term tm = ArgOfTerm(1, G); - if (IsVarTerm(tm)) { - Yap_ThrowError(INSTANTIATION_ERROR, G, NULL); - return false; - } - if (!IsAtomTerm(tm)) { - Yap_ThrowError(TYPE_ERROR_CALLABLE, G, NULL); - return false; - } - G = ArgOfTerm(2, G); - } else { + if (IsVarTerm(mod)) { + Yap_ThrowError(INSTANTIATION_ERROR, G, NULL); + return false; + } else if (!IsAtomTerm(mod)) { + Yap_ThrowError(TYPE_ERROR_ATOM, mod, NULL); + return false; + } + if (IsVarTerm(G)) { + Yap_ThrowError(INSTANTIATION_ERROR, G, NULL); + return false; + } + if (IsApplTerm(G)) { + Functor f = FunctorOfTerm(G); + if (IsExtensionFunctor(f)) { + Yap_ThrowError(TYPE_ERROR_CALLABLE, G, NULL); + }else { return true; } } else if (IsPairTerm(G) || IsAtomTerm(G)) { @@ -1282,8 +1277,7 @@ static Int must_be_callable(USES_REGS1) { Yap_ThrowError(TYPE_ERROR_CALLABLE, G, NULL); return false; } - } - return false; + return true; } /** @@ -1301,51 +1295,51 @@ static Int must_be_callable(USES_REGS1) { * (mod:a)/n as valid. */ static Int get_predicate_indicator(USES_REGS1) { - Term G = Deref(ARG1); - // Term Context = Deref(ARG2); - Term mod = CurrentModule; + Term G = Deref(ARG1); + // Term Context = Deref(ARG2); + Term mod = CurrentModule; - G = Yap_YapStripModule(G, &mod); - if (IsVarTerm(G)) { - Yap_ThrowError(INSTANTIATION_ERROR, G, NULL); - } - if (!IsVarTerm(mod) && !IsAtomTerm(mod)) { - Yap_Error(TYPE_ERROR_ATOM, G, NULL); + G = Yap_YapStripModule(G, &mod); + if (IsVarTerm(G)) { + Yap_ThrowError(INSTANTIATION_ERROR, G, NULL); + } + if (!IsVarTerm(mod) && !IsAtomTerm(mod)) { + Yap_Error(TYPE_ERROR_ATOM, G, NULL); + return false; + } + if (IsApplTerm(G)) { + Functor f = FunctorOfTerm(G); + if (IsExtensionFunctor(f)) { + Yap_ThrowError(TYPE_ERROR_PREDICATE_INDICATOR, G, NULL); + } + if (f == FunctorSlash || f == FunctorDoubleSlash) { + Term name = ArgOfTerm(1, G), arity = ArgOfTerm(2, G); + name = Yap_YapStripModule(name, &mod); + if (IsVarTerm(name)) { + Yap_ThrowError(INSTANTIATION_ERROR, name, NULL); + } else if (!IsAtomTerm(name)) { + Yap_ThrowError(TYPE_ERROR_ATOM, name, NULL); + } + if (IsVarTerm(arity)) { + Yap_ThrowError(INSTANTIATION_ERROR, arity, NULL); + } else if (!IsIntegerTerm(arity)) { + Yap_ThrowError(TYPE_ERROR_INTEGER, arity, NULL); + } else { + Int ar = IntegerOfTerm(arity); + if (ar < 0) { + Yap_ThrowError(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, arity, NULL); + } + if (f == FunctorDoubleSlash) { + arity = MkIntegerTerm(ar + 2); + } + return Yap_unify(mod, ARG2) && + Yap_unify(name, ARG3) && + Yap_unify(arity, ARG4); + } + } + } + Yap_ThrowError(TYPE_ERROR_PREDICATE_INDICATOR, G, NULL); return false; - } - if (IsApplTerm(G)) { - Functor f = FunctorOfTerm(G); - if (IsExtensionFunctor(f)) { - Yap_ThrowError(TYPE_ERROR_PREDICATE_INDICATOR, G, NULL); - } - if (f == FunctorSlash || f == FunctorDoubleSlash) { - Term name = ArgOfTerm(1,G), arity = ArgOfTerm(2,G); - name = Yap_YapStripModule (name, &mod); - if (IsVarTerm(name)) { - Yap_ThrowError(INSTANTIATION_ERROR, name, NULL); - } else if (!IsAtomTerm(name)) { - Yap_ThrowError(TYPE_ERROR_ATOM, name, NULL); - } - if (IsVarTerm(arity)) { - Yap_ThrowError(INSTANTIATION_ERROR, arity, NULL); - } else if (!IsIntegerTerm(arity)) { - Yap_ThrowError(TYPE_ERROR_INTEGER, arity, NULL); - } else { - Int ar = IntegerOfTerm(arity); - if (ar < 0) { - Yap_ThrowError(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, arity, NULL); - } - if ( f == FunctorDoubleSlash) { - arity = MkIntegerTerm(ar+2); - } - return Yap_unify(mod, ARG2) && - Yap_unify(name, ARG3) && - Yap_unify(arity, ARG4); - } - } - } - Yap_ThrowError(TYPE_ERROR_PREDICATE_INDICATOR, G, NULL); - return false; } void Yap_InitErrorPreds(void) { @@ -1360,7 +1354,7 @@ void Yap_InitErrorPreds(void) { Yap_InitCPred("$drop_exception", 1, drop_exception, 0); Yap_InitCPred("$close_error", 0, close_error, HiddenPredFlag); Yap_InitCPred("is_boolean", 1, is_boolean, TestPredFlag); - Yap_InitCPred("must_be_callable", 1, must_be_callable, TestPredFlag); + Yap_InitCPred("must_be_callable", 1, must_be_callable, TestPredFlag); Yap_InitCPred("is_atom", 1, is_atom, TestPredFlag); Yap_InitCPred("get_predicate_indicator", 4, get_predicate_indicator, 0); } diff --git a/C/stdpreds.c b/C/stdpreds.c index 9e87d82a7..3fbd44016 100755 --- a/C/stdpreds.c +++ b/C/stdpreds.c @@ -1574,7 +1574,6 @@ void Yap_InitCPreds(void) { Yap_InitCmpPreds(); Yap_InitCoroutPreds(); Yap_InitDBPreds(); - Yap_InitErrorPreds(); Yap_InitExecFs(); Yap_InitGlobals(); Yap_InitInlines(); diff --git a/C/write.c b/C/write.c index df559f901..2cef5244f 100644 --- a/C/write.c +++ b/C/write.c @@ -77,25 +77,9 @@ typedef struct write_globs { UInt last_atom_minus; UInt MaxDepth, MaxArgs; wtype lw; - CELL *visited, *visited0, *visited_max; + CELL *visited, *visited0, *visited_top; } wglbs; -static inline bool was_visited(Term t, wglbs *wg) { - if (IsApplTerm(t)) tp = RepAppl(tp); - else if (IsPairTerm(t)) tp = RepPair(t); - else return false; - bool rc = IsVarTerm(t) && (CELL *) t >= wg->visited0 - && (CELL *) t < wg->visited_max; - wg->visited = *t; - *t = wg->visited++; -}} - - - -static inline void done_visit(Term *t, wglbs *wg) { - *t = *--wg->visited++; -} - #define lastw wglb->lw #define last_minus wglb->last_atom_minus @@ -426,6 +410,51 @@ static void wrputref(CODEADDR ref, int Quote_illegal, lastw = alphanum; } + +static inline bool was_visited(Term t, wglbs *wg, Term *ta ) { + Term *tp; + if (IsApplTerm(t)) { + if (IsExtensionFunctor(FunctorOfTerm(t))) + return false; + tp = RepAppl(t); + } + else if (IsPairTerm(t)) tp = RepPair(t); + else return false; + if (IsAtomTerm(*tp)) { + CELL *pt= (CELL*)AtomOfTerm(*tp); + if (pt >= wg->visited0 && + pt < wg->visited) { + int depth = (wg->visited+1)-tp; + wrputs(" @( ", wg->stream); + wrputn(depth, wg); + wrputs( " ) ", wg->stream); + return true; + } + } + wg->visited[0] = *tp; + *tp = MkAtomTerm( (Atom)wg->visited ); + wg++; + + return false; +} + +static inline Term visited_indirection(Term t, wglbs *wg ) { + Term *tp = (CELL *)AtomOfTerm(t); + if (tp >= wg->visited0 + && (CELL *) *tp < wg->visited_top) + return *tp; + return 0; +} + +static inline void done_visiting(Term t, wglbs *wg) { + Term *tp; + if (IsApplTerm(t)) tp = RepAppl(t); + else if (IsPairTerm(t)) tp = RepPair(t); + else return; + *tp = *--wg->visited; +} + + /* writes a blob (default) */ static int wrputblob(AtomEntry *ref, int Quote_illegal, struct write_globs *wglb) { @@ -748,13 +777,14 @@ static void write_list(Term t, int direction, int depth, struct rewind_term nrwt; nrwt.parent = rwt; nrwt.u_sd.s.ptr = 0; - - if (is_visited(t, wglb)) { - wrputs(".."wglb->stream); +Term hot; + if (was_visited(t, wglb, &hot)) { + return; } - if (1) { - - PROTECT(t, writeTerm(HeadOfTerm(t), 999, depth + 1, FALSE, wglb, &nrwt)); + bool loop = true; + while (loop) { +loop = false; + PROTECT(t, writeTerm(hot, 999, depth + 1, FALSE, wglb, &nrwt)); ti = TailOfTerm(t); if (IsVarTerm(ti)) break; @@ -806,18 +836,27 @@ static void writeTerm(Term t, int p, int depth, int rinfixarg, if (IsVarTerm(t)) { write_var((CELL *)t, wglb, &nrwt); } else if (IsIntTerm(t)) { - wrputn((Int)IntOfTerm(t), wglb); } else if (IsAtomTerm(t)) { + Term tn; + if ((tn = visited_indirection(t, wglb))!=0) { + writeTerm(tn,p,depth,rinfixarg,wglb,rwt); + return; + } putAtom(AtomOfTerm(t), wglb->Quote_illegal, wglb); } else if (IsPairTerm(t)) { if (wglb->Ignore_ops) { wrputs("'.'(", wglb->stream); lastw = separator; + Term hot; +if ((was_visited(t, wglb, &hot))) { + return; +} - PROTECT(t, writeTerm(HeadOfTerm(t), 999, depth + 1, FALSE, wglb, &nrwt)); + PROTECT(t, writeTerm(hot, 999, depth + 1, FALSE, wglb, &nrwt)); wrputs(",", wglb->stream); writeTerm(TailOfTerm(t), 999, depth + 1, FALSE, wglb, &nrwt); + done_visiting(t, wglb); wrclose_bracket(wglb, TRUE); return; } @@ -897,7 +936,12 @@ static void writeTerm(Term t, int p, int depth, int rinfixarg, return; } } - if (!wglb->Ignore_ops && Arity == 1 && Yap_IsPrefixOp(atom, &op, &rp)) { + Term argf; + if (was_visited(t, wglb, &argf)) { + return; + } + + if (!wglb->Ignore_ops && Arity == 1 && Yap_IsPrefixOp(atom, &op, &rp)) { Term tright = ArgOfTerm(1, t); int bracket_right = !IsVarTerm(tright) && IsAtomTerm(tright) && Yap_IsOp(AtomOfTerm(tright)); @@ -1029,6 +1073,7 @@ static void writeTerm(Term t, int p, int depth, int rinfixarg, if (k == -1) { wrputc('_', wglb->stream); lastw = alphanum; + done_visiting(t, wglb); return; } else { wrputc((k % 26) + 'A', wglb->stream); @@ -1100,6 +1145,7 @@ static void writeTerm(Term t, int p, int depth, int rinfixarg, writeTerm(ArgOfTerm(op, t), 999, depth + 1, FALSE, wglb, &nrwt); wrclose_bracket(wglb, TRUE); } + done_visiting(t, wglb); } } @@ -1132,9 +1178,9 @@ void Yap_plwrite(Term t, StreamDesc *mywrite, int max_depth, int flags, if ((flags & Handle_cyclics_f) ){ // tp = Yap_CyclesInTerm(t PASS_REGS); - wglb.visited = MĖ€alloc(1024*sizeof(CELL)), - wglb.visited0 = visited, - wglb.visitedt_top = visited+1024; + wglb.visited = Malloc(1024*sizeof(CELL)), + wglb.visited0 = wglb.visited, + wglb.visited_top = wglb.visited+1024; } else { tp = t; } diff --git a/pl/arith.yap b/pl/arith.yap index 65562ce0e..0596765c1 100644 --- a/pl/arith.yap +++ b/pl/arith.yap @@ -133,7 +133,7 @@ do_c_built_in(G1, M1, H, OUT) :- do_c_built_in('$do_error'( Error, Goal), M, Head, throw(error(Error,[errorGoal=Goal, errorCaller=Head,prologPredFile=File,prologPredLine=Line, prologPredModule=M,prologPredName=Name,prologPredArity=Ar]))) - ) :- + :- !,source_location(File, Line). do_c_built_in(system_error( Error, Goal), M, Head, ErrorG) :- !, diff --git a/pl/error.yap b/pl/error.yap index 885adcaa0..169474cbb 100644 --- a/pl/error.yap +++ b/pl/error.yap @@ -335,7 +335,6 @@ must_be_instantiated(X, Comment) :- inline(must_be_of_type( atom, X ), is_atom(X) ). inline(must_be_of_type( module, X ), is_atom(X) ). -inline(must_be_of_type( callable, X ), must_be_callable(X) ). inline(must_be_atom( X ), is_atom(X) ). inline(must_be_module( X ), is_atom(X) ).