diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

lgamma broke arithmetic optimisation

Browse Source 
integer_y has type y
pass original source to checker (and maybe even use option in parser)
use warning mechanism for checker messages.


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1231 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2005-01-13 05:47:27 +00:00
parent c9307a5987
commit cd4fd05d45
6 changed files with 97 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
C/absmi.c
View File

@ -10,8 +10,12 @@
* * * *
* File: absmi.c * * File: absmi.c *
* comments: Portable abstract machine interpreter * * 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 $ * $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 * Revision 1.154 2004/12/05 05:01:21 vsc
* try to reduce overheads when running with goal expansion enabled. * try to reduce overheads when running with goal expansion enabled.
* CLPBN fixes * CLPBN fixes
@ -8099,7 +8103,7 @@ Yap_absmi(int inp)
integer_y_nvar: integer_y_nvar:
/* non variable */ /* non variable */
if (IsIntTerm(d0)) { if (IsIntTerm(d0)) {
PREG = NEXTOP(PREG, xF); PREG = NEXTOP(PREG, yF);
GONext(); GONext();
} }
if (IsApplTerm(d0)) { if (IsApplTerm(d0)) {

9
C/arith1.c
View File

@ -1086,7 +1086,7 @@ p_lgamma(Term t E_ARGS)
Functor f = AritFunctorOfTerm(t); Functor f = AritFunctorOfTerm(t);
union arith_ret v; union arith_ret v;
blob_type bt; blob_type bt;
Float dbl, out; Float dbl;
switch (BlobOfFunctor(f)) { switch (BlobOfFunctor(f)) {
case long_int_e: case long_int_e:
@ -1123,8 +1123,11 @@ p_lgamma(Term t E_ARGS)
} }
#if HAVE_LGAMMA #if HAVE_LGAMMA
{
Float out;
out = lgamma(dbl); out = lgamma(dbl);
RFLOAT(out); RFLOAT(out);
}
#else #else
RERROR(); RERROR();
#endif #endif
@ -2014,7 +2017,6 @@ static InitUnEntry InitUnTab[] = {
{"asin", p_asin}, {"asin", p_asin},
{"acos", p_acos}, {"acos", p_acos},
{"atan", p_atan}, {"atan", p_atan},
{"lgamma", p_lgamma},
{"asinh", p_asinh}, {"asinh", p_asinh},
{"acosh", p_acosh}, {"acosh", p_acosh},
{"atanh", p_atanh}, {"atanh", p_atanh},
@ -2028,7 +2030,8 @@ static InitUnEntry InitUnTab[] = {
{"msb", p_msb}, {"msb", p_msb},
{"float_fractional_part", p_ffracp}, {"float_fractional_part", p_ffracp},
{"float_integer_part", p_fintp}, {"float_integer_part", p_fintp},
{"sign", p_sign} {"sign", p_sign},
{"lgamma", p_lgamma},
}; };
static Int static Int

1
pl/arith.yap
View File

@ -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_fractional_part,27).
'$unary_op_as_integer'(float_integer_part,28). '$unary_op_as_integer'(float_integer_part,28).
'$unary_op_as_integer'(sign,29). '$unary_op_as_integer'(sign,29).
'$unary_op_as_integer'(lgamma,30).
'$binary_op_as_integer'(+,0). '$binary_op_as_integer'(+,0).
'$binary_op_as_integer'(-,1). '$binary_op_as_integer'(-,1).

81
pl/boot.yap
View File

@ -203,48 +203,49 @@ repeat :- '$repeat'.
'$command'(C,VL,Con) :- '$command'(C,VL,Con) :-
'$access_yap_flags'(9,1), !, '$access_yap_flags'(9,1), !,
'$execute_command'(C,VL,Con). '$execute_command'(C,VL,Con,C).
'$command'(C,VL,Con) :- '$command'(C,VL,Con) :-
( (Con = top ; var(C) ; C = [_|_]) -> ( (Con = top ; var(C) ; C = [_|_]) ->
'$execute_command'(C,VL,Con), ! ; '$execute_command'(C,VL,Con,C), ! ;
expand_term(C, EC), 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. % Hack in case expand_term has created a list of commands.
% %
'$execute_commands'(V,_,_) :- var(V), !, '$execute_commands'(V,_,_,Source) :- var(V), !,
'$do_error'(instantiation_error,meta_call(V)). '$do_error'(instantiation_error,meta_call(Source)).
'$execute_commands'([],_,_) :- !, fail. '$execute_commands'([],_,_,_) :- !, fail.
'$execute_commands'([C|Cs],VL,Con) :- !, '$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. fail.
'$execute_commands'(C,VL,Con) :- '$execute_commands'(C,VL,Con,Source) :-
'$execute_command'(C,VL,Con). '$execute_command'(C,VL,Con,Source).
% %
% %
% %
'$execute_command'(C,_,top) :- var(C), !, '$execute_command'(C,_,top,Source) :- var(C), !,
'$do_error'(instantiation_error,meta_call(C)). '$do_error'(instantiation_error,meta_call(Source)).
'$execute_command'(C,_,top) :- number(C), !, '$execute_command'(C,_,top,Source) :- number(C), !,
'$do_error'(type_error(callable,C),meta_call(C)). '$do_error'(type_error(callable,C),meta_call(Source)).
'$execute_command'(R,_,top) :- db_reference(R), !, '$execute_command'(R,_,top,Source) :- db_reference(R), !,
'$do_error'(type_error(callable,R),meta_call(R)). '$do_error'(type_error(callable,R),meta_call(Source)).
'$execute_command'(end_of_file,_,_) :- !. '$execute_command'(end_of_file,_,_,_) :- !.
'$execute_command'((:-G),_,Option) :- !, '$execute_command'((:-G),_,Option,_) :- !,
'$current_module'(M), '$current_module'(M),
'$process_directive'(G, Option, M), '$process_directive'(G, Option, M),
fail. fail.
'$execute_command'((?-G),V,_) :- !, '$execute_command'((?-G),V,_,Source) :- !,
'$execute_command'(G,V,top). '$execute_command'(G,V,top,Source).
'$execute_command'(G,V,Option) :- '$continue_with_command'(Option,V,G). '$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. % This command is very different depending on the language mode we are in.
@ -297,40 +298,40 @@ repeat :- '$repeat'.
'$all_directives'(G) :- !, '$all_directives'(G) :- !,
'$directive'(G). '$directive'(G).
'$continue_with_command'(reconsult,V,G) :- '$continue_with_command'(reconsult,V,G,Source) :-
'$go_compile_clause'(G,V,5), '$go_compile_clause'(G,V,5,Source),
fail. fail.
'$continue_with_command'(consult,V,G) :- '$continue_with_command'(consult,V,G,Source) :-
'$go_compile_clause'(G,V,13), '$go_compile_clause'(G,V,13,Source),
fail. fail.
'$continue_with_command'(top,V,G) :- '$continue_with_command'(top,V,G,_) :-
'$query'(G,V). '$query'(G,V).
% %
% not 100% compatible with SICStus Prolog, as SICStus Prolog would put % not 100% compatible with SICStus Prolog, as SICStus Prolog would put
% module prefixes all over the place, although unnecessarily so. % module prefixes all over the place, although unnecessarily so.
% %
'$go_compile_clause'(Mod:G,V,N) :- !, '$go_compile_clause'(Mod:G,V,N,Source) :- !,
'$go_compile_clause'(G,V,N,Mod). '$go_compile_clause'(G,V,N,Mod,Source).
'$go_compile_clause'((M:G :- B),V,N) :- !, '$go_compile_clause'((M:G :- B),V,N,Source) :- !,
'$current_module'(M1), '$current_module'(M1),
(M1 = M -> (M1 = M ->
NG = (G :- B) NG = (G :- B)
; ;
'$preprocess_clause_before_mod_change'((G:-B),M1,M,NG) '$preprocess_clause_before_mod_change'((G:-B),M1,M,NG)
), ),
'$go_compile_clause'(NG,V,N,M). '$go_compile_clause'(NG,V,N,M,Source).
'$go_compile_clause'(G,V,N) :- '$go_compile_clause'(G,V,N,Source) :-
'$current_module'(Mod), '$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) :- '$go_compile_clause'(G, V, N, Mod, Source) :-
'$prepare_term'(G, V, G0, G1, Mod), '$prepare_term'(G, V, G0, G1, Mod, Source),
'$$compile'(G1, G0, N, Mod). '$$compile'(G1, G0, N, Mod).
'$prepare_term'(G,V,G0,G1, Mod) :- '$prepare_term'(G, V, G0, G1, Mod, Source) :-
( get_value('$syntaxcheckflag',on) -> ( get_value('$syntaxcheckflag',on) ->
'$check_term'(G,V,Mod) ; true ), '$check_term'(Source, V, Mod) ; true ),
'$precompile_term'(G, G0, G1, Mod). '$precompile_term'(G, G0, G1, Mod).
% process an input clause % process an input clause
@ -753,12 +754,10 @@ not(G) :- \+ '$execute'(G).
'$do_undefp'(G,M) :- '$do_undefp'(G,M) :-
\+ '$undefined'(unknown_predicate_handler(_,_,_), user), \+ '$undefined'(unknown_predicate_handler(_,_,_), user),
'$system_catch'(unknown_predicate_handler(G,M,NG), user, _, fail), !, '$system_catch'(unknown_predicate_handler(G,M,NG), user, _, fail), !,
'$execute'(user:NG), ( once('$execute'(user:NG)) -> '$exit_undefp' ; '$exit_undefp', fail).
'$exit_undefp'.
'$do_undefp'(G,M) :- '$do_undefp'(G,M) :-
recorded('$unknown','$unknown'(M:G,US),_), !, recorded('$unknown','$unknown'(M:G,US),_), !,
'$execute'(user:US), ( once('$execute'(user:US)) -> '$exit_undefp' ; '$exit_undefp', fail).
'$exit_undefp'.
'$do_undefp'(_,_) :- '$do_undefp'(_,_) :-
'$exit_undefp', '$exit_undefp',
fail. fail.

48
pl/checker.yap
View File

@ -11,8 +11,11 @@
* File: checker.yap * * File: checker.yap *
* comments: style checker for Prolog * * 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 $ * $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 * Revision 1.14 2004/06/29 19:04:46 vsc
* fix multithreaded version * fix multithreaded version
* include new version of Ricardo's profiler * 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) :- '$sv_warning'(SVs,T) :-
'$current_module'(OM), '$current_module'(OM),
'$xtract_head'(T,OM,M,H,Name,Arity), '$xtract_head'(T,OM,M,H,Name,Arity),
write(user_error,'% Warning: singleton variable'), '$start_line'(LN),
'$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 '),
( get_value('$consulting',false), ( get_value('$consulting',false),
'$first_clause_in_file'(Name,Arity, OM) -> '$first_clause_in_file'(Name,Arity, OM) ->
ClN = 1 ; ClN = 1 ;
'$number_of_clauses'(H,M,ClN0), '$number_of_clauses'(H,M,ClN0),
ClN is ClN0+1 ClN is ClN0+1
), ),
write(user_error,ClN), print_message(warning,singletons(SVs,(M:Name/Arity),LN,ClN)).
write(user_error,')'),
nl(user_error).
'$xtract_head'(V,M,M,V,call,1) :- var(V), !. '$xtract_head'(V,M,M,V,call,1) :- var(V), !.
'$xtract_head'((H:-_),OM,M,NH,Name,Arity) :- !, '$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) :- '$xtract_head'(H,M,M,H,Name,Arity) :-
functor(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) :- '$handle_discontiguous'(F,A,M) :-
recorded('$discontiguous_defs','$df'(F,A,M),_), !. recorded('$discontiguous_defs','$df'(F,A,M),_), !.
'$handle_discontiguous'(F,A,M) :- '$handle_discontiguous'(F,A,M) :-
'$in_this_file_before'(F,A,M), '$in_this_file_before'(F,A,M),
write(user_error,'% Warning: discontiguous definition of '), '$start_line'(LN),
write(user_error,F/A), write(user_error,' (line '), print_message(warning,clauses_not_together((M:Name/Arity),LN)).
'$start_line'(LN), write(user_error,LN),
write(user_error,')'),
nl(user_error).
'$handle_multiple'(F,A,M) :- '$handle_multiple'(F,A,M) :-
\+ '$first_clause_in_file'(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'(F,F,_) :- !.
'$test_if_well_reconsulting'(_,Fil,P) :- '$test_if_well_reconsulting'(_,Fil,P) :-
write(user_error,'% Warning: predicate '), '$start_line'(LN),
write(user_error,P), write(user_error,' already defined in '), print_message(warning,defined_elsewhere((M:Name/Arity),Fil,LN)).
write(user_error,Fil), write(user_error,' (line '),
'$start_line'(LN), write(user_error,LN),
write(user_error,')'),
nl(user_error).
'$multifile'(V, _) :- var(V), !, '$multifile'(V, _) :- var(V), !,
'$do_error'(instantiation_error,multifile(V)). '$do_error'(instantiation_error,multifile(V)).

36
pl/errors.yap
View File

@ -11,8 +11,11 @@
* File: errors.yap * * File: errors.yap *
* comments: error messages for 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 $ * $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 * Revision 1.57 2004/10/27 15:56:34 vsc
* bug fixes on memory overflows and on clauses :- fail being ignored by clause. * 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)) :- !, '$do_print_message'(breakpoints(L)) :- !,
format(user_error,'Spy-points set on:', []), format(user_error,'Spy-points set on:', []),
'$print_list_of_preds'(L). '$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)) :- !, '$do_print_message'(debug(debug)) :- !,
format(user_error,'Debug mode on.',[]). format(user_error,'Debug mode on.',[]).
'$do_print_message'(debug(off)) :- !, '$do_print_message'(debug(off)) :- !,
format(user_error,'Debug mode off.',[]). format(user_error,'Debug mode off.',[]).
'$do_print_message'(debug(trace)) :- !, '$do_print_message'(debug(trace)) :- !,
format(user_error,'Trace mode on.',[]). 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)) :- !, '$do_print_message'(import(Pred,To,From,private)) :- !,
format(user_error,'Importing private predicate ~w:~w to ~w.', format(user_error,'Importing private predicate ~w:~w to ~w.',
[From,Pred,To]). [From,Pred,To]).
@ -176,10 +183,15 @@ print_message(Level, Mss) :-
'$do_print_message'(no_match(P)) :- !, '$do_print_message'(no_match(P)) :- !,
format(user_error,'No matching predicate for ~w.', format(user_error,'No matching predicate for ~w.',
[P]). [P]).
'$do_print_message'(trace_command(C)) :- !, '$do_print_message'(leash([A|B])) :- !,
format(user_error,'Invalid trace command: ~c', [C]). 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) :- !, '$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)) :- !, '$do_print_message'(version(Version)) :- !,
format(user_error,'YAP version ~a', [Version]). format(user_error,'YAP version ~a', [Version]).
'$do_print_message'(yes) :- !, '$do_print_message'(yes) :- !,
@ -187,6 +199,22 @@ print_message(Level, Mss) :-
'$do_print_message'(Messg) :- '$do_print_message'(Messg) :-
format(user_error,'~q',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'([]).
'$print_list_of_preds'([P|L]) :- '$print_list_of_preds'([P|L]) :-
format(user_error,'~n ~w',[P]), format(user_error,'~n ~w',[P]),