From 79a154cbf47dd20c257e631f55ae09971969d4b4 Mon Sep 17 00:00:00 2001 From: Vitor Santos Costa Date: Tue, 2 Aug 2016 11:34:58 -0500 Subject: [PATCH] fix current_predicate/1 and arg/3 --- C/cdmgr.c | 6 ++-- C/inlines.c | 3 +- C/prim_absmi_insts.h | 32 +++++++++++----------- pl/error.yap | 65 ++++++++++++++++++++++++++++++++++++++++++++ pl/preds.yap | 42 ++++++++++++++-------------- 5 files changed, 109 insertions(+), 39 deletions(-) diff --git a/C/cdmgr.c b/C/cdmgr.c index 02ea2fc30..323c50844 100644 --- a/C/cdmgr.c +++ b/C/cdmgr.c @@ -138,8 +138,10 @@ restart: goto restart; } return RepPredProp(Yap_GetPredPropByFunc(fun, tmod)); - } else - return NULL; + } else { + Yap_Error(TYPE_ERROR_CALLABLE, t0, pname); + } + return NULL; } /** Look for a predicate with same functor as t, diff --git a/C/inlines.c b/C/inlines.c index dff18a0d5..16d2eada0 100644 --- a/C/inlines.c +++ b/C/inlines.c @@ -665,6 +665,7 @@ p_arg( USES_REGS1 ) pt0 = RepAppl(d1); d1 = *pt0; if (IsExtensionFunctor((Functor) d1)) { + Yap_Error(TYPE_ERROR_COMPOUND, d1, "arg 2 of arg/3"); return(FALSE); } save_hb(); @@ -708,7 +709,7 @@ p_arg( USES_REGS1 ) ENDP(pt0); } else { - /* Yap_Error(TYPE_ERROR_COMPOUND, d1, "arg 2 of arg/3"); */ + Yap_Error(TYPE_ERROR_COMPOUND, d1, "arg 2 of arg/3"); return(FALSE); } diff --git a/C/prim_absmi_insts.h b/C/prim_absmi_insts.h index bb74e9174..419bb48cf 100644 --- a/C/prim_absmi_insts.h +++ b/C/prim_absmi_insts.h @@ -2390,6 +2390,9 @@ pt0 = RepAppl(d1); d1 = *pt0; if (IsExtensionFunctor((Functor) d1)) { + saveregs(); + Yap_Error(TYPE_ERROR_COMPOUND, d1, "arg 2 of arg/3"); + setregs(); FAIL(); } if ((Int)d0 <= 0 || @@ -2427,12 +2430,9 @@ ENDP(pt0); } else { - /* - don't complain here for SWI Prolog compatibility saveregs(); Yap_Error(TYPE_ERROR_COMPOUND, d1, "arg 2 of arg/3"); setregs(); - */ FAIL(); } @@ -2481,6 +2481,9 @@ pt0 = RepAppl(d1); d1 = *pt0; if (IsExtensionFunctor((Functor) d1)) { + saveregs(); + Yap_Error(TYPE_ERROR_COMPOUND, d1, "arg 2 of arg/3"); + setregs(); FAIL(); } if ((Int)d0 <= 0 || @@ -2518,12 +2521,9 @@ ENDP(pt0); } else { - /* - keep SWI Prolog compatibility, just fail on trying to obtain an argument of a compound term. - saveregs(); - Yap_Error(TYPE_ERROR_COMPOUND, d1, "arg 2 of arg/3"); - setregs(); - */ + saveregs(); + Yap_Error(TYPE_ERROR_COMPOUND, d1, "arg 2 of arg/3"); + setregs(); FAIL(); } @@ -2579,6 +2579,9 @@ pt0 = RepAppl(d1); d1 = *pt0; if (IsExtensionFunctor((Functor) d1)) { + saveregs(); + Yap_Error(TYPE_ERROR_COMPOUND, d1, "arg 2 of arg/3"); + setregs(); FAIL(); } if ((Int)d0 <= 0 || @@ -2622,12 +2625,9 @@ ENDP(pt0); } else { - /* - don't complain here for SWI Prolog compatibility saveregs(); Yap_Error(TYPE_ERROR_COMPOUND, d1, "arg 2 of arg/3"); setregs(); - */ FAIL(); } @@ -2677,7 +2677,10 @@ pt0 = RepAppl(d1); d1 = *pt0; if (IsExtensionFunctor((Functor) d1)) { - FAIL(); + saveregs(); + Yap_Error(TYPE_ERROR_COMPOUND, d1, "arg 2 of arg/3"); + setregs(); + FAIL(); } if ((Int)d0 <= 0 || (Int)d0 > ArityOfFunctor((Functor) d1)) { @@ -2720,12 +2723,9 @@ ENDP(pt0); } else { - /* - don't complain here for SWI Prolog compatibility saveregs(); Yap_Error(TYPE_ERROR_COMPOUND, d1, "arg 2 of arg/3"); setregs(); - */ FAIL(); } diff --git a/pl/error.yap b/pl/error.yap index 49a5188a5..c896a5317 100644 --- a/pl/error.yap +++ b/pl/error.yap @@ -18,6 +18,7 @@ existence_error/2, % +Type, +Term permission_error/3, % +Action, +Type, +Term must_be_instantiated/1, % +Term + must_bind_to_type/2, % +Type, ?Term instantiation_error/1, % +Term representation_error/1, % +Reason is_of_type/2 % +Type, +Term @@ -139,6 +140,12 @@ must_be_of_type(Type, X, _Comment) :- ; is_not(Type, X) ). +must_bind_to_type(Type, X) :- + ( may_bind_to_type(Type, X), writeln(X) + -> true + ; is_not(Type, X) + ). + %% @predicate is_not(+Type, @Term) % % Throws appropriate error. It is _known_ that Term is not of type @@ -237,6 +244,64 @@ has_type(string, X) :- string(X). has_type(stream, X) :- is_stream(X). has_type(list(Type), X) :- is_list(X), element_types(X, Type). +%% may_bind_to_type(+Type, @Term) is semidet. +% +% True if _Term_ or term _Term\theta_ satisfies _Type_. + +may_bind_to_type(_, X ) :- var(X), !. +may_bind_to_type(impossible, _) :- instantiation_error(_). +may_bind_to_type(any, _). +may_bind_to_type(atom, X) :- atom(X). +may_bind_to_type(atomic, X) :- atomic(X). +may_bind_to_type(between(L,U), X) :- ( integer(L) + -> integer(X), between(L,U,X) + ; number(X), X >= L, X =< U + ). +may_bind_to_type(boolean, X) :- (X==true;X==false), !. +may_bind_to_type(callable, X) :- callable(X). +may_bind_to_type(chars, X) :- chars(X). +may_bind_to_type(codes, X) :- codes(X). +may_bind_to_type(text, X) :- text(X). +may_bind_to_type(compound, X) :- compound(X). +may_bind_to_type(constant, X) :- atomic(X). +may_bind_to_type(float, X) :- float(X). +may_bind_to_type(ground, X) :- ground(X). +may_bind_to_type(integer, X) :- integer(X). +may_bind_to_type(nonneg, X) :- integer(X), X >= 0. +may_bind_to_type(positive_integer, X) :- integer(X), X > 0. +may_bind_to_type(negative_integer, X) :- integer(X), X < 0. +may_bind_to_type(predicate_indicator, X) :- + ( + X = M:PI + -> + may_bind_to_type( atom, M), + may_bind_to_type(predicate_indicator, PI) + ; + X = N/A + -> + may_bind_to_type( atom, N), + may_bind_to_type(integer, A) + ; + X = N//A + -> + may_bind_to_type( atom, N), + may_bind_to_type(integer, A) + ). + + +may_bind_to_type(nonvar, _X). +may_bind_to_type(number, X) :- number(X). +may_bind_to_type(oneof(L), X) :- ground(X), lists:memberchk(X, L). +may_bind_to_type(proper_list, X) :- is_list(X). +may_bind_to_type(list, X) :- is_list(X). +may_bind_to_type(list_or_partial_list, X) :- is_list_or_partial_list(X). +may_bind_to_type(symbol, X) :- atom(X). +may_bind_to_type(var, X) :- var(X). +may_bind_to_type(rational, X) :- rational(X). +may_bind_to_type(string, X) :- string(X). +may_bind_to_type(stream, X) :- is_stream(X). +may_bind_to_type(list(Type), X) :- is_list(X), element_types(X, Type). + chars(0) :- !, fail. chars([]). chars([H|T]) :- diff --git a/pl/preds.yap b/pl/preds.yap index f8346970a..51f6a63d9 100644 --- a/pl/preds.yap +++ b/pl/preds.yap @@ -674,7 +674,7 @@ system_predicate(A, P0) :- /** - @pred current_predicate( _F_) is iso + @pred current_predicate( F ) is iso True if _F_ is the predicate indicator for a currently defined user or library predicate.The indicator _F_ is of the form _Mod_:_Na_/_Ar_ or _Na/Ar_, @@ -683,32 +683,34 @@ system_predicate(A, P0) :- */ current_predicate(F0) :- '$yap_strip_module'(F0, M, F), - '$c_i_predicate'( F, M ). + must_bind_to_type( predicate_indicator, F ), + '$c_i_predicate'( F, M ). '$c_i_predicate'( A/N, M ) :- - !, - ( nonvar(A), nonvar(N) -> - functor(S, A, N), + !, + ( + ground(A/N) + -> + atom(A), integer(N), + functor(S, A, N), current_predicate(A, M:S) ; - current_predicate(A, M:S), - functor(S, A, N) - ). + current_predicate(A, M:S), + functor(S, A, N) + ). '$c_i_predicate'( A//N, M ) :- - !, - ( nonvar(A), nonvar(N) -> - N2 is N+2, - functor(S, A, N2), + ( + ground(A) + -> + atom(A), integer(N), + N2 is N+2, + functor(S, A, N2), current_predicate(A, M:S) ; - current_predicate(A, M:S), - functor(S, A, N2), - N is N-2 - ). -'$c_i_predicate'( F, M ) :- - '$do_error'(type_error(predicate_indicator,F), - current_predicate(M:F)). - + current_predicate(A, M:S), + functor(S, A, N2), + N is N2-2 + ). '$imported_predicate'(A, G, ImportingMod, G, Flags) :- '$get_undefined_pred'(G, ImportingMod, G0, ExportingMod),