From 53e8811077ca3f535a39c4ce1dccc75391d053b5 Mon Sep 17 00:00:00 2001 From: ubu32 Date: Sat, 26 Feb 2011 18:34:44 -0800 Subject: [PATCH 1/4] fixes to use SWI version of readline. --- C/errors.c | 4 +- C/iopreds.c | 30 ++-- LGPL/history.pl | 288 ++++++++++++++++++++++++++++++++++ library/dialect/swi/fli/swi.c | 20 ++- packages/PLStream/pl-read.c | 11 +- packages/PLStream/pl-yap.h | 2 +- pl/boot.yap | 15 +- pl/flags.yap | 10 +- pl/init.yap | 6 +- pl/messages.yap | 7 +- 10 files changed, 358 insertions(+), 35 deletions(-) create mode 100644 LGPL/history.pl diff --git a/C/errors.c b/C/errors.c index d8267d297..c4edc2033 100644 --- a/C/errors.c +++ b/C/errors.c @@ -1461,10 +1461,8 @@ Yap_Error(yap_error_number type, Term where, char *format,...) { int i; - Term ti[1]; i = strlen(tmpbuf); - ti[0] = where; - nt[0] = Yap_MkApplTerm(FunctorShortSyntaxError, 1, ti); + nt[0] = where; tp = tmpbuf+i; psize -= i; fun = FunctorError; diff --git a/C/iopreds.c b/C/iopreds.c index cb58d6d51..9e66a18ab 100644 --- a/C/iopreds.c +++ b/C/iopreds.c @@ -388,6 +388,18 @@ syntax_error (TokEntry * tokptr, IOSTREAM *st, Term *outp) return(Yap_MkApplTerm(FunctorSyntaxError,7,tf)); } +static void +GenerateSyntaxError(Term *tp, TokEntry *tokstart, IOSTREAM *sno) +{ + if (tp) { + Term et[2]; + Term t = MkVarTerm(); + et[0] = syntax_error(tokstart, sno, &t); + et[1] = MkAtomTerm(Yap_LookupAtom("Syntax error")); + *tp = Yap_MkApplTerm(FunctorError, 2, et); + } +} + Term Yap_StringToTerm(char *s,Term *tp) { @@ -418,11 +430,8 @@ Yap_StringToTerm(char *s,Term *tp) } t = Yap_Parse(); TR = TR_before_parse; - if (!t && !Yap_ErrorMessage) { - if (tp) { - t = MkVarTerm(); - *tp = syntax_error(tokstart, sno, &t); - } + if (!t || Yap_ErrorMessage) { + GenerateSyntaxError(tp, tokstart, sno); Yap_clean_tokenizer(tokstart, Yap_VarTable, Yap_AnonVarTable); Sclose(sno); return FALSE; @@ -521,11 +530,10 @@ Yap_readTerm(void *st0, Term *tp, Term *varnames, Term *terror, Term *tpos) return FALSE; } pt = Yap_Parse(); - if (Yap_ErrorMessage) { - Term t0 = MkVarTerm(); - *terror = syntax_error(tokstart, st, &t0); - Yap_clean_tokenizer(tokstart, Yap_VarTable, Yap_AnonVarTable); - return FALSE; + if (Yap_ErrorMessage || pt == (CELL)0) { + GenerateSyntaxError(terror, tokstart, st); + Yap_clean_tokenizer(tokstart, Yap_VarTable, Yap_AnonVarTable); + return FALSE; } if (varnames) { *varnames = Yap_VarNames(Yap_VarTable, TermNil); @@ -535,6 +543,8 @@ Yap_readTerm(void *st0, Term *tp, Term *varnames, Term *terror, Term *tpos) } } *tp = pt; + if (!pt) + return FALSE; return TRUE; } diff --git a/LGPL/history.pl b/LGPL/history.pl new file mode 100644 index 000000000..e6e668d69 --- /dev/null +++ b/LGPL/history.pl @@ -0,0 +1,288 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: wielemak@science.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2005, University of Amsterdam + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module('$history', + [ % read_history/6, + '$clean_history'/0, + '$save_history'/1 + ]). + +%% read_history(+History, +Help, +DontStore, +Prompt, -Term, -Bindings) +% +% Give a prompt using Prompt. The sequence '%w' is substituted with the +% current event number. Then read a term from the input stream and perform +% the history expansion. Return the expanded term and the bindings of the +% variables as with read/2. +% entering the term History makes read_history/5 print the history. +% Help specifies the help command. +% DontStore is a list of events that need not be stored. + +% When read_history reads a term of the form $silent(Goal), it will +% call Goal and pretend it has not seen anything. This hook is used +% by the GNU-Emacs interface to for communication between GNU-EMACS +% and SWI-Prolog. + +prolog:read_history(History, Help, DontStore, Prompt, Term, Bindings) :- + repeat, + prompt_history(Prompt), + catch('$raw_read'(user_input, Raw), E, + (print_message(error, E), + ( E = error(syntax_error(_), _) + -> fail + ; throw(E) + ))), + read_history_(History, Help, DontStore, Raw, Term, Bindings), !. + +read_history_(History, _, _, History, _, _) :- + list_history, !, + fail. +read_history_(Show, Help, _, Help, _, _) :- + print_message(help, history(help(Show, Help))), !, + fail. +read_history_(History, Help, DontStore, Raw, Term, Bindings) :- + expand_history(Raw, Expanded, Changed), + save_history_line(Expanded), + catch(atom_to_term(Expanded, Term0, Bindings0), + E, + ( print_message(error, E), + fail + )), + ( var(Term0) + -> Term = Term0, + Bindings = Bindings0 + ; Term0 = '$silent'(Goal) + -> user:ignore(Goal), + read_history(History, Help, DontStore, '', Term, Bindings) + ; save_event(DontStore, Expanded), + ( Changed == true + -> print_message(query, history(expanded(Expanded))) + ; true + ), + Term = Term0, + Bindings = Bindings0 + ). + + +% list_history +% Write history events to the current output stream. + +list_history :- + ( '$history'(Last, _) + -> true + ; Last = 0 + ), + history_depth_(Depth), + plus(First, Depth, Last), + findall(Nr/Event, + ( between(First, Last, Nr), + '$history'(Nr, Event) + ), + Events), + print_message(query, history(history(Events))). + +'$clean_history' :- + retractall('$history'(_,_)). + +% prompt_history(+Prompt) +% Give prompt, substituting '%!' by the event number. + +prompt_history('') :- !, + ttyflush. +prompt_history(Prompt) :- + ( '$history'(Last, _) + -> This is Last + 1 + ; This = 1 + ), + atom_codes(Prompt, SP), + number_codes(This, ST), + ( substitute("%!", ST, SP, String) + -> prompt1(String) + ; prompt1(Prompt) + ), + ttyflush. + +% substitute(+Old, +New, +String, -Substituted) +% substitute first occurence of Old in String by New + +substitute(Old, New, String, Substituted) :- + '$append'(Head, OldAndTail, String), + '$append'(Old, Tail, OldAndTail), !, + '$append'(Head, New, HeadAndNew), + '$append'(HeadAndNew, Tail, Substituted), !. + +% save_event(+Event) +% Save Event in the history system. Remove possibly outdated events. + +save_history_line(end_of_file) :- !. +save_history_line(Line) :- + current_prolog_flag(readline, true), + format(atom(CompleteLine), '~W~W', + [ Line, [partial(true)], + '.', [partial(true)] + ]), + catch(user:rl_add_history(CompleteLine), _, fail), !. +save_history_line(_). + +save_event(Dont, Event) :- + lists:memberchk(Event, Dont), !. +save_event(_, Event) :- + '$save_history'(Event). + +:- thread_local + '$history'/2. + +'$save_history'(Event) :- + ( '$history'(Old, _) + -> New is Old + 1 + ; New is 1 + ), + asserta('$history'(New, Event)), + history_depth_(Depth), + remove_history(New, Depth). + +remove_history(New, Depth) :- + New - Depth =< 0, !. +remove_history(New, Depth) :- + Remove is New - Depth, + retract('$history'(Remove, _)), !. +remove_history(_, _). + +% history_depth_(-Depth) +% Define the depth to which to keep the history. + +history_depth_(N) :- + current_prolog_flag(history, N), + integer(N), + N > 0, !. +history_depth_(25). + +% expand_history(+Raw, -Expanded) +% Expand Raw using the available history list. Expandations performed +% are: +% +% !match % Last event starting +% !n % Event nr. +% !! % last event +% +% Note: the first character after a '!' should be a letter or number to +% avoid problems with the cut. + +expand_history(Raw, Expanded, Changed) :- + atom_chars(Raw, RawString), + expand_history2(RawString, ExpandedString, Changed), + atom_chars(Expanded, ExpandedString), !. + +expand_history2([!], [!], false) :- !. +expand_history2([!, C|Rest], [!|Expanded], Changed) :- + not_event_char(C), !, + expand_history2([C|Rest], Expanded, Changed). +expand_history2([!|Rest], Expanded, true) :- !, + match_event(Rest, Event, NewRest), + '$append'(Event, RestExpanded, Expanded), !, + expand_history2(NewRest, RestExpanded, _). +expand_history2(['\''|In], ['\''|Out], Changed) :- !, + skip_quoted(In, '\'', Out, Tin, Tout), + expand_history2(Tin, Tout, Changed). +expand_history2(['"'|In], ['"'|Out], Changed) :- !, + skip_quoted(In, '"', Out, Tin, Tout), + expand_history2(Tin, Tout, Changed). +expand_history2([H|T], [H|R], Changed) :- !, + expand_history2(T, R, Changed). +expand_history2([], [], false). + +skip_quoted([Q|T],Q,[Q|R], T, R) :- !. +skip_quoted([\,Q|T0],Q,[\,Q|T], In, Out) :- !, + skip_quoted(T0, Q, T, In, Out). +skip_quoted([Q,Q|T0],Q,[Q,Q|T], In, Out) :- !, + skip_quoted(T0, Q, T, In, Out). +skip_quoted([C|T0],Q,[C|T], In, Out) :- !, + skip_quoted(T0, Q, T, In, Out). +skip_quoted([], _, [], [], []). + +% get_last_event(-String) +% return last event typed as a string + +get_last_event(Event) :- + '$history'(_, Atom), + atom_chars(Atom, Event), !. +get_last_event(_) :- + print_message(query, history(no_event)), + fail. + +% match_event(+Spec, -Event, -Rest) +% Use Spec as a specification of and event and return the event as Event +% and what is left of Spec as Rest. + +match_event(Spec, Event, Rest) :- + find_event(Spec, Event, Rest), !. +match_event(_, _, _) :- + print_message(query, history(no_event)), + fail. + +not_event_char(C) :- code_type(C, csym), !, fail. +not_event_char(!) :- !, fail. +not_event_char(_). + +find_event([!|Left], Event, Left) :- !, + get_last_event(Event). +find_event([N|Rest], Event, Left) :- + code_type(N, digit), !, + take_number([N|Rest], String, Left), + number_codes(Number, String), + '$history'(Number, Atom), + atom_chars(Atom, Event). +find_event(Spec, Event, Left) :- + take_string(Spec, String, Left), + matching_event(String, Event). + +take_string([C|Rest], [C|String], Left) :- + code_type(C, csym), !, + take_string(Rest, String, Left). +take_string([C|Rest], [], [C|Rest]) :- !. +take_string([], [], []). + +take_number([C|Rest], [C|String], Left) :- + code_type(C, digit), !, + take_string(Rest, String, Left). +take_number([C|Rest], [], [C|Rest]) :- !. +take_number([], [], []). + +% matching_event(+String, -Event) +% +% Return first event with prefix String as a Prolog string. + +matching_event(String, Event) :- + '$history'(_, AtomEvent), + atom_chars(AtomEvent, Event), + '$append'(String, _, Event), !. + +'$append'(Head, OldAndTail, String) :- + lists:append(Head, OldAndTail, String). \ No newline at end of file diff --git a/library/dialect/swi/fli/swi.c b/library/dialect/swi/fli/swi.c index 2acae2911..9e5a44358 100755 --- a/library/dialect/swi/fli/swi.c +++ b/library/dialect/swi/fli/swi.c @@ -2754,15 +2754,26 @@ Yap_swi_install(void) YAP_UserCPredicate("ctime", SWI_ctime, 2); } -int Yap_read_term(term_t t, IOSTREAM *st, term_t vs); +int Yap_read_term(term_t t, IOSTREAM *st, term_t *excep, term_t vs); int -Yap_read_term(term_t t, IOSTREAM *st, term_t vs) +Yap_read_term(term_t t, IOSTREAM *st, term_t *excep, term_t vs) { Term varnames, out, tpos; + Term error; - if (!Yap_readTerm(st, &out, &varnames, NULL, &tpos)) + if (!Yap_readTerm(st, &out, &varnames, &error, &tpos)) { + if (excep) { + *excep = Yap_InitSlot(error); + } return FALSE; + } + if (!out) { + if (excep) { + *excep = Yap_InitSlot(error); + } + return FALSE; + } if (!Yap_unify(out, Yap_GetFromSlot(t))) { return FALSE; } @@ -2794,6 +2805,9 @@ Atom Yap_FileName(IOSTREAM *s) { atom_t a = fileNameStream(s); + if (!a) { + return AtomEmptyAtom; + } return SWIAtomToAtom(a); } diff --git a/packages/PLStream/pl-read.c b/packages/PLStream/pl-read.c index ff25bfa93..7183fdcd6 100644 --- a/packages/PLStream/pl-read.c +++ b/packages/PLStream/pl-read.c @@ -83,7 +83,16 @@ free_read_data(ReadData _PL_rd) static int read_term(term_t t, ReadData _PL_rd ARG_LD) { - return Yap_read_term(t, rb.stream, _PL_rd->varnames); + int rval; + term_t except; + + if (!(rval = Yap_read_term(t, rb.stream, &except, _PL_rd->varnames))) { + if (except) { + _PL_rd->has_exception = TRUE; + _PL_rd->exception = except; + } + } + return rval; } diff --git a/packages/PLStream/pl-yap.h b/packages/PLStream/pl-yap.h index 93f643450..f23a8d456 100644 --- a/packages/PLStream/pl-yap.h +++ b/packages/PLStream/pl-yap.h @@ -31,7 +31,7 @@ typedef YAP_Term (*Func)(term_t); /* foreign functions */ extern const char *Yap_GetCurrentPredName(void); extern YAP_Int Yap_GetCurrentPredArity(void); -extern int Yap_read_term(term_t t, IOSTREAM *st, term_t vs); +extern int Yap_read_term(term_t t, IOSTREAM *st, term_t *exc, term_t vs); extern int Yap_LookupSWIStream(void *swi_s); extern term_t Yap_fetch_module_for_format(term_t args, YAP_Term *modp); extern IOENC Yap_DefaultEncoding(void); diff --git a/pl/boot.yap b/pl/boot.yap index 554b9a93e..58fb97f11 100755 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -66,7 +66,7 @@ true :- true. set_value(fileerrors,1), set_value('$gc',on), ('$exit_undefp' -> true ; true), - prompt1(' ?- '), + prompt1(' ?- '), '$debug_on'(false), % simple trick to find out if this is we are booting from Prolog. get_value('$user_module',V), @@ -144,10 +144,11 @@ true :- true. */ /* main execution loop */ -'$read_vars'(user_input, Goal, Mod, Pos, Binding) :- +'$read_vars'(user_input, Goal, Mod, Pos, Bindings) :- + get_value('$readline',true), !, read_history(h, '!h', [trace, end_of_file], - Prompt, Goal, Bindings), + ' ?- ', Goal, Bindings), (nonvar(Err) -> print_message(error,Err), fail ; @@ -191,8 +192,8 @@ true :- true. set_value('$live','$false'). '$enter_top_level' :- '$disable_docreep', - prompt(_,' | '), - prompt1(' ?- '), + prompt(_,'| '), + prompt1(' ?- '), '$run_toplevel_hooks', '$read_vars'(user_input,Command,_,Pos,Varnames), nb_setval('$spy_gn',1), @@ -200,7 +201,7 @@ true :- true. nb_setval('$debug_run',off), nb_setval('$debug_jump',off), - prompt(_,' |: '), + prompt(_,'|: '), '$command'(Command,Varnames,Pos,top), '$sync_mmapped_arrays', set_value('$live','$false'). @@ -223,7 +224,7 @@ true :- true. '$startup_saved_state' :- recorded('$restore_goal',G,R), erase(R), - prompt(_,' | '), + prompt(_,'| '), '$system_catch'('$do_yes_no'((G->true),user),user,Error,user:'$Error'(Error)), fail. '$startup_saved_state'. diff --git a/pl/flags.yap b/pl/flags.yap index 4f5254a4f..0194c32f2 100644 --- a/pl/flags.yap +++ b/pl/flags.yap @@ -207,12 +207,11 @@ yap_flag(home,X) :- yap_flag(readline,X) :- var(X), !, - get_value('$readline',X1). - '$transl_to_true_false'(X1,X). + get_value('$readline',X). +yap_flag(readline,X) :- + ( X = true ; X = false ), !, + set_value('$readline',X). yap_flag(readline,X) :- - '$transl_to_true_false'(X1,X), !, - set_value('$readline',X1). -yap_flag(bounded,X) :- '$do_error'(domain_error(flag_value,readline+X),yap_flag(bounded,X)). % tabling mode @@ -848,6 +847,7 @@ yap_flag(dialect,yap). '$yap_system_flag'(open_shared_object). '$yap_system_flag'(profiling). '$yap_system_flag'(prompt_alternatives_on). +'$yap_system_flag'(readline). '$yap_system_flag'(redefine_warnings). '$yap_system_flag'(shared_object_search_path). '$yap_system_flag'(single_var_warnings). diff --git a/pl/init.yap b/pl/init.yap index d1652a0d6..bb4bdd55a 100644 --- a/pl/init.yap +++ b/pl/init.yap @@ -113,9 +113,7 @@ system_mode(verbose,off) :- set_value('$verbose',off). :- use_module('attributes.yap'). :- use_module('corout.yap'). :- use_module('dialect.yap'). -%:- use_module('../LGPL/history.pl'). - -%:- set_prolog_flag(readline, true). +:- use_module('../LGPL/history.pl'). '$system_module'('$messages'). '$system_module'('$hacks'). @@ -211,3 +209,5 @@ file_search_path(foreign, yap('lib/Yap')). :- yap_flag(unknown,error). +:- set_prolog_flag(readline, true). + diff --git a/pl/messages.yap b/pl/messages.yap index acc7a5e47..1bf71d512 100644 --- a/pl/messages.yap +++ b/pl/messages.yap @@ -273,9 +273,10 @@ system_message(error(resource_error(trail), Where)) --> [ 'RESOURCE ERROR- not enough trail space' - [Where] ]. system_message(error(signal(SIG,_), _)) --> [ 'UNEXPECTED SIGNAL: ~a' - [SIG] ]. -system_message(error(syntax_error(syntax_error(G,0,Msg,[],0,0,File)), _)) --> +system_message(error(syntax_error(G,_,Msg,[],_,0,File), _)) --> [ 'SYNTAX ERROR at "~a", goal ~q: ~a' - [File,G,Msg] ]. -system_message(error(syntax_error(syntax_error(read(Term),_,_,Term,Pos,Start,File)), Where)) --> +system_message(error(syntax_error(read(_),_,_,Term,Pos,Start,File), Where)) --> + { Term = [_|_] }, ['~w' - [Where]], syntax_error_line(File, Start, Pos), syntax_error_term(10, Pos, Term), @@ -421,6 +422,8 @@ list_of_preds([P|L]) --> list_of_preds(L). +syntax_error_line('', _,_) --> !, + [':~n' ]. syntax_error_line(File, Position,_) --> [' at ~a, near line ~d:~n' - [File,Position]]. From 3c261305dbe3f02f7790f04f321fe2d9c3590686 Mon Sep 17 00:00:00 2001 From: ubu32 Date: Sun, 27 Feb 2011 02:13:25 -0800 Subject: [PATCH 2/4] interface to rationals. --- C/c_interface.c | 54 +++++++++++++++++++++++++++++++++++++- include/YapInterface.h | 9 +++++++ packages/PLStream/pl-yap.c | 6 +++++ 3 files changed, 68 insertions(+), 1 deletion(-) diff --git a/C/c_interface.c b/C/c_interface.c index 5301ee434..16aeffa98 100755 --- a/C/c_interface.c +++ b/C/c_interface.c @@ -385,6 +385,7 @@ X_API Bool STD_PROTO(YAP_IsNonVarTerm,(Term)); X_API Bool STD_PROTO(YAP_IsIntTerm,(Term)); X_API Bool STD_PROTO(YAP_IsLongIntTerm,(Term)); X_API Bool STD_PROTO(YAP_IsBigNumTerm,(Term)); +X_API Bool STD_PROTO(YAP_IsRationalTerm,(Term)); X_API Bool STD_PROTO(YAP_IsFloatTerm,(Term)); X_API Bool STD_PROTO(YAP_IsDbRefTerm,(Term)); X_API Bool STD_PROTO(YAP_IsAtomTerm,(Term)); @@ -392,8 +393,10 @@ X_API Bool STD_PROTO(YAP_IsPairTerm,(Term)); X_API Bool STD_PROTO(YAP_IsApplTerm,(Term)); X_API Term STD_PROTO(YAP_MkIntTerm,(Int)); X_API Term STD_PROTO(YAP_MkBigNumTerm,(void *)); +X_API Term STD_PROTO(YAP_MkRationalTerm,(void *)); X_API Int STD_PROTO(YAP_IntOfTerm,(Term)); X_API void STD_PROTO(YAP_BigNumOfTerm,(Term, void *)); +X_API void STD_PROTO(YAP_RationalOfTerm,(Term, void *)); X_API Term STD_PROTO(YAP_MkFloatTerm,(flt)); X_API flt STD_PROTO(YAP_FloatOfTerm,(Term)); X_API Term STD_PROTO(YAP_MkAtomTerm,(Atom)); @@ -601,7 +604,29 @@ X_API Bool YAP_IsBigNumTerm(Term t) { #if USE_GMP - return IsBigIntTerm(t); + CELL *pt; + if (IsVarTerm(t)) + return FALSE; + if (!IsBigIntTerm(t)) + return FALSE; + pt = RepAppl(t); + return pt[1] == BIG_INT; +#else + return FALSE; +#endif +} + +X_API Bool +YAP_IsRationalTerm(Term t) +{ +#if USE_GMP + CELL *pt; + if (IsVarTerm(t)) + return FALSE; + if (!IsBigIntTerm(t)) + return FALSE; + pt = RepAppl(t); + return pt[1] == BIG_RATIONAL; #else return FALSE; #endif @@ -698,6 +723,33 @@ YAP_BigNumOfTerm(Term t, void *b) #endif /* USE_GMP */ } +X_API Term +YAP_MkRationalTerm(void *big) +{ +#if USE_GMP + Term I; + BACKUP_H(); + I = Yap_MkBigRatTerm((MP_RAT *)big); + RECOVER_H(); + return I; +#else + return TermNil; +#endif /* USE_GMP */ +} + +X_API void +YAP_RationalOfTerm(Term t, void *b) +{ +#if USE_GMP + MP_RAT *br = (MP_RAT *)b; + if (IsVarTerm(t)) + return; + if (!IsBigIntTerm(t)) + return; + mpq_set(br,Yap_BigRatOfTerm(t)); +#endif /* USE_GMP */ +} + X_API Term YAP_MkBlobTerm(unsigned int sz) { diff --git a/include/YapInterface.h b/include/YapInterface.h index 12860e4e4..ca720aab5 100755 --- a/include/YapInterface.h +++ b/include/YapInterface.h @@ -103,6 +103,9 @@ extern X_API YAP_Bool PROTO(YAP_IsLongIntTerm,(YAP_Term)); /* YAP_Bool IsBigNumTerm(YAP_Term) */ extern X_API YAP_Bool PROTO(YAP_IsBigNumTerm,(YAP_Term)); +/* YAP_Bool IsRationalTerm(YAP_Term) */ +extern X_API YAP_Bool PROTO(YAP_IsRationalTerm,(YAP_Term)); + /* YAP_Bool IsFloatTerm(YAP_Term) */ extern X_API YAP_Bool PROTO(YAP_IsFloatTerm,(YAP_Term)); @@ -124,12 +127,18 @@ extern X_API YAP_Term PROTO(YAP_MkIntTerm,(YAP_Int)); /* Term MkBigNumTerm(void *) */ extern X_API YAP_Term PROTO(YAP_MkBigNumTerm,(void *)); +/* Term MkRationalTerm(void *) */ +extern X_API YAP_Term PROTO(YAP_MkRationalTerm,(void *)); + /* YAP_Int IntOfTerm(Term) */ extern X_API YAP_Int PROTO(YAP_IntOfTerm,(YAP_Term)); /* void * BigNumOfTerm(Term) */ extern X_API void *PROTO(YAP_BigNumOfTerm,(YAP_Term, void *)); +/* void * RationalOfTerm(Term) */ +extern X_API void *PROTO(YAP_RationalOfTerm,(YAP_Term, void *)); + /* Term MkFloatTerm(YAP_Float) */ extern X_API YAP_Term PROTO(YAP_MkFloatTerm,(YAP_Float)); diff --git a/packages/PLStream/pl-yap.c b/packages/PLStream/pl-yap.c index 9b59fb4f9..432578433 100755 --- a/packages/PLStream/pl-yap.c +++ b/packages/PLStream/pl-yap.c @@ -190,6 +190,12 @@ valueExpression(term_t t, Number r ARG_LD) YAP_BigNumOfTerm(t0, &r->value.mpz); return 1; } + if (YAP_IsRationalTerm(t0)) { + r->type = V_MPQ; + mpq_init(&r->value.mpq); + YAP_RationalOfTerm(t0, &r->value.mpq); + return 1; + } #endif return 0; } From f2e8f2ac2e41e796df3135bf74ac1a881716a3fc Mon Sep 17 00:00:00 2001 From: ubu32 Date: Sun, 27 Feb 2011 03:40:27 -0800 Subject: [PATCH 3/4] more fixes for bignum support in PLStream. --- library/dialect/swi/fli/swi.c | 62 ++++++++++++++++++++++++++++++++++- packages/PLStream/pl-write.c | 3 ++ packages/PLStream/pl-yap.c | 7 +++- packages/PLStream/pl-yap.h | 2 ++ 4 files changed, 72 insertions(+), 2 deletions(-) diff --git a/library/dialect/swi/fli/swi.c b/library/dialect/swi/fli/swi.c index 9e5a44358..d8e6a6af5 100755 --- a/library/dialect/swi/fli/swi.c +++ b/library/dialect/swi/fli/swi.c @@ -535,6 +535,9 @@ X_API int PL_get_name_arity(term_t ts, atom_t *name, int *arity) } if (YAP_IsApplTerm(t)) { Functor f = FunctorOfTerm(t); + if (IsExtensionFunctor(f)) { + return 0; + } *name = AtomToSWIAtom(NameOfFunctor(f)); *arity = ArityOfFunctor(f); return 1; @@ -1697,7 +1700,18 @@ X_API int PL_is_float(term_t ts) X_API int PL_is_integer(term_t ts) { YAP_Term t = Yap_GetFromSlot(ts); - return YAP_IsIntTerm(t) || YAP_IsBigNumTerm(t); + if (IsVarTerm(t)) return FALSE; + if (IsIntTerm(t)) return TRUE; + if (IsApplTerm(t)) { + Functor f = FunctorOfTerm(t); + if (f == FunctorLongInt) + return TRUE; + if (f == FunctorBigInt) { + CELL mask = RepAppl(t)[1]; + return ( mask == BIG_INT ); + } + } + return FALSE; } X_API int PL_is_list(term_t ts) @@ -2841,6 +2855,52 @@ FILE *Yap_FileDescriptorFromStream(Term t) return NULL; } +extern term_t Yap_CvtTerm(term_t ts); + +term_t Yap_CvtTerm(term_t ts) +{ + Term t = Yap_GetFromSlot(ts); + if (IsVarTerm(t)) return ts; + if (IsPairTerm(t)) return ts; + if (IsAtomTerm(t)) return ts; + if (IsIntTerm(t)) return ts; + if (IsApplTerm(t)) { + Functor f = FunctorOfTerm(t); + if (IsExtensionFunctor(f)) { + if (f == FunctorBigInt) { + big_blob_type flag = RepAppl(t)[1]; + switch (flag) { + case BIG_INT: + return ts; + case BIG_RATIONAL: +#if USE_GMP + { + MP_RAT *b = Yap_BigRatOfTerm(t); + Term ta[2]; + ta[0] = Yap_MkBigIntTerm(mpq_numref(b)); + if (ta[0] == TermNil) + return ts; + ta[1] = Yap_MkBigIntTerm(mpq_denref(b)); + if (ta[1] == TermNil) + return ts; + return Yap_InitSlot(Yap_MkApplTerm(FunctorRDiv, 2, ta)); + } +#endif + case EMPTY_ARENA: + case ARRAY_INT: + case ARRAY_FLOAT: + case CLAUSE_LIST: + case EXTERNAL_BLOB: + return Yap_InitSlot(MkIntTerm(0)); + default: + return ts; + } + } + } + } + return ts; +} + #ifdef _WIN32 #include diff --git a/packages/PLStream/pl-write.c b/packages/PLStream/pl-write.c index 61b641dde..3680d1cff 100644 --- a/packages/PLStream/pl-write.c +++ b/packages/PLStream/pl-write.c @@ -1065,6 +1065,9 @@ writeTerm2(term_t t, int prec, write_options *options, bool arg) } } +#if __YAP_PROLOG__ + t = Yap_CvtTerm(t); +#endif if ( PL_get_atom(t, &a) ) { if ( !arg && prec < 1200 && priorityOperator((Module)NULL, a) > 0 ) { if ( PutOpenBrace(out) && diff --git a/packages/PLStream/pl-yap.c b/packages/PLStream/pl-yap.c index 432578433..2e1568d37 100755 --- a/packages/PLStream/pl-yap.c +++ b/packages/PLStream/pl-yap.c @@ -381,9 +381,14 @@ PL_get_number(term_t l, number *n) { n->type = V_INTEGER; n->value.i = YAP_IntOfTerm(t); #ifdef O_GMP - } else { + } else if (YAP_IsBigNumTerm(t)) { n->type = V_MPZ; + mpz_init(&n->value.mpq); YAP_BigNumOfTerm(t, &n->value.mpz); + } else { + n->type = V_MPQ; + mpq_init(&n->value.mpq); + YAP_RationalOfTerm(t, &n->value.mpq); #endif } } diff --git a/packages/PLStream/pl-yap.h b/packages/PLStream/pl-yap.h index f23a8d456..da9c46a95 100644 --- a/packages/PLStream/pl-yap.h +++ b/packages/PLStream/pl-yap.h @@ -149,6 +149,8 @@ void PL_license(const char *license, const char *module); #define isTaggedInt(A) YAP_IsIntTerm(A) #define valInt(A) YAP_IntOfTerm(A) +extern term_t Yap_CvtTerm(term_t ts); + #define clearNumber(n) inline static int From 3f6b92de4bd4667c958d8d83ddc28d4899980a18 Mon Sep 17 00:00:00 2001 From: ubu32 Date: Sun, 27 Feb 2011 15:06:10 -0800 Subject: [PATCH 4/4] enable compilation with multi-threading. --- H/yapio.h | 4 +- include/SWI-Stream.h | 101 +++++++++++++++++++++++++++++++++- library/dialect/swi/fli/swi.c | 12 ++++ packages/PLStream/pl-incl.h | 97 ++++---------------------------- packages/PLStream/pl-yap.c | 57 +++++++++++++++++++ 5 files changed, 180 insertions(+), 91 deletions(-) diff --git a/H/yapio.h b/H/yapio.h index 253ca99ed..d1b41e6f9 100644 --- a/H/yapio.h +++ b/H/yapio.h @@ -282,8 +282,8 @@ FILE *STD_PROTO(Yap_FileDescriptorFromStream,(Term)); Int STD_PROTO(Yap_FirstLineInParse,(void)); int STD_PROTO(Yap_CheckIOStream,(Term, char *)); #if defined(YAPOR) || defined(THREADS) -void STD_PROTO(Yap_LockStream,(int)); -void STD_PROTO(Yap_UnLockStream,(int)); +void STD_PROTO(Yap_LockStream,(struct io_stream *)); +void STD_PROTO(Yap_UnLockStream,(struct io_stream *)); #else #define Yap_LockStream(X) #define Yap_UnLockStream(X) diff --git a/include/SWI-Stream.h b/include/SWI-Stream.h index 56f8fb0c8..9f1bf3565 100755 --- a/include/SWI-Stream.h +++ b/include/SWI-Stream.h @@ -94,11 +94,106 @@ typedef int64_t (*Sseek64_function)(void *handle, int64_t pos, int whence); typedef int (*Sclose_function)(void *handle); typedef int (*Scontrol_function)(void *handle, int action, void *arg); +#if defined(THREADS) && !defined(O_PLMT) +#define O_PLMT 1 +#endif + #if defined(O_PLMT) && defined(PL_KERNEL) -#include "pl-mutex.h" -#define IOLOCK recursiveMutex +/* Support PL_LOCK in the interface */ +#if THREADS + +#include + +typedef pthread_mutex_t simpleMutex; + +#define simpleMutexInit(p) pthread_mutex_init(p, NULL) +#define simpleMutexDelete(p) pthread_mutex_destroy(p) +#define simpleMutexLock(p) pthread_mutex_lock(p) +#define simpleMutexUnlock(p) pthread_mutex_unlock(p) + +typedef pthread_mutex_t recursiveMutex; + +#define NEED_RECURSIVE_MUTEX_INIT 1 +extern int recursiveMutexInit(recursiveMutex *m); +#define recursiveMutexDelete(p) pthread_mutex_destroy(p) +#define recursiveMutexLock(p) pthread_mutex_lock(p) +#define recursiveMutexTryLock(p) pthread_mutex_trylock(p) +#define recursiveMutexUnlock(p) pthread_mutex_unlock(p) + +#define IF_MT(id, g) if ( id == L_THREAD || GD->thread.enabled ) g + +typedef struct counting_mutex +{ simpleMutex mutex; /* mutex itself */ + const char *name; /* name of the mutex */ + long count; /* # times locked */ + long unlocked; /* # times unlocked */ +#ifdef O_CONTENTION_STATISTICS + long collisions; /* # contentions */ +#endif + struct counting_mutex *next; /* next of allocated chain */ +} counting_mutex; + +extern counting_mutex *allocSimpleMutex(const char *name); +extern void freeSimpleMutex(counting_mutex *m); + +extern counting_mutex _PL_mutexes[]; /* Prolog mutexes */ + +#define L_MISC 0 +#define L_ALLOC 1 +#define L_ATOM 2 +#define L_FLAG 3 +#define L_FUNCTOR 4 +#define L_RECORD 5 +#define L_THREAD 6 +#define L_PREDICATE 7 +#define L_MODULE 8 +#define L_TABLE 9 +#define L_BREAK 10 +#define L_FILE 11 +#define L_PLFLAG 12 +#define L_OP 13 +#define L_INIT 14 +#define L_TERM 15 +#define L_GC 16 +#define L_AGC 17 +#define L_FOREIGN 18 +#define L_OS 19 + +#ifdef O_CONTENTION_STATISTICS +#define countingMutexLock(cm) \ + do \ + { if ( pthread_mutex_trylock(&(cm)->mutex) == EBUSY ) \ + { (cm)->collisions++; \ + pthread_mutex_lock(&(cm)->mutex); \ + } \ + (cm)->count++; \ + } while(0) #else -typedef void * IOLOCK; /* Definition for external use */ +#define countingMutexLock(cm) \ + do \ + { simpleMutexLock(&(cm)->mutex); \ + (cm)->count++; \ + } while(0) +#endif +#define countingMutexUnlock(cm) \ + do \ + { (cm)->unlocked++; \ + assert((cm)->unlocked <= (cm)->count); \ + simpleMutexUnlock(&(cm)->mutex); \ + } while(0) + +#define PL_LOCK(id) IF_MT(id, countingMutexLock(&_PL_mutexes[id])) +#define PL_UNLOCK(id) IF_MT(id, countingMutexUnlock(&_PL_mutexes[id])) + +#define IOLOCK recursiveMutex + +#endif + +#else +#define PL_LOCK(X) +#define PL_UNLOCK(X) + +typedef void * IOLOCK; #endif typedef struct io_functions diff --git a/library/dialect/swi/fli/swi.c b/library/dialect/swi/fli/swi.c index d8e6a6af5..1375b7949 100755 --- a/library/dialect/swi/fli/swi.c +++ b/library/dialect/swi/fli/swi.c @@ -2855,6 +2855,18 @@ FILE *Yap_FileDescriptorFromStream(Term t) return NULL; } +#if THREADS +void Yap_LockStream(IOSTREAM *s) +{ + if ( s->mutex ) recursiveMutexLock(s->mutex); +} + +void Yap_UnLockStream(IOSTREAM *s) +{ + if ( s->mutex ) recursiveMutexUnlock(s->mutex); +} +#endif + extern term_t Yap_CvtTerm(term_t ts); term_t Yap_CvtTerm(term_t ts) diff --git a/packages/PLStream/pl-incl.h b/packages/PLStream/pl-incl.h index acd616129..4a6347d60 100755 --- a/packages/PLStream/pl-incl.h +++ b/packages/PLStream/pl-incl.h @@ -267,25 +267,23 @@ typedef struct #define GF_PROCEDURE 2 /* check for max arity */ +#ifdef O_PLMT + +typedef struct free_chunk *FreeChunk; /* left-over chunk */ + +struct free_chunk +{ FreeChunk next; /* next of chain */ + size_t size; /* size of free bit */ +}; + +#endif + /******************************* * LIST BUILDING * *******************************/ #include "pl-privitf.h" -typedef int simpleMutex; - -typedef struct counting_mutex -{ simpleMutex mutex; /* mutex itself */ - const char *name; /* name of the mutex */ - long count; /* # times locked */ - long unlocked; /* # times unlocked */ -#ifdef O_CONTENTION_STATISTICS - long collisions; /* # contentions */ -#endif - struct counting_mutex *next; /* next of allocated chain */ -} counting_mutex; - typedef enum { CLN_NORMAL = 0, /* Normal mode */ CLN_ACTIVE, /* Started cleanup */ @@ -360,12 +358,6 @@ typedef struct { { Table table; /* global (read-only) features */ } prolog_flag; -#if THREADS - struct - { int enabled; /* threads are enabled */ - } thread; -#endif - struct { Table tmp_files; /* Known temporary files */ CanonicalDir _canonical_dirlist; @@ -693,73 +685,6 @@ extern PL_local_data_t lds; #define source_line_pos (LD->read_source.linepos) #define source_char_no (LD->read_source.character) -/* Support PL_LOCK in the interface */ -#if THREADS - -typedef pthread_mutex_t simpleMutex; - -#define simpleMutexInit(p) pthread_mutex_init(p, NULL) -#define simpleMutexDelete(p) pthread_mutex_destroy(p) -#define simpleMutexLock(p) pthread_mutex_lock(p) -#define simpleMutexUnlock(p) pthread_mutex_unlock(p) - -extern counting_mutex _PL_mutexes[]; /* Prolog mutexes */ - -#define L_MISC 0 -#define L_ALLOC 1 -#define L_ATOM 2 -#define L_FLAG 3 -#define L_FUNCTOR 4 -#define L_RECORD 5 -#define L_THREAD 6 -#define L_PREDICATE 7 -#define L_MODULE 8 -#define L_TABLE 9 -#define L_BREAK 10 -#define L_FILE 11 -#define L_PLFLAG 12 -#define L_OP 13 -#define L_INIT 14 -#define L_TERM 15 -#define L_GC 16 -#define L_AGC 17 -#define L_FOREIGN 18 -#define L_OS 19 - -#define IF_MT(id, g) if ( id == L_THREAD || GD->thread.enabled ) g - -#ifdef O_CONTENTION_STATISTICS -#define countingMutexLock(cm) \ - do \ - { if ( pthread_mutex_trylock(&(cm)->mutex) == EBUSY ) \ - { (cm)->collisions++; \ - pthread_mutex_lock(&(cm)->mutex); \ - } \ - (cm)->count++; \ - } while(0) -#else -#define countingMutexLock(cm) \ - do \ - { simpleMutexLock(&(cm)->mutex); \ - (cm)->count++; \ - } while(0) -#endif -#define countingMutexUnlock(cm) \ - do \ - { (cm)->unlocked++; \ - assert((cm)->unlocked <= (cm)->count); \ - simpleMutexUnlock(&(cm)->mutex); \ - } while(0) - -#define PL_LOCK(id) IF_MT(id, countingMutexLock(&_PL_mutexes[id])) -#define PL_UNLOCK(id) IF_MT(id, countingMutexUnlock(&_PL_mutexes[id])) - -#else -#define PL_LOCK(X) -#define PL_UNLOCK(X) -#endif - - #ifndef TRUE #define TRUE 1 #define FALSE 0 diff --git a/packages/PLStream/pl-yap.c b/packages/PLStream/pl-yap.c index 2e1568d37..6fc83e22e 100755 --- a/packages/PLStream/pl-yap.c +++ b/packages/PLStream/pl-yap.c @@ -926,6 +926,63 @@ Yap_fetch_module_for_format(term_t args, YAP_Term *modp) { } #if THREADS + +static int +recursive_attr(pthread_mutexattr_t **ap) +{ static int done; + static pthread_mutexattr_t attr; + int rc; + + if ( done ) + { *ap = &attr; + return 0; + } + + PL_LOCK(L_THREAD); + if ( done ) + { PL_UNLOCK(L_THREAD); + + *ap = &attr; + return 0; + } + if ( (rc=pthread_mutexattr_init(&attr)) ) + goto error; +#ifdef HAVE_PTHREAD_MUTEXATTR_SETTYPE + if ( (rc=pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE)) ) + goto error; +#else +#ifdef HAVE_PTHREAD_MUTEXATTR_SETKIND_NP + if ( (rc=pthread_mutexattr_setkind_np(&attr, PTHREAD_MUTEX_RECURSIVE_NP)) ) + goto error; +#endif +#endif + + done = TRUE; + PL_UNLOCK(L_THREAD); + *ap = &attr; + + return 0; + +error: + PL_UNLOCK(L_THREAD); + return rc; +} + +int +recursiveMutexInit(recursiveMutex *m) +{ + int rc; + pthread_mutexattr_t *attr; + + if ( (rc=recursive_attr(&attr)) ) + return rc; + + return pthread_mutex_init(m, attr); + +} + + + counting_mutex _PL_mutexes[] = { COUNT_MUTEX_INITIALIZER("L_MISC"), COUNT_MUTEX_INITIALIZER("L_ALLOC"),