diff --git a/C/c_interface.c b/C/c_interface.c index 4ff55d9d6..eef287b9f 100755 --- a/C/c_interface.c +++ b/C/c_interface.c @@ -2054,7 +2054,6 @@ YAP_RestartGoal(void) { int out; BACKUP_MACHINE_REGS(); - if (Yap_AllowRestart) { P = (yamop *)FAILCODE; do_putcf = myputc; @@ -2650,6 +2649,8 @@ YAP_Init(YAP_init_args *yap_init) /* first, initialise the saved state */ Term t_goal = MkAtomTerm(AtomStartupSavedState); YAP_RunGoalOnce(t_goal); + Yap_InitYaamRegs(); + /* reset stacks */ return YAP_BOOT_FROM_SAVED_CODE; } else { return YAP_BOOT_FROM_SAVED_STACKS; @@ -2681,6 +2682,8 @@ YAP_Init(YAP_init_args *yap_init) fgoal = Yap_MkFunctor(Yap_LookupAtom("module"), 1); goal = Yap_MkApplTerm(fgoal, 1, as); YAP_RunGoalOnce(goal); + /* reset stacks */ + Yap_InitYaamRegs(); } Yap_PutValue(Yap_FullLookupAtom("$live"), MkAtomTerm (Yap_FullLookupAtom("$true"))); } diff --git a/C/cdmgr.c b/C/cdmgr.c index b8c7cd038..46cc99f1e 100644 --- a/C/cdmgr.c +++ b/C/cdmgr.c @@ -507,8 +507,6 @@ STATIC_PROTO(Int p_new_multifile, (void)); STATIC_PROTO(Int p_is_multifile, (void)); STATIC_PROTO(Int p_optimizer_on, (void)); STATIC_PROTO(Int p_optimizer_off, (void)); -STATIC_PROTO(Int p_in_this_f_before, (void)); -STATIC_PROTO(Int p_first_cl_in_f, (void)); STATIC_PROTO(Int p_is_dynamic, (void)); STATIC_PROTO(Int p_kill_dynamic, (void)); STATIC_PROTO(Int p_compile_mode, (void)); @@ -2431,80 +2429,6 @@ Yap_add_logupd_clause(PredEntry *pe, LogUpdClause *cl, int mode) { } } -static Int -p_in_this_f_before(void) -{ /* '$in_this_file_before'(N,A,M) */ - unsigned int arity; - Atom at; - Term t; - register consult_obj *fp; - Prop p0; - Term mod; - - if (IsVarTerm(t = Deref(ARG1)) || !IsAtomTerm(t)) - return (FALSE); - else - at = AtomOfTerm(t); - if (IsVarTerm(t = Deref(ARG2)) || !IsIntTerm(t)) - return (FALSE); - else - arity = IntOfTerm(t); - if (IsVarTerm(mod = Deref(ARG3)) || !IsAtomTerm(mod)) - return FALSE; - if (arity) - p0 = PredPropByFunc(Yap_MkFunctor(at, arity), mod); - else - p0 = PredPropByAtom(at, mod); - if (!ConsultSp || ConsultSp == ConsultBase || LastAssertedPred == RepPredProp(p0) || (fp = ConsultSp)->p == p0) - return FALSE; - else - fp++; - for (; fp < ConsultBase; ++fp) - if (fp->p == p0) - break; - if (fp != ConsultBase) - return TRUE; - else - return FALSE; -} - -static Int -p_first_cl_in_f(void) -{ /* '$first_cl_in_file'(+N,+Ar,+Mod) */ - unsigned int arity; - Atom at; - Term t; - register consult_obj *fp; - Prop p0; - Term mod; - - - if (IsVarTerm(t = Deref(ARG1)) || !IsAtomTerm(t)) - return (FALSE); - else - at = AtomOfTerm(t); - if (IsVarTerm(t = Deref(ARG2)) || !IsIntTerm(t)) - return (FALSE); - else - arity = IntOfTerm(t); - if (IsVarTerm(mod = Deref(ARG3)) || !IsAtomTerm(mod)) - return (FALSE); - if (arity) - p0 = PredPropByFunc(Yap_MkFunctor(at, arity),mod); - else - p0 = PredPropByAtom(at, mod); - if (LastAssertedPred == RepPredProp(p0)) - return FALSE; - if (!ConsultSp) - return FALSE; - for (fp = ConsultSp; fp < ConsultBase; ++fp) - if (fp->p == p0) - break; - if (fp != ConsultBase) - return FALSE; - return TRUE; -} - #if EMACS /* @@ -5732,8 +5656,6 @@ Yap_InitCdMgr(void) Yap_InitCPred("$clean_up_dead_clauses", 0, p_clean_up_dead_clauses, SyncPredFlag|HiddenPredFlag); Yap_InitCPred("$optimizer_off", 0, p_optimizer_off, SafePredFlag|SyncPredFlag|HiddenPredFlag); Yap_InitCPred("$kill_dynamic", 2, p_kill_dynamic, SafePredFlag|SyncPredFlag|HiddenPredFlag); - Yap_InitCPred("$in_this_file_before", 3, p_in_this_f_before, SafePredFlag|HiddenPredFlag); - Yap_InitCPred("$first_clause_in_file", 3, p_first_cl_in_f, SafePredFlag|HiddenPredFlag); Yap_InitCPred("$new_multifile", 3, p_new_multifile, SafePredFlag|SyncPredFlag|HiddenPredFlag); Yap_InitCPred("$is_multifile", 2, p_is_multifile, TestPredFlag | SafePredFlag|HiddenPredFlag); Yap_InitCPred("$is_profiled", 1, p_is_profiled, SafePredFlag|SyncPredFlag|HiddenPredFlag); diff --git a/C/exec.c b/C/exec.c index 418a6721a..7850e88f5 100644 --- a/C/exec.c +++ b/C/exec.c @@ -1002,6 +1002,8 @@ exec_absmi(int top) Yap_PrologMode = UserMode; } Yap_CloseSlots(); + YENV = ASP; + YENV[E_CB] = Unsigned (B); out = Yap_absmi(0); Yap_StartSlots(); /* make sure we don't leave a FAIL signal hanging around */ @@ -1054,9 +1056,9 @@ init_stack(int arity, CELL *pt, int top, choiceptr saved_b) #if defined(YAPOR) || defined(THREADS) WPP = NULL; #endif - YENV[E_CB] = Unsigned (B); - CP = YESCODE; + /* start with some slots so that we can use them */ Yap_StartSlots(); + CP = YESCODE; } static Term @@ -1639,6 +1641,7 @@ Yap_InitYaamRegs(void) EX = NULL; init_stack(0, NULL, TRUE, NULL); /* the first real choice-point will also have AP=FAIL */ + /* always have an empty slots for people to use */ CurSlot = 0; GlobalArena = TermNil; h0var = MkVarTerm(); diff --git a/H/iatoms.h b/H/iatoms.h index 7d0ac0618..72d86fc02 100644 --- a/H/iatoms.h +++ b/H/iatoms.h @@ -162,7 +162,7 @@ AtomMfClause = Yap_FullLookupAtom("$mf_clause"); AtomMinus = Yap_LookupAtom("-"); AtomModify = Yap_LookupAtom("modify"); - AtomMultiFile = Yap_FullLookupAtom("$multi_file"); + AtomMultiFile = Yap_FullLookupAtom("$mf"); AtomMutable = Yap_LookupAtom("mutable"); AtomMutableVariable = Yap_FullLookupAtom("$mutable_variable"); AtomMyddasDB = Yap_FullLookupAtom("$myddas_db"); diff --git a/library/dialect/swi.yap b/library/dialect/swi.yap index a31997aa7..13b2d444b 100755 --- a/library/dialect/swi.yap +++ b/library/dialect/swi.yap @@ -189,7 +189,9 @@ goal_expansion(open_null_stream(A), system:swi_open_null_stream(A)) :- swi_io. /* SWI specific */ goal_expansion(is_stream(A), system:swi_is_stream(A)) :- swi_io. goal_expansion(set_stream(A,B),system:swi_set_stream(A,B)) :- swi_io. -goal_expansion(with_output_to(A,B),system:swi_with_output_to(A,B)) :- swi_io. +% careful: with_output_to/2 requires setting user_output, and this +% confuses emulation. +goal_expansion(with_output_to(A,B),with_output_to(A,B)) :- swi_io. goal_expansion(set_prolog_IO(A,B,C), system:swi_set_prolog_IO(A,B,C)) :- swi_io. goal_expansion(protocol(A), system:swi_protocol(A)) :- swi_io. goal_expansion(protocola(A), system:swi_protocola(A)) :- swi_io. diff --git a/library/dialect/swi/fli/swi.c b/library/dialect/swi/fli/swi.c index fd4a45264..7b195b6eb 100755 --- a/library/dialect/swi/fli/swi.c +++ b/library/dialect/swi/fli/swi.c @@ -478,11 +478,7 @@ X_API int PL_get_chars(term_t l, char **sp, unsigned flags) } else { if (!(flags & (CVT_INTEGER|CVT_NUMBER|CVT_ATOMIC|CVT_WRITE|CVT_WRITE_CANONICAL|CVT_ALL))) return cv_error(flags); -#if _WIN64 - snprintf(tmp,SWI_BUF_SIZE,"%I64d",IntegerOfTerm(t)); -#else - snprintf(tmp,SWI_BUF_SIZE,"%ld",IntegerOfTerm(t)); -#endif + snprintf(tmp,SWI_BUF_SIZE,Int_FORMAT,IntegerOfTerm(t)); } } else if (IsPairTerm(t)) { if (!(flags & (CVT_LIST|CVT_WRITE|CVT_WRITE_CANONICAL|CVT_ALL))) { @@ -2578,12 +2574,7 @@ X_API qid_t PL_open_query(module_t ctx, int flags, predicate_t p, term_t t0) Term t[2], m; /* ignore flags and module for now */ - if (execution == NULL) - PL_open_foreign_frame(); - if (execution->open != 0) { - YAP_Error(0, 0L, "only one query at a time allowed\n"); - return FALSE; - } + PL_open_foreign_frame(); execution->open=1; execution->state=0; PredicateInfo((PredEntry *)p, &yname, &arity, &m); @@ -2617,13 +2608,13 @@ X_API qid_t PL_open_query(module_t ctx, int flags, predicate_t p, term_t t0) X_API int PL_next_solution(qid_t qi) { int result; - if (qi->open != 1) return 0; if (setjmp(execution->env)) return 0; if (qi->state == 0) { result = YAP_RunGoal(qi->g); } else { + Yap_AllowRestart = qi->open; result = YAP_RestartGoal(); } qi->state = 1; @@ -2894,6 +2885,7 @@ PL_set_engine(PL_engine_t engine, PL_engine_t *old) } return PL_ENGINE_SET; #else + if (old) *old = (PL_engine_t)&Yap_WLocal; return FALSE; #endif } diff --git a/misc/ATOMS b/misc/ATOMS index 27bd9d6c0..5d696abae 100644 --- a/misc/ATOMS +++ b/misc/ATOMS @@ -167,7 +167,7 @@ A MetaCall F "$call" A MfClause F "$mf_clause" A Minus N "-" A Modify N "modify" -A MultiFile F "$multi_file" +A MultiFile F "$mf" A Mutable N "mutable" A MutableVariable F "$mutable_variable" A MyddasDB F "$myddas_db" diff --git a/pl/boot.yap b/pl/boot.yap index bbe4e19a3..eac15a1b2 100755 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -461,14 +461,14 @@ true :- true. '$$compile'(G1, G0, N, HeadMod). '$prepare_term'(G, V, Pos, G0, G1, BodyMod, SourceMod, Source) :- - '$precompile_term'(G, G0, G1, BodyMod, SourceMod), ( get_value('$syntaxcheckflag',on) -> - '$check_term'(G0, V, Pos, Source, BodyMod) + '$check_term'(Source, V, Pos, BodyMod) ; true - ). + ), + '$precompile_term'(G, G0, G1, BodyMod, SourceMod). % process an input clause '$$compile'(G, G0, L, Mod) :- diff --git a/pl/checker.yap b/pl/checker.yap index 3405c2b17..6e52d9a53 100644 --- a/pl/checker.yap +++ b/pl/checker.yap @@ -106,7 +106,6 @@ no_style_check([]). no_style_check([H|T]) :- no_style_check(H), no_style_check(T). - '$syntax_check_mode'(O,N) :- '$values'('$syntaxcheckflag',O,N). @@ -119,55 +118,78 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T). '$syntax_check_multiple'(O,N) :- '$values'('$syntaxcheckmultiple',O,N). +% reset current state of style checker. +'$init_style_check'(File) :- + recorded('$predicate_defs','$predicate_defs'(_,_,_,File),R), + erase(R), + fail. +'$init_style_check'(_). -'$check_term'(T,_,P,_Source,M) :- +% style checker proper.. +'$check_term'(T,VL,P,_) :- + get_value('$syntaxchecksinglevar',on), + '$singletons_in_clause'(T, VL, Sv), + Sv = [_|_], + '$sv_warning'(Sv,T), + fail. +'$check_term'(T,_,P,M) :- get_value('$syntaxcheckdiscontiguous',on), '$xtract_head'(T,M,NM,_,F,A), - '$handle_discontiguous'(F,A,NM), fail. -'$check_term'(T,_,P,_Source,M) :- + % should always fail + '$handle_discontiguous'(F,A,NM), + fail. +'$check_term'(T,_,P,M) :- get_value('$syntaxcheckmultiple',on), '$xtract_head'(T,M,NM,_,F,A), - '$handle_multiple'(F,A,NM), fail. -'$check_term'(T,VL,P,_Source,_) :- - get_value('$syntaxchecksinglevar',on), - ( '$chk_binding_vars'(T), - '$sv_list'(VL,Sv) - -> - '$sv_warning'(Sv,T) - ), fail. -'$check_term'(_,_,_,_,_). + '$handle_multiple'(F,A,NM), + fail. +'$check_term'(T,_,_,M) :- + once(( + get_value('$syntaxcheckdiscontiguous',on) + ; + get_value('$syntaxcheckmultiple',on) + )), + recorded('$reconsulting',File,_), + '$xtract_head'(T,M,NM,_,F,A), + \+ ( + % allow duplicates if we are not the last predicate to have + % been asserted. + once(recorded('$predicate_defs','$predicate_defs'(F0,A0,M0,File),_)), + F0 = F, A0 = A, M0 = NM + ), + recorda('$predicate_defs','$predicate_defs'(F,A,NM,File),_), + fail. +'$check_term'(_,_,_,_). -'$chk_binding_vars'(V) :- var(V), !, V = '$V'(_). -'$chk_binding_vars'('$V'(off)) :- !. -'$chk_binding_vars'(A) :- primitive(A), !. -'$chk_binding_vars'(S) :- S =.. [_|L], - '$chk_bind_in_struct'(L). +% +% output a list of singleton variables... +% +'$singletons_in_clause'(T, VL, Sv) :- + % first check which variables are not singleton + '$non_singletons_in_term'(T,[],V2L), + % bound them + '$ground_vars'(V2L), + % the remainder which do not start by _ are our target! + '$sv_list'(VL, Sv). -'$chk_bind_in_struct'([]). -'$chk_bind_in_struct'([H|T]) :- - '$chk_binding_vars'(H), - '$chk_bind_in_struct'(T). +'$ground_vars'([]). +'$ground_vars'(ground.V2L) :- + '$ground_vars'(V2L). '$sv_list'([],[]). -'$sv_list'([[[95|_]|_]|T],L) :- +'$sv_list'([[95|_]._|T],L) :- !, '$sv_list'(T,L). -'$sv_list'([[Name|'$V'(V)]|T],[Name|L]) :- var(V), !, +'$sv_list'([_|V].T,L) :- nonvar(V), !, '$sv_list'(T,L). -'$sv_list'([_|T],L) :- +'$sv_list'([Name|_].T, Name.L) :- '$sv_list'(T,L). -'$sv_warning'([],_) :- !. -'$sv_warning'(SVs,T) :- +'$sv_warning'([], _) :- !. +'$sv_warning'(SVs, T) :- '$current_module'(OM), - '$xtract_head'(T,OM,M,H,Name,Arity), - ( nb_getval('$consulting',false), - '$first_clause_in_file'(Name,Arity, OM) -> - ClN = 1 ; - '$number_of_clauses'(H,M,ClN0), - ClN is ClN0+1 - ), - print_message(warning,singletons(SVs,(M:Name/Arity),ClN)). + '$xtract_head'(T, OM, M, H, Name, Arity), + print_message(warning,singletons(SVs,(M:Name/Arity))). '$xtract_head'(V,M,M,V,call,1) :- var(V), !. '$xtract_head'((H:-_),OM,M,NH,Name,Arity) :- !, @@ -183,36 +205,54 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T). '$xtract_head'(H,M,M,H,Name,Arity) :- functor(H,Name,Arity). +% check if a predicate is discontiguous. '$handle_discontiguous'(F,A,M) :- - recorded('$discontiguous_defs','$df'(F,A,M),_), !. + recorded('$discontiguous_defs','$df'(F,A,M),_), !, + fail. '$handle_discontiguous'(F,A,M) :- functor(Head, F, A), - '$is_multifile'(Head, M), !. + '$is_multifile'(Head, M), !, + fail. '$handle_discontiguous'(F,A,M) :- - '$in_this_file_before'(F,A,M), - print_message(warning,clauses_not_together((M:F/A))). + nb_getval('$consulting_file', FileName), + % we have been there before + once(recorded('$predicate_defs','$predicate_defs'(F, A, M, FileName),_)), + % and we are not + \+ ( + % the last predicate to have been asserted + once(recorded('$predicate_defs','$predicate_defs'(F0,A0,M0,FileName),_)), + F0 = F, A0 = A, M0 = M + ), + print_message(warning,clauses_not_together((M:F/A))), + fail. +% never complain the second time '$handle_multiple'(F,A,M) :- - \+ '$first_clause_in_file'(F,A,M), !. -'$handle_multiple'(_,_,_) :- - nb_getval('$consulting',true), !. + nb_getval('$consulting_file', FileName), + recorded('$predicate_defs','$predicate_defs'(F,A,M,FileName),_), !. +% first time we have a definition '$handle_multiple'(F,A,M) :- - recorded('$predicate_defs','$predicate_defs'(F,A,M,Fil),_), !, - '$multiple_has_been_defined'(Fil, F/A, M), !. -'$handle_multiple'(F,A,M) :- - ( recorded('$reconsulting',Fil,_) -> true ), - recorda('$predicate_defs','$predicate_defs'(F,A,M,Fil),_). + nb_getval('$consulting_file', FileName0), + recorded('$predicate_defs','$predicate_defs'(F,A,M,FileName),_), + FileName \= FileName0, + '$multiple_has_been_defined'(FileName, F/A, M), !. +% be careful about these cases. +% consult does not count +'$multiple_has_been_defined'(_, _, _) :- + nb_getval('$consulting',true), !. +% multifile does not count '$multiple_has_been_defined'(_, F/A, M) :- functor(S, F, A), '$is_multifile'(S, M), !. +'$multiple_has_been_defined'(Fil,F/A,M) :- + % first, clean up all definitions in other files + % don't forget, we just removed everything. + recorded('$predicate_defs','$predicate_defs'(F,A,M,FileName),R), + erase(R), + fail. '$multiple_has_been_defined'(Fil,P,M) :- - recorded('$reconsulting',F,_), !, - '$test_if_well_reconsulting'(F,Fil,M:P). - -'$test_if_well_reconsulting'(F,F,_) :- !. -'$test_if_well_reconsulting'(_,Fil,P) :- - print_message(warning,defined_elsewhere(P,Fil)). + print_message(warning,defined_elsewhere(M:P,Fil)). '$multifile'(V, _) :- var(V), !, '$do_error'(instantiation_error,multifile(V)). diff --git a/pl/consult.yap b/pl/consult.yap index 598c56f53..adbf17b64 100755 --- a/pl/consult.yap +++ b/pl/consult.yap @@ -252,6 +252,7 @@ use_module(M,F,Is) :- '$access_yap_flags'(18,GenerateDebug), '$consult_infolevel'(InfLevel), '$comp_mode'(OldCompMode, CompMode), + ( get_value('$syntaxcheckflag',on) -> '$init_style_check'(File) ; true ), recorda('$initialisation','$',_), ( Reconsult = reconsult -> '$start_reconsulting'(File), diff --git a/pl/messages.yap b/pl/messages.yap index a3f7dbbec..9adc30ca4 100644 --- a/pl/messages.yap +++ b/pl/messages.yap @@ -129,10 +129,10 @@ system_message(leash([A|B])) --> [ 'Leashing set to ~w.' - [[A|B]] ]. system_message(existence_error(prolog_flag,F)) --> [ 'Prolog Flag ~w: new Prolog flags must be created using create_prolog_flag/3.' - [F] ]. -system_message(singletons([SV],P,CLN)) --> - [ 'Singleton variable ~s in ~q, clause ~d.' - [SV,P,CLN] ]. -system_message(singletons(SVs,P,CLN)) --> - [ 'Singleton variables ~s in ~q, clause ~d.' - [SVsL, P, CLN] ], +system_message(singletons([SV],P)) --> + [ 'Singleton variable ~s in ~q.' - [SV,P] ]. +system_message(singletons(SVs,P)) --> + [ 'Singleton variables ~s in ~q.' - [SVsL, P] ], { svs(SVs,SVsL,[]) }. system_message(trace_command(-1)) --> [ 'EOF is not a valid debugger command.' ]. diff --git a/pl/modules.yap b/pl/modules.yap index a3ed65774..f3b2e9d78 100644 --- a/pl/modules.yap +++ b/pl/modules.yap @@ -316,6 +316,9 @@ expand_goal(G, NG) :- '$do_expand'(G, M, NG), !. expand_goal(G, G). +'$do_expand'(G, _, G) :- var(G), !. +'$do_expand'(M:G, CurMod, M:GI) :- !, + '$do_expand'(G, M, GI). '$do_expand'(G, CurMod, GI) :- ( '$pred_exists'(goal_expansion(G,GI), CurMod), @@ -323,7 +326,8 @@ expand_goal(G, G). -> true ; - recorded('$dialect',swi,_), system:goal_expansion(G, GI) + recorded('$dialect',swi,_), + system:goal_expansion(G, GI) -> true ; @@ -332,7 +336,22 @@ expand_goal(G, G). true ; user:goal_expansion(G, GI) - ). + ), !. +'$do_expand'(G, CurMod, NG) :- + '$is_metapredicate'(G,CurMod), !, + functor(G, Name, Arity), + prolog:'$meta_predicate'(Name,CurMod,Arity,PredDef), + G =.. [Name|GArgs], + PredDef =.. [Name|GDefs], + '$expand_args'(GArgs, CurMod, GDefs, NGArgs), + NG =.. [Name|NGArgs]. + +'$expand_args'([], _, [], []). +'$expand_args'(A.GArgs, CurMod, 0.GDefs, NA.NGArgs) :- + '$do_expand'(A, CurMod, NA), !, + '$expand_args'(GArgs, CurMod, GDefs, NGArgs). +'$expand_args'(A.GArgs, CurMod, _.GDefs, A.NGArgs) :- + '$expand_args'(GArgs, CurMod, GDefs, NGArgs). % args are: % goal to expand @@ -455,7 +474,7 @@ expand_goal(G, G). '$install_meta_predicate'(P, M1) :- functor(P,F,N), ( M1 = prolog -> M = _ ; M1 = M), - ( retractall('$meta_predicate'(F,M,N,_)), fail ; true), + ( retractall(prolog:'$meta_predicate'(F,M,N,_)), fail ; true), asserta(prolog:'$meta_predicate'(F,M,N,P)), '$flags'(P, M1, Fl, Fl), NFlags is Fl \/ 0x200000, diff --git a/pl/preds.yap b/pl/preds.yap index 875dc1b81..77815f9e7 100644 --- a/pl/preds.yap +++ b/pl/preds.yap @@ -212,7 +212,8 @@ assertz_static(C) :- '$head_and_body'(C,H,B), '$assertat_d'(last,H,B,C0,Mod,_). '$assertz_dynamic'(X,C,C0,Mod) :- - '$head_and_body'(C,H,B), functor(H,N,A), + '$head_and_body'(C,H,B), + functor(H,N,A), ('$check_if_reconsulted'(N,A) -> true ;