diff --git a/os/pl-prologflag.c b/os/pl-prologflag.c index 5271cc2c6..b1a744fce 100644 --- a/os/pl-prologflag.c +++ b/os/pl-prologflag.c @@ -1005,6 +1005,7 @@ pl_prolog_flag5(term_t key, term_t value, } fid = PL_open_foreign_frame(); + LOCK(); for(;;) { while( (s=advanceTableEnum(e->table_enum)) ) @@ -1032,7 +1033,6 @@ pl_prolog_flag5(term_t key, term_t value, #endif PL_rewind_foreign_frame(fid); } - if ( e->scope == ATOM_local ) { e->scope = ATOM_global; freeTableEnum(e->table_enum); diff --git a/os/pl-read.c b/os/pl-read.c index 1d1a25181..713c0e912 100644 --- a/os/pl-read.c +++ b/os/pl-read.c @@ -24,9 +24,14 @@ init_read_data(ReadData _PL_rd, IOSTREAM *in ARG_LD) _PL_rd->magic = RD_MAGIC; _PL_rd->varnames = 0; _PL_rd->module = Yap_GetModuleEntry(CurrentModule); + _PL_rd->exception = PL_new_term_ref(); rb.stream = in; _PL_rd->has_exception = 0; - _PL_rd->exception = 0; + _PL_rd->module = MODULE_parse; + _PL_rd->flags = _PL_rd->module->flags; /* change for options! */ + _PL_rd->styleCheck = debugstatus.styleCheck; + _PL_rd->on_error = ATOM_error; + _PL_rd->backquoted_string = truePrologFlag(PLFLAG_BACKQUOTED_STRING); } static void @@ -1207,6 +1212,8 @@ retry: &rd.quasi_quotations, #endif &rd.cycles) ) { + PL_discard_foreign_frame(fid); + free_read_data(&rd); return FALSE; } @@ -1231,8 +1238,10 @@ retry: rd.comments = PL_copy_term_ref(tcomments); rval = read_term(term, &rd PASS_LD); - if ( Sferror(s) ) + if ( Sferror(s) ) { + free_read_data(&rd); return FALSE; + } if ( rval ) { if ( tpos ) @@ -1241,23 +1250,43 @@ retry: { if ( !PL_unify_nil(rd.comments) ) rval = FALSE; } - } else - { if ( rd.has_exception && reportReadError(&rd) ) + } else { + if ( rd.has_exception && reportReadError(&rd) ) { PL_rewind_foreign_frame(fid); free_read_data(&rd); goto retry; } } - free_read_data(&rd); return rval; } +/** read_term(+Stream, -Term, +Options) is det. +*/ + +static +PRED_IMPL("read_term", 3, read_term, PL_FA_ISO) +{ PRED_LD + IOSTREAM *s; + + if ( getTextInputStream(A1, &s) ) + { if ( read_term_from_stream(s, A2, A3 PASS_LD) ) + return PL_release_stream(s); + if ( Sferror(s) ) + return streamStatus(s); + PL_release_stream(s); + return FALSE; + } + + return FALSE; +} + /** read_term(-Term, +Options) is det. */ + static PRED_IMPL("read_term", 2, read_term, PL_FA_ISO) { PRED_LD @@ -1376,8 +1405,8 @@ PL_chars_to_term(const char *s, term_t t) *******************************/ BeginPredDefs(read) - PRED_DEF("swi_read_term", 3, read_term, PL_FA_ISO) - PRED_DEF("swi_read_term", 2, read_term, PL_FA_ISO) + PRED_DEF("read_term", 3, read_term, PL_FA_ISO) + PRED_DEF("read_term", 2, read_term, PL_FA_ISO) PRED_DEF("atom_to_term", 3, atom_to_term, 0) PRED_DEF("term_to_atom", 2, term_to_atom, 0) #ifdef O_QUASIQUOTATIONS diff --git a/packages/real b/packages/real index 9ff05eaf6..f60caaf8b 160000 --- a/packages/real +++ b/packages/real @@ -1 +1 @@ -Subproject commit 9ff05eaf6a47d856f0e43c14ddb105f2bedcbafb +Subproject commit f60caaf8b2134b6a64e4923b2a471cdcd8026c2f diff --git a/pl/boot.yap b/pl/boot.yap index 1c3053108..43fbf9e1e 100755 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -1022,13 +1022,10 @@ bootstrap(F) :- !, close(Stream). +'$read_vars'(Stream, T, Mod, Pos, V, _Prompt, false) :- !, + read_term(Stream, T, [ /* module(Mod), */ variable_names(V), term_position(Pos), syntax_errors(dec10) ]). '$read_vars'(Stream, T, Mod, Pos, V, _Prompt, ReadComments) :- - '$read'(true, T, Mod, V, Pos, Err, ReadComments, Stream), - (nonvar(Err) -> - print_message(error,Err), fail - ; - true - ). + read_term(Stream, T, [module(Mod), variable_names(V), term_position(Pos), syntax_errors(dec10), comments( ReadComments ) ]). '$loop'(Stream,exo) :- prolog_flag(agc_margin,Old,0), @@ -1059,7 +1056,7 @@ bootstrap(F) :- repeat, prompt1('| '), prompt(_,'| '), '$current_module'(OldModule), - '$system_catch'('$enter_command'(Stream,Status), OldModule, Error, + '$system_catch'('$enter_command'(Stream,OldModule,Status), OldModule, Error, user:'$LoopError'(Error, Status)), !. % support comment hook @@ -1067,17 +1064,17 @@ bootstrap(F) :- repeat, prompt1('| '), prompt(_,'| '), '$current_module'(OldModule), - '$system_catch'('$enter_command_with_hook'(Stream,Status), OldModule, Error, + '$system_catch'('$enter_command_with_hook'(Stream,OldModule,Status), OldModule, Error, user:'$LoopError'(Error, Status)), !. -'$enter_command'(Stream,Status) :- - '$read_vars'(Stream,Command,_,Pos,Vars, '|: ', no), +'$enter_command'(Stream,Mod,Status) :- + '$read_vars'(Stream,Command,Mod,Pos,Vars, '|: ', false), '$command'(Command,Vars,Pos,Status). % support SWI hook in a separate predicate, to avoid slow down standard consult. -'$enter_command_with_hook'(Stream,Status) :- - '$read_vars'(Stream,Command,_,Pos,Vars, '|: ', Comments), +'$enter_command_with_hook'(Stream,Mod,Status) :- + '$read_vars'(Stream,Command,Mod,Pos,Vars, '|: ', Comments), ( prolog:comment_hook(Comments,Pos,Command) -> true ; true ), '$command'(Command,Vars,Pos,Status). diff --git a/pl/yio.yap b/pl/yio.yap index 5cc5e3b01..1c84bece8 100644 --- a/pl/yio.yap +++ b/pl/yio.yap @@ -131,92 +131,11 @@ exists(F) :- /* Term IO */ read(T) :- - '$read'(false,T,_,_,_,Err,_), - (nonvar(Err) -> - print_message(error,Err), fail - ; - true - ). + read_term(T, []). read(Stream,T) :- - '$read'(false,T,_,_,_,Err,_,Stream), - (nonvar(Err) -> - print_message(error,Err), fail - ; - true - ). + read_term(Stream, T, []). -read_term(T, Options) :- - '$check_io_opts'(Options,read_term(T, Options)), - current_input(S), - '$preprocess_read_terms_options'(Options,Module,DoComments), - '$read_vars'(S,T,Module,Pos,VL,'|: ',DoComments), - '$postprocess_read_terms_options'(Options, T, VL, Pos). - -read_term(Stream, T, Options) :- - '$check_io_opts'(Options,read_term(T, Options)), - '$preprocess_read_terms_options'(Options,Module,DoComments), - '$read_vars'(Stream,T,Module,Pos,VL,'|: ',DoComments), - '$postprocess_read_terms_options'(Options, T, VL, Pos). - -% -% support flags to read -% -'$preprocess_read_terms_options'([], _, no). -'$preprocess_read_terms_options'([syntax_errors(NewVal)|L], Mod, DoComments) :- !, - '$get_read_error_handler'(OldVal), - set_value('$read_term_error_handler', OldVal), - '$set_read_error_handler'(NewVal), - '$preprocess_read_terms_options'(L,Mod, DoComments). -'$preprocess_read_terms_options'([module(Mod)|L], Mod, DoComments) :- !, - '$preprocess_read_terms_options'(L, Mod, DoComments). -'$preprocess_read_terms_options'([comments(Val)|L], Mod, Val) :- !, - '$preprocess_read_terms_options'(L, Mod, _). -'$preprocess_read_terms_options'([_|L],Mod, DoComments) :- - '$preprocess_read_terms_options'(L,Mod, DoComments). - -'$postprocess_read_terms_options'([], _, _, _). -'$postprocess_read_terms_options'([H|Tail], T, VL, Pos) :- !, - '$postprocess_read_terms_option'(H, T, VL, Pos), - '$postprocess_read_terms_options_list'(Tail, T, VL, Pos). - -'$postprocess_read_terms_options_list'([], _, _, _). -'$postprocess_read_terms_options_list'([H|Tail], T, VL, Pos) :- - '$postprocess_read_terms_option'(H, T, VL, Pos), - '$postprocess_read_terms_options_list'(Tail, T, VL, Pos). - -'$postprocess_read_terms_option'(syntax_errors(_), _, _, _) :- - get_value('$read_term_error_handler', OldVal), - '$set_read_error_handler'(OldVal). -'$postprocess_read_terms_option'(variable_names(Vars), _, Vars, _). -'$postprocess_read_terms_option'(singletons(Val), T, VL, _) :- - '$singletons_in_term'(T, Val1), - '$fetch_singleton_names'(Val1,VL,Val). -'$postprocess_read_terms_option'(variables(Val), T, _, _) :- - '$variables_in_term'(T, [], Val). -'$postprocess_read_terms_option'(comments(_), _, _, _). -'$postprocess_read_terms_option'(term_position(Pos), _, _, Pos). -'$postprocess_read_terms_option'(module(_), _, _, _). -%'$postprocess_read_terms_option'(cycles(Val), _, _). - -% problem is what to do about _ singletons. -% no need to do ordering, the two lists already come ordered. -'$fetch_singleton_names'([], _, []) :- !. -'$fetch_singleton_names'([V1|Ss], [(Na=V2)|Ns], ONs) :- - V1 == V2, !, - '$add_singleton_if_no_underscore'(Na,V2,NSs,ONs), - '$fetch_singleton_names'(Ss, Ns, NSs). -'$fetch_singleton_names'([V1|Ss], [N=V2|Ns], NSs) :- - V1 @< V2, !, - '$fetch_singleton_names'(Ss, [N=V2|Ns], NSs). -'$fetch_singleton_names'(_Ss, [], []). -'$fetch_singleton_names'(Ss, [_|Ns], NSs) :- -% V1 @> V2, !, - '$fetch_singleton_names'(Ss, Ns, NSs). - -'$add_singleton_if_no_underscore'(Name, _, NSs, NSs) :- - atom_codes(Name, [C|_]), C == 0'_ , !. %' -'$add_singleton_if_no_underscore'(Name, V2, NSs, [(Name=V2)|NSs]). /* meaning of flags for '$write' is 1 quote illegal atoms