diff --git a/C/absmi.c b/C/absmi.c index 0c8d101e8..ddd861479 100644 --- a/C/absmi.c +++ b/C/absmi.c @@ -10,8 +10,12 @@ * * * File: absmi.c * * comments: Portable abstract machine interpreter * -* Last rev: $Date: 2004-12-28 22:20:34 $,$Author: vsc $ * +* Last rev: $Date: 2005-01-13 05:47:25 $,$Author: vsc $ * * $Log: not supported by cvs2svn $ +* Revision 1.155 2004/12/28 22:20:34 vsc +* some extra bug fixes for trail overflows: some cannot be recovered that easily, +* some can. +* * Revision 1.154 2004/12/05 05:01:21 vsc * try to reduce overheads when running with goal expansion enabled. * CLPBN fixes @@ -8099,7 +8103,7 @@ Yap_absmi(int inp) integer_y_nvar: /* non variable */ if (IsIntTerm(d0)) { - PREG = NEXTOP(PREG, xF); + PREG = NEXTOP(PREG, yF); GONext(); } if (IsApplTerm(d0)) { diff --git a/C/arith1.c b/C/arith1.c index 6ba0dce6d..0aeb113c3 100644 --- a/C/arith1.c +++ b/C/arith1.c @@ -1086,7 +1086,7 @@ p_lgamma(Term t E_ARGS) Functor f = AritFunctorOfTerm(t); union arith_ret v; blob_type bt; - Float dbl, out; + Float dbl; switch (BlobOfFunctor(f)) { case long_int_e: @@ -1123,8 +1123,11 @@ p_lgamma(Term t E_ARGS) } #if HAVE_LGAMMA - out = lgamma(dbl); - RFLOAT(out); + { + Float out; + out = lgamma(dbl); + RFLOAT(out); + } #else RERROR(); #endif @@ -2014,7 +2017,6 @@ static InitUnEntry InitUnTab[] = { {"asin", p_asin}, {"acos", p_acos}, {"atan", p_atan}, - {"lgamma", p_lgamma}, {"asinh", p_asinh}, {"acosh", p_acosh}, {"atanh", p_atanh}, @@ -2028,7 +2030,8 @@ static InitUnEntry InitUnTab[] = { {"msb", p_msb}, {"float_fractional_part", p_ffracp}, {"float_integer_part", p_fintp}, - {"sign", p_sign} + {"sign", p_sign}, + {"lgamma", p_lgamma}, }; static Int diff --git a/pl/arith.yap b/pl/arith.yap index 05eb75d20..9b2768527 100644 --- a/pl/arith.yap +++ b/pl/arith.yap @@ -322,6 +322,7 @@ do_not_compile_expressions :- set_value('$c_arith',[]). '$unary_op_as_integer'(float_fractional_part,27). '$unary_op_as_integer'(float_integer_part,28). '$unary_op_as_integer'(sign,29). +'$unary_op_as_integer'(lgamma,30). '$binary_op_as_integer'(+,0). '$binary_op_as_integer'(-,1). diff --git a/pl/boot.yap b/pl/boot.yap index 80f7d3817..665e7186c 100644 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -203,48 +203,49 @@ repeat :- '$repeat'. '$command'(C,VL,Con) :- '$access_yap_flags'(9,1), !, - '$execute_command'(C,VL,Con). + '$execute_command'(C,VL,Con,C). '$command'(C,VL,Con) :- ( (Con = top ; var(C) ; C = [_|_]) -> - '$execute_command'(C,VL,Con), ! ; + '$execute_command'(C,VL,Con,C), ! ; expand_term(C, EC), - '$execute_commands'(EC,VL,Con) + '$execute_commands'(EC,VL,Con,C) ). % % Hack in case expand_term has created a list of commands. % -'$execute_commands'(V,_,_) :- var(V), !, - '$do_error'(instantiation_error,meta_call(V)). -'$execute_commands'([],_,_) :- !, fail. -'$execute_commands'([C|Cs],VL,Con) :- !, +'$execute_commands'(V,_,_,Source) :- var(V), !, + '$do_error'(instantiation_error,meta_call(Source)). +'$execute_commands'([],_,_,_) :- !, fail. +'$execute_commands'([C|Cs],VL,Con,Source) :- !, ( - '$execute_command'(C,VL,Con) + '$execute_command'(C,VL,Con,Source) ; - '$execute_commands'(Cs,VL,Con) + '$execute_commands'(Cs,VL,Con,Source) ), fail. -'$execute_commands'(C,VL,Con) :- - '$execute_command'(C,VL,Con). +'$execute_commands'(C,VL,Con,Source) :- + '$execute_command'(C,VL,Con,Source). % % % -'$execute_command'(C,_,top) :- var(C), !, - '$do_error'(instantiation_error,meta_call(C)). -'$execute_command'(C,_,top) :- number(C), !, - '$do_error'(type_error(callable,C),meta_call(C)). -'$execute_command'(R,_,top) :- db_reference(R), !, - '$do_error'(type_error(callable,R),meta_call(R)). -'$execute_command'(end_of_file,_,_) :- !. -'$execute_command'((:-G),_,Option) :- !, +'$execute_command'(C,_,top,Source) :- var(C), !, + '$do_error'(instantiation_error,meta_call(Source)). +'$execute_command'(C,_,top,Source) :- number(C), !, + '$do_error'(type_error(callable,C),meta_call(Source)). +'$execute_command'(R,_,top,Source) :- db_reference(R), !, + '$do_error'(type_error(callable,R),meta_call(Source)). +'$execute_command'(end_of_file,_,_,_) :- !. +'$execute_command'((:-G),_,Option,_) :- !, '$current_module'(M), '$process_directive'(G, Option, M), fail. -'$execute_command'((?-G),V,_) :- !, - '$execute_command'(G,V,top). -'$execute_command'(G,V,Option) :- '$continue_with_command'(Option,V,G). +'$execute_command'((?-G),V,_,Source) :- !, + '$execute_command'(G,V,top,Source). +'$execute_command'(G,V,Option,Source) :- + '$continue_with_command'(Option,V,G,Source). % % This command is very different depending on the language mode we are in. @@ -297,40 +298,40 @@ repeat :- '$repeat'. '$all_directives'(G) :- !, '$directive'(G). -'$continue_with_command'(reconsult,V,G) :- - '$go_compile_clause'(G,V,5), +'$continue_with_command'(reconsult,V,G,Source) :- + '$go_compile_clause'(G,V,5,Source), fail. -'$continue_with_command'(consult,V,G) :- - '$go_compile_clause'(G,V,13), +'$continue_with_command'(consult,V,G,Source) :- + '$go_compile_clause'(G,V,13,Source), fail. -'$continue_with_command'(top,V,G) :- +'$continue_with_command'(top,V,G,_) :- '$query'(G,V). % % not 100% compatible with SICStus Prolog, as SICStus Prolog would put % module prefixes all over the place, although unnecessarily so. % -'$go_compile_clause'(Mod:G,V,N) :- !, - '$go_compile_clause'(G,V,N,Mod). -'$go_compile_clause'((M:G :- B),V,N) :- !, +'$go_compile_clause'(Mod:G,V,N,Source) :- !, + '$go_compile_clause'(G,V,N,Mod,Source). +'$go_compile_clause'((M:G :- B),V,N,Source) :- !, '$current_module'(M1), (M1 = M -> NG = (G :- B) ; '$preprocess_clause_before_mod_change'((G:-B),M1,M,NG) ), - '$go_compile_clause'(NG,V,N,M). -'$go_compile_clause'(G,V,N) :- + '$go_compile_clause'(NG,V,N,M,Source). +'$go_compile_clause'(G,V,N,Source) :- '$current_module'(Mod), - '$go_compile_clause'(G,V,N,Mod). + '$go_compile_clause'(G,V,N,Mod,Source). -'$go_compile_clause'(G, V, N, Mod) :- - '$prepare_term'(G, V, G0, G1, Mod), +'$go_compile_clause'(G, V, N, Mod, Source) :- + '$prepare_term'(G, V, G0, G1, Mod, Source), '$$compile'(G1, G0, N, Mod). -'$prepare_term'(G,V,G0,G1, Mod) :- +'$prepare_term'(G, V, G0, G1, Mod, Source) :- ( get_value('$syntaxcheckflag',on) -> - '$check_term'(G,V,Mod) ; true ), + '$check_term'(Source, V, Mod) ; true ), '$precompile_term'(G, G0, G1, Mod). % process an input clause @@ -753,12 +754,10 @@ not(G) :- \+ '$execute'(G). '$do_undefp'(G,M) :- \+ '$undefined'(unknown_predicate_handler(_,_,_), user), '$system_catch'(unknown_predicate_handler(G,M,NG), user, _, fail), !, - '$execute'(user:NG), - '$exit_undefp'. + ( once('$execute'(user:NG)) -> '$exit_undefp' ; '$exit_undefp', fail). '$do_undefp'(G,M) :- recorded('$unknown','$unknown'(M:G,US),_), !, - '$execute'(user:US), - '$exit_undefp'. + ( once('$execute'(user:US)) -> '$exit_undefp' ; '$exit_undefp', fail). '$do_undefp'(_,_) :- '$exit_undefp', fail. diff --git a/pl/checker.yap b/pl/checker.yap index 6eaa4a531..9089fef02 100644 --- a/pl/checker.yap +++ b/pl/checker.yap @@ -11,8 +11,11 @@ * File: checker.yap * * comments: style checker for Prolog * * * -* Last rev: $Date: 2004-06-29 19:12:01 $,$Author: vsc $ * +* Last rev: $Date: 2005-01-13 05:47:27 $,$Author: vsc $ * * $Log: not supported by cvs2svn $ +* Revision 1.15 2004/06/29 19:12:01 vsc +* fix checker messages +* * Revision 1.14 2004/06/29 19:04:46 vsc * fix multithreaded version * include new version of Ricardo's profiler @@ -122,22 +125,14 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T). '$sv_warning'(SVs,T) :- '$current_module'(OM), '$xtract_head'(T,OM,M,H,Name,Arity), - write(user_error,'% Warning: singleton variable'), - '$write_svs'(SVs), - write(user_error,' in '), - write(user_error,Name/Arity), - write(user_error,' (line '), - '$start_line'(LN), write(user_error,LN), - write(user_error,', clause '), + '$start_line'(LN), ( get_value('$consulting',false), '$first_clause_in_file'(Name,Arity, OM) -> ClN = 1 ; '$number_of_clauses'(H,M,ClN0), ClN is ClN0+1 ), - write(user_error,ClN), - write(user_error,')'), - nl(user_error). + print_message(warning,singletons(SVs,(M:Name/Arity),LN,ClN)). '$xtract_head'(V,M,M,V,call,1) :- var(V), !. '$xtract_head'((H:-_),OM,M,NH,Name,Arity) :- !, @@ -153,31 +148,12 @@ 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). -'$write_svs'([H]) :- !, write(user_error,' '), '$write_svs1'([H]). -'$write_svs'(SVs) :- write(user_error,'s '), '$write_svs1'(SVs). - -'$write_svs1'([H]) :- !, - '$write_str_in_stderr'(H). -'$write_svs1'([H|T]) :- - '$write_str_in_stderr'(H), - write(user_error,','), - '$write_svs1'(T). - -'$write_str_in_stderr'([]). -'$write_str_in_stderr'([C|T]) :- - put(user_error,C), - '$write_str_in_stderr'(T). - - '$handle_discontiguous'(F,A,M) :- recorded('$discontiguous_defs','$df'(F,A,M),_), !. '$handle_discontiguous'(F,A,M) :- '$in_this_file_before'(F,A,M), - write(user_error,'% Warning: discontiguous definition of '), - write(user_error,F/A), write(user_error,' (line '), - '$start_line'(LN), write(user_error,LN), - write(user_error,')'), - nl(user_error). + '$start_line'(LN), + print_message(warning,clauses_not_together((M:Name/Arity),LN)). '$handle_multiple'(F,A,M) :- \+ '$first_clause_in_file'(F,A,M), !. @@ -199,12 +175,8 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T). '$test_if_well_reconsulting'(F,F,_) :- !. '$test_if_well_reconsulting'(_,Fil,P) :- - write(user_error,'% Warning: predicate '), - write(user_error,P), write(user_error,' already defined in '), - write(user_error,Fil), write(user_error,' (line '), - '$start_line'(LN), write(user_error,LN), - write(user_error,')'), - nl(user_error). + '$start_line'(LN), + print_message(warning,defined_elsewhere((M:Name/Arity),Fil,LN)). '$multifile'(V, _) :- var(V), !, '$do_error'(instantiation_error,multifile(V)). diff --git a/pl/errors.yap b/pl/errors.yap index cf224f002..575168dc1 100644 --- a/pl/errors.yap +++ b/pl/errors.yap @@ -11,8 +11,11 @@ * File: errors.yap * * comments: error messages for YAP * * * -* Last rev: $Date: 2004-11-19 21:32:53 $,$Author: vsc $ * +* Last rev: $Date: 2005-01-13 05:47:27 $,$Author: vsc $ * * $Log: not supported by cvs2svn $ +* Revision 1.58 2004/11/19 21:32:53 vsc +* change abort so that it won't be caught by handlers. +* * Revision 1.57 2004/10/27 15:56:34 vsc * bug fixes on memory overflows and on clauses :- fail being ignored by clause. * @@ -156,12 +159,16 @@ print_message(Level, Mss) :- '$do_print_message'(breakpoints(L)) :- !, format(user_error,'Spy-points set on:', []), '$print_list_of_preds'(L). +'$do_print_message'(clauses_not_together(P,LN)) :- !, + format(user_error, 'Discontiguous definition of ~q, at line ~d.',[P,LN]). '$do_print_message'(debug(debug)) :- !, format(user_error,'Debug mode on.',[]). '$do_print_message'(debug(off)) :- !, format(user_error,'Debug mode off.',[]). '$do_print_message'(debug(trace)) :- !, format(user_error,'Trace mode on.',[]). +'$do_print_message'(defined_elsewhere(P,F,LN)) :- !, + format(user_error, 'predicate ~q, at line ~d, previously defined in file ~a.',[P,LN,F]). '$do_print_message'(import(Pred,To,From,private)) :- !, format(user_error,'Importing private predicate ~w:~w to ~w.', [From,Pred,To]). @@ -176,10 +183,15 @@ print_message(Level, Mss) :- '$do_print_message'(no_match(P)) :- !, format(user_error,'No matching predicate for ~w.', [P]). -'$do_print_message'(trace_command(C)) :- !, - format(user_error,'Invalid trace command: ~c', [C]). +'$do_print_message'(leash([A|B])) :- !, + format(user_error,'Leashing set to ~w.', + [[A|B]]). +'$do_print_message'(singletons(SVs,P,LN,CLN)) :- !, + format(user_error, 'Singleton variable',[]), + '$write_svs'(SVs), + format(user_error, ' in ~q at line ~d, clause ~d.',[P,LN,CLN]). '$do_print_message'(trace_help) :- !, - format(user_error,' Please enter a valid debugger command (h for help).', []). + yap_flag(user_error,' Please enter a valid debugger command (h for help).', []). '$do_print_message'(version(Version)) :- !, format(user_error,'YAP version ~a', [Version]). '$do_print_message'(yes) :- !, @@ -187,6 +199,22 @@ print_message(Level, Mss) :- '$do_print_message'(Messg) :- format(user_error,'~q',Messg). +'$write_svs'([H]) :- !, write(user_error,' '), '$write_svs1'([H]). +'$write_svs'(SVs) :- write(user_error,'s '), '$write_svs1'(SVs). + +'$write_svs1'([H]) :- !, + '$write_str_in_stderr'(H). +'$write_svs1'([H|T]) :- + '$write_str_in_stderr'(H), + write(user_error,','), + '$write_svs1'(T). + +'$write_str_in_stderr'([]). +'$write_str_in_stderr'([C|T]) :- + put(user_error,C), + '$write_str_in_stderr'(T). + + '$print_list_of_preds'([]). '$print_list_of_preds'([P|L]) :- format(user_error,'~n ~w',[P]),