1% ---------------------------------------------------------------------- 2% BEGIN LICENSE BLOCK 3% Version: CMPL 1.1 4% 5% The contents of this file are subject to the Cisco-style Mozilla Public 6% License Version 1.1 (the "License"); you may not use this file except 7% in compliance with the License. You may obtain a copy of the License 8% at www.eclipse-clp.org/license. 9% 10% Software distributed under the License is distributed on an "AS IS" 11% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 12% the License for the specific language governing rights and limitations 13% under the License. 14% 15% The Original Code is The ECLiPSe Constraint Logic Programming System. 16% The Initial Developer of the Original Code is Cisco Systems, Inc. 17% Portions created by the Initial Developer are 18% Copyright (C) 1989-2006 Cisco Systems, Inc. All Rights Reserved. 19% 20% Contributor(s): ECRC GmbH 21% Contributor(s): IC-Parc, Imperal College London 22% 23% END LICENSE BLOCK 24% 25% System: ECLiPSe Constraint Logic Programming System 26% Version: $Id: events.pl,v 1.30 2014/02/05 03:29:16 jschimpf Exp $ 27% ---------------------------------------------------------------------- 28 29/* 30 * SEPIA PROLOG SOURCE MODULE 31 */ 32 33/* 34 * IDENTIFICATION: events.pl, part of module(sepia_kernel) 35 * 36 * DESCRIPTION: 37 * 38 * 39 * CONTENTS: Event-Related Prolog Procedures and Declarations 40 * 41 */ 42 43:- system. 44:- pragma(nodebug). 45 46%------------------------------------ 47% error/event handling builtins 48%------------------------------------ 49 50get_error_handler(N, H, M) :- atom(N), !, 51 error(5,get_error_handler(N, H, M)). 52get_error_handler(N, H, M) :- 53 get_event_handler(N, H, M). 54 55current_error(N) :- 56 (var(N) -> 57 max_error(Max), 58 gen_valid_errors(1, Max, N) 59 ; 60 integer(N) -> 61 error_id(N, _) 62 ; 63 error(5, current_error(N)) 64 ). 65 66gen_valid_errors(Start, _Max, Start) :- 67 error_id(Start, _). 68gen_valid_errors(Start, Max, N) :- 69 Start < Max, 70 New is Start+1, 71 gen_valid_errors(New, Max, N). 72 73 74% The user-definable exit from a non-recoverable error. 75error_exit :- 76 throw(abort). 77 78%------------------------------------- 79% Here are the default error handlers 80% 81% Arguments of error handlers: 82% 1 Error integer or atom (identifies the error) 83% 2 Culprit usually a goal (but sometimes a clause, a N/A, etc) 84% 3 ContextModule context module (if not known, same as lookup module) 85% 4 LookupModule lookup module for the culprit (always a valid module, 86% except for error 86 NO_LOOKUP_MODULE) 87%------------------------------------- 88 89no_err_handler(X, Where) :- 90 write(error, 'no error handler, module has been erased,'), 91 nl(error), 92 error_message(X, Where). 93 94error_handler(X, Where) :- 95 error_message(X, Where), 96 error(157, _). 97 98:- tool(error_handler/3, error_handler/4). 99 100error_handler(X, Where, CM, LM) :- 101 error_message(X, Where, CM, LM), 102 error(157, _). 103 104 105%------------------------------------- 106% Undefined-call handler, may be redefined to fail, etc 107%------------------------------------- 108 109call_handler(X, Where, CM, LM) :- 110 atom(CM), % The context module may not be checked yet, 111 is_a_module(CM), % since this is normally done by the callee! 112 !, 113 error_id(X, Msg), 114 % Avoid loops by recursive calls due to macros: 115 % First remove 'm' or 'M' from the output flags so that we don't 116 % hit undefined 'print attribute' predicates 117 output_mode(Mode), 118 string_list(Mode, ModeL), 119 (member(0'm, ModeL) -> 120 delete(0'm, ModeL, NewModeL) 121 ; 122 member(0'M, ModeL) -> 123 delete(0'M, ModeL, NewModeL) 124 ; 125 NewModeL = ModeL 126 ), 127 string_list(NewMode, NewModeL), 128 % And then disable write macros. This unfortunately also disables 129 % goal macros which would not loop anyway... 130 concat_string(['%w %', NewMode, 'Tw in module %w%n'], Format), 131 ( CM == LM -> QualWhere = Where ; QualWhere = LM:Where ), 132 printf_body(error, Format, [Msg,QualWhere,CM], CM), 133 error(157, _). 134call_handler(_, Where, CM, _) :- 135 error(80, Where@CM). 136 137 138%------------------------------------- 139% Autoload and lazy predicate creation 140%------------------------------------- 141 142:- pragma(nodebug). 143:- unskipped autoload_handler/4. 144:- untraceable autoload_handler/4. 145autoload_handler(_, Goal, CM, LM) :- 146 atom(CM), % The context module is not checked yet, 147 is_a_module(CM), % since this is normally done by the callee! 148 !, 149 ( try_create_pred(Goal, LM) -> 150 ( LM==CM -> 151 call(Goal)@CM 152 ; 153 :@(LM, Goal, CM) 154 ) 155 ; 156 error(68, Goal, CM)@LM 157 ). 158autoload_handler(_, Goal, CM, _) :- 159 error(80, Goal@CM). 160 161 162try_create_pred(Goal, LM) :- 163 functor(Goal, Name, Arity), 164 ( is_lazy_pred(LM, Name, Arity, Tool, Body, Proto) -> 165 166 % Create the body, unless it exists already 167 ( get_flag(Body, defined, on) -> 168 true 169 ; 170 Body = BName/N1, 171 create_call_n(BName, N1) 172 ), 173 % Create the tool, unless it exists already 174 ( get_flag(Tool, tool, on) -> 175 true 176 ; 177 tool(Tool, Body), 178 export(Tool) 179 ), 180 % Create same visibility as Proto 181 ( get_flag(Proto, visibility, imported)@LM -> 182 (import Tool from sepia_kernel)@LM 183 ; get_flag(Proto, visibility, reexported)@LM -> 184 (reexport Tool from sepia_kernel)@LM 185 ; 186 true 187 ) 188 189 ; % Autoloading 190 get_flag(Name/Arity, autoload, on)@LM, % may fail 191 get_unqualified_goal(Goal, UnQualGoal), 192 mutex_lib(UnQualGoal, LM) 193 ). 194 195is_lazy_pred(LM, Name, Arity, Tool, Body, Proto) :- 196 multi_arity_pred(Name, Arity, Tool, Body, Proto), 197 arity(Body) =< get_flag(max_predicate_arity), 198 % is the visible prototype the standard one? 199 get_flag(Proto, definition_module, DM)@LM, 200 ( DM==sepia_kernel -> true ; DM==iso_strict ). 201 202multi_arity_pred(call, N, call/N, call_/N1, call/1) :- N1 is N+1, N>1. 203multi_arity_pred(call_, N1, call/N, call_/N1, call/1) :- N is N1-1, N>1. 204multi_arity_pred((:), N, (:)/N, (:@)/N1, (:)/2) :- N1 is N+1, N>2. 205multi_arity_pred((:@), N1, (:)/N, (:@)/N1, (:)/2) :- N is N1-1, N>2. 206 207 208?- local variable(autoload_lock). 209?- mutex_init(autoload_lock). 210mutex_lib(Goal, CallerModule) :- 211 mutex(autoload_lock, ( 212 get_autoload_info(Goal, CallerModule, File, HomeModule) -> 213 ensure_loaded_skip(library(File), HomeModule) 214 ; 215 true % already loaded (maybe by other worker) 216 )). 217 218% fails if predicate is defined in the meantime 219get_autoload_info(Goal, CallerModule, HomeModule, HomeModule) :- 220 functor(Goal, N, A), 221 proc_flags(N/A, 14, off, CallerModule), % get_flag(N/A, defined, off) 222 proc_flags(N/A, 0, HomeModule, CallerModule). 223 224 225% Some hacking here to suppress tracing of metacalls during ensure_loaded 226:- pragma(debug). 227ensure_loaded_skip(File, Module) :- 228 % need the (untraceable) CALL port here for skipping 229 ensure_loaded_silent(File, Module). 230:- pragma(nodebug). 231 232:- untraceable ensure_loaded_silent/2. 233:- skipped ensure_loaded_silent/2. 234ensure_loaded_silent(File, Module) :- 235 ensure_loaded(File, Module). 236 237 238%------------------------------------- 239% Handler for error 86 - lookup module does not exist. 240%------------------------------------- 241 242% Culprit is an ok goal, but LM is an atom but not a module. 243% If there is a library called LM, we try to load it. 244:- unskipped no_lookup_module_handler/4. 245:- untraceable no_lookup_module_handler/4. 246no_lookup_module_handler(N, Goal, CM, LM) :- !, 247 getval(prolog_suffix, ECLs), 248 getval(eclipse_object_suffix, ECO), 249 ( existing_file(library(LM), [ECO|ECLs], [readable], _) -> 250 printf(warning_output, 251 "WARNING: module '%w' does not exist, loading library...%n", 252 [LM]), 253 ensure_loaded_skip(library(LM), CM), 254 ( is_a_module(LM) -> 255 :@(LM, Goal, CM) 256 ; 257 error_handler(N, Goal, CM, LM) 258 ) 259 ; 260 error_handler(N, Goal, CM, LM) 261 ). 262 263 264%------------------------------------- 265% End-of-compilation warnings 266%------------------------------------- 267 268 % suppress these warnings until autoloading is done properly 269declaration_warning_handler(_N, _Pred, lists) :- !. 270declaration_warning_handler(_N, _Pred, profile) :- !. 271declaration_warning_handler(75, Pred, Module) :- !, 272 get_flag_body(Pred, definition_module, DM, Module), 273 get_deprecation_advice(Pred, DM, Advice), 274 !, 275 warning_handler(75, Pred, Module), 276 printf(warning_output, " Advice: %w%n", [Advice]). 277 % suppress the warning if there is such a library 278declaration_warning_handler(85, BadModule:_, _Module) :- 279 known_library(BadModule), 280 !. 281 % suppress the warning if predicate will be created lazily 282declaration_warning_handler(84, LM:N/A, _Module) ?- 283 is_lazy_pred(LM, N, A, _, _, _), 284 !. 285declaration_warning_handler(N, Pred, Module) :- 286 warning_handler(N, Pred, Module). 287 288 % modules for which we raise no warning 85 289 known_library(daVinci) :- !. % because not in runtime system 290 known_library(ic_gap_sbds) :- !. % because not in runtime system 291 known_library(ic_gap_sbdd) :- !. % because not in runtime system 292 known_library(Module) :- 293 getval(prolog_suffix, ECLs), 294 getval(eclipse_object_suffix, ECO), 295 once existing_file(library(Module), [ECO|ECLs], [readable], _). 296 297 298%------------------------------------- 299% General warnings 300%------------------------------------- 301 302warning_handler(X, Where) :- 303 write(warning_output, 'WARNING: '), 304 warning_message(X, Where). 305 306warning_handler(X, Where, Module) :- 307 write(warning_output, 'WARNING: '), 308 warning_message(X, Where, Module). 309 310 311%------------------------------------- 312% Undefined global entities 313%------------------------------------- 314 315undef_array_handler(N, setval_body(Name, Value, Module), _) :- !, 316 undef_array_handler(N, setval(Name, Value), Module). 317undef_array_handler(N, getval_body(Name, Value, Module), _) :- !, 318 undef_array_handler(N, getval(Name, Value), Module). 319undef_array_handler(_N, setval(Name, Value), Module) :- 320 atom(Name), 321 !, 322 ( current_module(M), not is_locked(M), current_array(Name, _)@M -> 323 % there's one in another module, probably error 324 printf(warning_output, 325 "WARNING: creating local variable(%w) in %w while there exists one in %w%n", 326 [Name, Module, M]) 327 ; 328 true % create it silently 329 ), 330 make_array_(Name, prolog, local, Module), 331 setval_body(Name, Value, Module). 332undef_array_handler(N, Goal, Module) :- 333 error_handler(N, Goal, Module). 334 335 336make_array_handler(42, Culprit, Module, LM) :- 337 !, 338 make_array_args(Culprit, Array, Type, Visibility), 339 ( current_array(Array, [Type,Visibility])@Module -> 340 true % it's the same 341 ; 342 warning_handler(42, Culprit), 343 functor(Array, N, A), 344 erase_array_(N/A, visible, Module), 345 :@(LM,Culprit,Module) 346 ). 347make_array_handler(N, Culprit, Module, LM) :- 348 error_handler(default(N), Culprit, Module, LM). 349 350 make_array_args(make_array(Array, Type), Array, Type, global). 351 make_array_args(make_local_array(Array, Type), Array, Type, local). 352 make_array_args(local(variable(Array)), Array, prolog, local) :- !. 353 make_array_args(local(variable(Array,_)), Array, prolog, local) :- !. 354 make_array_args(global(variable(Array)), Array, prolog, global) :- !. 355 make_array_args(local(reference(Array)), Array, reference, local) :- !. 356 make_array_args(global(reference(Array)), Array, reference, global) :- !. 357 make_array_args(local(reference(Array,_)), Array, reference, local) :- !. 358 make_array_args(local(array(Array, Type)), Array, Type, local) :- !. 359 make_array_args(local(array(Array)), Array, prolog, local) :- !. 360 make_array_args(global(array(Array, Type)), Array, Type, global) :- !. 361 make_array_args(global(array(Array)), Array, prolog, global) :- !. 362 363 364undef_record_handler(_N, Culprit) :- 365 extract_record_key(Culprit, Key, Module), 366 !, 367 ( current_module(M), not is_locked(M), current_record(Key)@M -> 368 printf(warning_output, 369 "WARNING: creating local record(%w) in %w while there exists one in %w%n", 370 [Key, Module, M]) 371 ; 372 true % create it silently 373 ), 374 functor(Key, K, A), 375 local_record_body(K/A, Module), 376 call(Culprit). % Culprit is a kernel tool body, so call/1 is ok 377undef_record_handler(N, Culprit) :- 378 error_handler(N, Culprit). 379 380 extract_record_key(recorda_body(Key,_,M), Key, M). 381 extract_record_key(recordz_body(Key,_,M), Key, M). 382 extract_record_key(recorda_body(Key,_,_,M), Key, M). 383 extract_record_key(recordz_body(Key,_,_,M), Key, M). 384 385 386%------------------------------------- 387% Syntax error handling 388%------------------------------------- 389 390parser_error_handler(N, Goal, M):- 391 ( extract_module(Goal, CM) -> true ; CM = M ), 392 error_id(N, Id), 393 ( extract_stream(Goal, Stream) -> 394 get_context_and_skip_forward(Stream, Context), 395 ( get_flag(syntax_option, iso_restrictions)@CM -> %%% temporary 396 % ISO style: throw error term 397 throw(error(syntax_error(Id), Context)) 398 ; 399 % old ECLiPSe style: print error directly, then fail 400 print_syntax_error(Id, Context), 401 fail 402 ) 403 ; 404 error_message(N, Goal), 405 fail 406 ). 407 408 409% Print syntax error, can be done from handler or after throw/catch 410print_syntax_error(Id, context(_Stream, Device, Name, Line, String, From, Where)) ?- !, 411 % Don't use Stream, it may be closed/stale. 412 ( Device==tty -> 413 true % no need 414 ; 415 printf(error, "%s %w", [Device,Name]), 416 ( Line > 1 -> printf(error, ", line %d", [Line]) ; true ), 417 printf(error, ": ", []) 418 ), 419 printf(error, "syntax error: %s%n", Id), 420 ( String == "" -> 421 true 422 ; 423 printf(error, "| %s%n", String), 424 Num is Where - From - 1, 425 string_print_length(String, 2, Num, Skip), 426 printf(error, "| %*c^ here%n", [Skip, 0' ]) 427 ), 428 flush(error). 429print_syntax_error(Id, Context) :- 430 printf(error, "syntax error: %s in %w%n%b", [Id,Context]). 431 432 433get_context_and_skip_forward(Stream, 434 context(Stream, DevName, Name, ErrLine, String, From, Where)) :- 435 stream_info_(Stream, 13, Device), 436 stream_info_(Stream, 6, Where), 437 short_stream_name(Device, DevName, Stream, Name), 438 stream_info_(Stream, 5, Line), 439 get_context_strings(Device, Stream, Where, From, Left, Right, NewLine), 440 concat_strings(Left, Right, String), 441 ErrLine is Line-NewLine, 442 set_stream_prop_(Stream, 5, Line). % reset the line number 443 444 445% Get some left and right context of the error. This is rather tricky, 446% especially when we can't freely seek on the device. Also, skip further 447% input, how much depends on what device we are reading from. 448% Make sure line numbers are repaired after seeking. 449get_context_strings(Device, Stream, Pos, From, Left, Right, NewLine) :- 450 ( Device==file ; Device==string ), % fully seekable devices 451 !, 452 seek_left_context(Stream, 70, 0, Pos, From, Left, NewLine), 453 % skip forward to fullstop 454 skip_to_eocl(Stream), 455 % get limited amount of right context 456 ( NewLine > 0 -> 457 Right = "" 458 ; 459 at(Stream, EndPos), 460 stream_info_(Stream, 5, Line), % save 461 MaxRight is 80-(From-Pos), 462 seek(Stream, Pos), 463 N is min(EndPos-Pos,MaxRight), 464 read_string(Stream, end_of_line, N, Right), 465 seek(Stream, EndPos), 466 set_stream_prop_(Stream, 5, Line) % restore 467 ). 468get_context_strings(Device, Stream, Pos, From, Left, Right, NewLine) :- 469 ( Device==pipe ; Device==socket ; Device==tty ), % buffer seekable 470 !, 471 stream_info_(Stream, 14, SeekLimit), % buffer start 472 seek_left_context(Stream, 70, SeekLimit, Pos, From, Left, NewLine), 473 ( Device==tty -> 474 % For tty, skip to end of line, unless already there 475 ( NewLine > 0 -> Skipped="" 476 ; read_string(Stream, end_of_line, _, Skipped) 477 ) 478 ; 479 % Do a rough skip, as we can't seek back to get the context 480 skip_to_eocl_collect(Stream, Cs), 481 string_list(Skipped, Cs) 482 ), 483 % get limited amount of right context 484 ( NewLine > 0 -> 485 Right = "" 486 ; 487 MaxRight is 80-(From-Pos), 488 split_string(Skipped, "\n", "", [RestLine|_]), 489 ( MaxRight < string_length(RestLine) -> 490 first_substring(RestLine, 1, MaxRight, Right) 491 ; 492 Right = RestLine 493 ) 494 ). 495get_context_strings(_Device, _Stream, _Pos, 0, "", "", 0). % queue or null 496 497 498 % Get context left of current position Pos, maximum Max bytes. 499 % Return starting position From, string Left, and line end flag NewLine 500 seek_left_context(Stream, Max, SeekLimit, Pos, From, Left, NewLine) :- 501 stream_info_(Stream, 5, Line), % save 502 Back is min(Pos-SeekLimit,Max), 503 BackPos is Pos-Back, 504 seek(Stream, BackPos), 505 read_string(Stream, "", Back, Left1), 506 split_string(Left1, "\n", "", LeftParts), 507 last_nonempty_string(LeftParts, Left, NewLine), 508 From is Pos-string_length(Left)-NewLine, 509 set_stream_prop_(Stream, 5, Line). % restore 510 511 last_nonempty_string([S|Ss], Last, NewLine) :- 512 ( Ss=[] -> Last=S, NewLine=0 513 ; Ss=[""] -> Last=S, NewLine=1 514 ; last_nonempty_string(Ss, Last, NewLine) 515 ). 516 517 518% For seekable streams: skip token-wise to fullstop or end of stream 519skip_to_eocl(Stream) :- 520 ( at_eof(Stream) -> 521 true 522 ; 523 read_token(Stream, _, Class), 524 ( Class==fullstop -> true 525 ; Class==end_of_file -> true 526 ; skip_to_eocl(Stream) 527 ) 528 ). 529 530% Skip to something that looks like fullstop, collecting the skipped text 531skip_to_eocl_collect(Stream, Cs) :- 532 ( at_eof(Stream) -> Cs=[] ; 533 get(Stream, C), 534 ( C < 0 -> Cs=[] 535 ; C==0'. -> Cs=[C|Cs1], skip_to_eocl_collect1(Stream, Cs1) 536 ; get_chtab(C, terminator) -> Cs=[C] 537 ; Cs=[C|Cs1], skip_to_eocl_collect(Stream, Cs1) 538 ) 539 ). 540 541 skip_to_eocl_collect1(Stream, Cs) :- 542 ( at_eof(Stream) -> Cs=[] ; 543 get(Stream, C), 544 ( C < 0 -> Cs=[] 545 ; get_chtab(C, blank_space) -> Cs=[] 546 ; get_chtab(C, end_of_line) -> Cs=[] 547 ; C==0'. -> Cs=[C|Cs1], skip_to_eocl_collect1(Stream, Cs1) 548 ; Cs=[C|Cs1], skip_to_eocl_collect(Stream, Cs1) 549 ) 550 ). 551 552:- mode short_stream_name(+,-,+,-). 553short_stream_name(file, file, Stream, File) :- !, 554 stream_info_(Stream, 0, Name), 555 local_file_name(Name, File). 556short_stream_name(queue, 'queue stream', Stream, Stream) :- !. 557short_stream_name(string, 'string stream', Stream, Stream) :- !. 558short_stream_name(null, 'null stream', _Stream, null) :- !. 559short_stream_name(Device, Device, Stream, Name) :- % tty,socket,pipe,null 560 stream_info_(Stream, 0, Name). 561 562 563%------------------------------------- 564 565singleton_in_loop(N, Occurrence) :- 566 ( Occurrence = quantified(Name) -> 567 printf(warning_output, 568 "*** Warning: Singleton local variable %a in do-loop (not used in loop body)%n", 569 [Name]) 570 ; Occurrence = unquantified(Name) -> 571 printf(warning_output, 572 "*** Warning: Singleton local variable %a in do-loop, maybe param(%a) missing?%n", 573 [Name,Name]) 574 ; 575 error_handler(N, Occurrence) 576 ), 577 ( compiled_file(File, Line) -> 578 printf(warning_output, "\tbefore line %d in file %s%n", [Line, File]) 579 ; 580 true 581 ), 582 flush(warning_output). 583 584% extract_stream(Goal, Stream) 585:- mode extract_stream(+, -). 586extract_stream(read(_), input). 587extract_stream(read_(_, _), input). 588extract_stream(readvar(S, _, _), S). 589extract_stream(readvar(S, _, _, _), S). 590extract_stream(read_annotated_raw(S, _, _, _), S). 591extract_stream(read_string(_, _, _), input). 592extract_stream(read_string(S, _, _, _), S). 593extract_stream(read_string(S, _, _, _, _), S). 594extract_stream(read(S, _), S). 595extract_stream(read_(S, _, _), S). 596extract_stream(read_token(S, _, _), S). 597extract_stream(read_token_(S, _, _, _), S). 598extract_stream(read_exdr(S, _), S). 599extract_stream(compile_stream(S), S). 600extract_stream(compile_stream_(S, _), S). 601extract_stream(get(_), input). 602extract_stream(get(S, _), S). 603extract_stream(get0(_), input). 604extract_stream(get0(S, _), S). 605extract_stream(get_char(_), input). 606extract_stream(get_char(S, _), S). 607extract_stream(getw(S, _), S). 608extract_stream(tyi(_), input). 609extract_stream(tyi(S, _), S). 610extract_stream(tyo(_), output). 611extract_stream(tyo(S, _), S). 612extract_stream(flush(S), S). 613extract_stream(format(_, _), output). 614extract_stream(format(S, _, _), S). 615extract_stream(format_body(_, _, _), output). 616extract_stream(format_body(S, _, _, _), S). 617extract_stream(printf(_, _), output). 618extract_stream(printf(S, _, _), S). 619extract_stream(printf_body(_, _, _), output). 620extract_stream(printf_body(S, _, _, _), S). 621extract_stream(write(_), output). 622extract_stream(write(S, _), S). 623extract_stream(write_(_, _), output). 624extract_stream(write_(S, _, _), S). 625extract_stream(write_term(S,_,_,_,_,_,_), S). 626extract_stream(writeln_body(_,_), output). 627extract_stream(writeln_body(S,_,_), S). 628extract_stream(writeln(_), output). 629extract_stream(writeln(S,_), S). 630extract_stream(nl, output). 631extract_stream(nl(S), S). 632extract_stream(close(S), S). 633 634% This should be replaced with a more generic way of getting 635% the context module from a tool body goal 636:- mode extract_module(+, -). 637extract_module(read_(_, M), M). 638extract_module(readvar(_, _, _, M), M). 639extract_module(read_annotated_raw(_, _, _, M), M). 640extract_module(read_(_, _, M), M). 641extract_module(read_token_(_, _, _, M), M). 642extract_module(compile_stream_(_, M), M). 643extract_module(format_body(_, _, M), M). 644extract_module(format_body(_, _, _, M), M). 645extract_module(printf_body(_, _, M), M). 646extract_module(printf_body(_, _, _, M), M). 647extract_module(write_(_, M), M). 648extract_module(write_(_, _, M), M). 649extract_module(writeln_body(_,M), M). 650extract_module(writeln_body(_,_,M), M). 651 652 653%------------------------------------- 654% I/O event handling 655%------------------------------------- 656 657% eof_handler/4 - take the appropriate action for each culprit 658% CARE: eof_handler/4 fails for other culprits 659 660eof_handler(N, Goal, Module, LM) :- 661 extract_stream(Goal, Stream), 662 ( stream_info_(Stream, 19, on) -> % yield 663 stream_info_(Stream, 4, PhysicalStream), 664 (is_remote_sync_queue(PhysicalStream, _, ControlStream) -> 665 remote_input(PhysicalStream, ControlStream) 666 ; 667 yield(6, PhysicalStream, _) % 6 == PWAITIO == EC_waitio 668 ), 669 :@(LM, Goal, Module) 670 ; 671 eof_handler(N, Goal) 672 ). 673 674 675:- mode eof_handler(++, +). 676eof_handler(_, read(end_of_file)). 677eof_handler(_, read_(end_of_file, _)). 678eof_handler(_, read(_, end_of_file)). 679eof_handler(_, read_(_, end_of_file, _)). 680eof_handler(_, read_exdr(_, _)) :- fail. 681eof_handler(_, readvar(_, end_of_file, [])). 682eof_handler(_, readvar(_, end_of_file, [], _)). 683eof_handler(_, read_token(_, end_of_file, end_of_file)). 684eof_handler(_, read_token_(_, end_of_file, end_of_file, _)). 685eof_handler(_, read_string(_, _, _)) :- fail. 686eof_handler(_, read_string(_, _, _, _)) :- fail. 687eof_handler(_, compile_stream(_)). 688eof_handler(_, compile_stream_(_,_)). 689eof_handler(_, get(-1)). 690eof_handler(_, get(_, -1)). 691eof_handler(_, get0(-1)). 692eof_handler(_, get0(_, -1)). 693eof_handler(_, tyi(-1)). 694eof_handler(_, tyi(_, -1)). 695eof_handler(_, get_char(_)) :- fail. 696eof_handler(_, get_char(_, _)) :- fail. 697eof_handler(_, getw(_, end_of_file)). 698eof_handler(_, read_annotated_raw(S, 699 annotated_term(end_of_file,end_of_file,File,Line,End,End), 0, _)) :- 700 stream_info_(S, 0 /*name*/, File), 701 stream_info_(S, 5 /*line*/, Line), 702 at(S, End). 703 704 705past_eof_handler(N, Goal) :- 706 extract_stream(Goal, Stream), 707 stream_info_(Stream, 37, Action), % eof_action 708 ( Action == error -> 709 close(Stream, [force(true)]), 710 error_handler(N, Goal) 711 ; 712 % Action == eof_code -> 713 % Action == reset -> % should never happen! 714 eof_handler(N, Goal) 715 ). 716 717 718%------------------------------------- 719% Compilation related handlers 720%------------------------------------- 721 722compiler_warning_handler(N, Proc) :- 723 ( ( nonvar(Proc), Proc=Term@File:Line 724 ; compiled_file(File, Line), Term=Proc) -> 725 write(error, '\n*** '), 726 error_id(N, M), 727 write(error, M), 728 write(error, ': '), 729 printf_with_current_modes(error, Term), 730 (Line > 0 -> 731 printf(error, "\n\tbefore line %d in the file %s", 732 [Line, File]) 733 ; 734 true 735 ), 736 nl(error), 737 flush(error) 738 ; 739 error_handler(N, Proc) 740 ). 741 742compiler_error_handler(N, Proc) :- 743 compiler_warning_handler(N, Proc), 744 fail. 745 746compiler_abort_handler(N, File, _Module) :- 747 error_id(N, M), 748 printf(error, "\n*** %s", M), 749 (compiled_file(File, Line) -> 750 (Line > 0 -> 751 printf(error, "\n\tbefore line %d in the file %s", 752 [Line, File]) 753 ; 754 true 755 ) 756 ; 757 printf(error, " in the file %s\n", File) 758 ), 759 nl(error), 760 flush(error). 761 762pragma_handler(148, pragma(Pragma), Module) :- 763 record_pragma(Pragma, Module), !. 764pragma_handler(N, Proc, _Module) :- 765 compiler_error_handler(N, Proc). 766 767 768compiled_file_handler(N, (File, Size, Time), Module) :- !, 769 compiled_file_handler(N, File, Size, Time, Module). 770compiled_file_handler(N, Goal, Module) :- 771 error_handler(N, Goal, Module). 772 773compiled_file_handler(_, term, _, _, _) :- !. 774compiled_file_handler(_, File, Size, Time, _Module) :- 775 ( File = source(Source) -> 776 true 777 ; 778 local_file_name(File, Source) 779 ), 780 ( Size < 0 -> 781 printf(log_output, "%-10s loaded in %.2f seconds\n%b", 782 [Source, Time]) 783 ; 784 printf(log_output, "%-10s compiled %d bytes in %.2f seconds\n%b", 785 [Source, Size, Time]) 786 ). 787 788 789% end of loading a code unit: do any finishing up work 790unit_loaded_handler(_, Options, Module) :- 791 run_stored_goals(initialization_goals, Module), 792 ( memberchk(check, Options) -> 793 record(compiled_modules, Module) 794 ; 795 true 796 ). 797 798 799record_compiled_file_handler(_, File-Goal, Module) :- 800 canonical_path_name(File, CanonicalFile0), 801 ( string(CanonicalFile0) -> 802 atom_string(CanonicalFile, CanonicalFile0) 803 ; 804 CanonicalFile = CanonicalFile0 805 ), 806 record_compiled_file(CanonicalFile, Goal, Module). 807 808 809local_file_name(File:Line, LocalF:Line) :- !, 810 local_file_name(File, LocalF). 811local_file_name(File, LocalF) :- 812 getcwd(Cwd), 813 atom_string(File, FileS), 814 (substring(FileS, Cwd, 1) -> 815 Pos is string_length(Cwd) + 1, 816 Len is string_length(FileS) - Pos + 1, 817 first_substring(FileS, Pos, Len, LocalF) 818 ; 819 LocalF = File 820 ). 821 822:- export redef_other_file_handler/2. 823redef_other_file_handler(_, (Pred, OldFile0, NewFile0)) :- 824 local_file_name(OldFile0, OldFile), 825 local_file_name(NewFile0, NewFile), 826 printf(warning_output, "WARNING: %w in file %w replaces previous definition in file %w%n", 827 [Pred,NewFile,OldFile]). 828 829 830:- mode library_module(++, -). 831library_module(library(File), File) :- !. 832library_module(File, File). 833 834error_message(X, Where):- 835 error_id(X, M), 836 write(error, M), 837 write(error, ' in '), 838 printf_goal(error, Where), 839 nl(error), 840 flush(error). 841 842 843% What's all these different modules? 844% 845% CM LM TrueLM UsedLM 846% :- module(lm). 847% ?- lm1:p(X). lm lm lm1 lm1 848% prints "error in lm1:p(X)" using lm1's syntax 849% 850% :- module(lm). 851% :- import p/1 from lm1. 852% ?- lm1:p(X). lm lm lm1 lm 853% prints "error in p(X)" using lm's syntax 854% ?- p(X). lm lm lm lm 855% prints "error in p(X)" in lm's syntax 856% 857% :- module(lm). 858% ?- lm1:p(X)@cm. cm lm lm1 lm1 859% prints "error in lm1:p(X) in module cm" using lm1's syntax 860% 861% :- module(lm). 862% :- import p/1 from lm1. 863% ?- lm1:p(X)@cm. cm lm lm1 lm 864% prints "error in p(X) in module cm" using lm's syntax 865% ?- p(X)@cm. cm lm lm lm 866% prints "error in p(X) in module cm" using lm's syntax 867 868 869error_message(X, Goal, CM, LM):- 870 error_id(X, M), 871 write(error, M), 872 write(error, ' in '), 873 874 % Strip off any module qualifier to find the true lookup module 875 unqualify(Goal, LM, TrueLM, PlainGoal), 876 877 % Add back a qualifier only if predicate not anyway visible in LM 878 qualify_goal_if_needed(PlainGoal, LM, TrueLM, QualGoal, UsedLM), 879 880 % Print the goal using the syntax from one of the lookup modules, 881 % to make sure we have the relevant goal output transformations. 882 % We prefer LM to TrueLM because that might have some user's trans- 883 % formations in addition, which may be needed for goal's arguments. 884 ( is_a_module(UsedLM) -> 885 printf_goal_body(error, QualGoal, UsedLM) 886 ; 887 printf_goal(error, QualGoal) 888 ), 889 890 % If we have an interesting context module, print it 891 ( atom(CM), is_a_module(CM), not is_locked(CM), CM \== LM -> 892 write(error, ' in module '), 893 write(error, CM) 894 ; 895 true 896 ), 897 nl(error), 898 flush(error). 899 900 901warning_message(X, Where):- 902 error_id(X, M), 903 write(warning_output, M), 904 write(warning_output, ' in '), 905 printf_goal(warning_output, Where), 906 nl(warning_output), 907 flush(warning_output). 908 909warning_message(X, Where, Module):- 910 error_id(X, M), 911 write(warning_output, M), 912 write(warning_output, ' in '), 913 printf_goal_body(warning_output, Where, Module), 914 write(warning_output, ' in module '), 915 write(warning_output, Module), 916 nl(warning_output), 917 flush(warning_output). 918 919/* Finally boot_error/2 can be properly redefined. It is used 920 * as error handler when no error handler can be found 921 */ 922boot_error(N, Goal) :- 923 write(error, 'no error handler: '), 924 ( error_message(N, Goal) -> 925 compiled_file(File, Line), 926 (Line > 0 -> 927 printf(error, "\n\tbefore line %d in the file %s", 928 [Line, File]) 929 ; 930 true 931 ), 932 nl(error), 933 exit0(-1) % to avoids loops in error 152 in exit/1 934 ; 935 writeln(error, N) 936 ). 937 938 939output_error_handler(X, Culprit, CM, LM):- 940 ( Culprit = close(_) -> 941 true 942 ; 943 extract_stream(Culprit, S), 944 close(S) 945 ), 946 system_error_handler(X, Culprit, CM, LM). 947 948 949% This handler is called when we were trying to close one of the predefined 950% streams, whether explicitly or via their handle or another alias. 951 952close_handler(E, close(Stream, Options)) ?- !, 953 get_stream(Stream, Handle), 954 ( default_stream(_, Stream) -> 955 % Don't close stdin etc. 956 flush_if_output(Stream) 957 958 ; default_stream(_, FixedStream), 959 get_stream(FixedStream, Handle) -> 960 % Trying to close another alias or the handle of a fixed stream: 961 % don't close it! Erase alias, unless a predefined one. 962 flush_if_output(Stream), 963 erase_alias(Stream) 964 965 ; default_stream(Stream, FixedStream) -> 966 % Allow closing default streams explicitly via the user_xxx alias. 967 % Close user_xxx's handle after setting alias back to stdxxx. 968 set_stream(Stream, FixedStream), 969 close(Handle, Options) 970 971 ; default_stream(DefaultStream, _), 972 get_stream(DefaultStream, Handle) -> 973 % Trying to close a stream that is in use as a default stream: 974 % don't close it! Erase alias, unless a predefined one. 975 flush_if_output(Stream), 976 erase_alias(Stream) 977 978 ; current_stream(Stream, DefaultStream) -> 979 % close current stream handle after setting alias back to default 980 set_stream(Stream, DefaultStream), 981 close(Handle, Options) 982 983 ; current_stream(CurrentStream, DefaultStream), 984 get_stream(CurrentStream, Handle) -> 985 % reset current stream that was redirected to Handle, and try again 986 set_stream(CurrentStream, DefaultStream), 987 close(Stream, Options) 988 ; 989 % should not occur 990 error_handler(E, close(Stream, Options)) 991 ). 992close_handler(_, close(Stream)) ?- !, 993 close_handler(_, close(Stream, [])). 994close_handler(ErrorNumber, Goal) :- 995 error_handler(ErrorNumber, Goal). 996 997 % The 'current' streams, and the 'default' streams to reset them to 998 :- mode current_stream(?,?,-,-). 999 current_stream(input, user_input). 1000 current_stream(output, user_output). 1001 current_stream(warning_output, user_output). 1002 current_stream(log_output, user_output). 1003 current_stream(error, user_error). 1004 1005 % The 'default' streams, and the 'fixed' streams to reset them to 1006 default_stream(user_input, stdin). 1007 default_stream(user_output, stdout). 1008 default_stream(user_error, stderr). 1009 default_stream(null, null). 1010 1011 erase_alias(stdin) :- !. 1012 erase_alias(stdout) :- !. 1013 erase_alias(stderr) :- !. 1014 erase_alias(user_input) :- !. 1015 erase_alias(user_output) :- !. 1016 erase_alias(user_error) :- !. 1017 erase_alias(input) :- !. 1018 erase_alias(output) :- !. 1019 erase_alias(error) :- !. 1020 erase_alias(warning_output) :- !. 1021 erase_alias(log_output) :- !. 1022 erase_alias(null) :- !. 1023 erase_alias(Stream) :- atom(Stream), !, erase_stream_property(Stream). 1024 erase_alias(_). 1025 1026 flush_if_output(Stream) :- 1027 ( stream_info_(Stream, 35/*output*/, true) -> flush(Stream) ; true ). 1028 1029 1030% Currently only used for output goals 1031io_yield_handler(_, Goal) :- 1032 extract_stream(Goal, Stream), 1033 stream_info_(Stream, 4, PhysicalStream), 1034 % recover memory used during yielding by \+\+ 1035 \+ \+ do_stream_yield(PhysicalStream). 1036 1037do_stream_yield(PhysicalStream) :- 1038 (is_remote_sync_queue(PhysicalStream, RemoteStream, ControlStream) -> 1039 remote_output(PhysicalStream, ControlStream, RemoteStream) 1040 ; yield(7, PhysicalStream, _) 1041 % 7 == PFLUSHIO == EC_flushio 1042 ). 1043 1044 1045% This is the handler for all errors from the operating system. It has 1046% special treatment for "Interrupted system call" and will restart certain 1047% builtins in that case. The advantage of doing this through the handler 1048% rather than directly in C is that this gives the system a chance to 1049% run a synchronous interrupt handler before the goal gets restarted. 1050 1051system_error_handler(E, Goal, CM, LM):- 1052 errno_id(Msg), 1053 ( Msg = "Interrupted system call", restartable_builtin(Goal) -> 1054 :@(LM, Goal, CM) 1055 ; 1056 error_id(E, EclMsg), 1057 printf(error, "%w: %w in ", [EclMsg, Msg]), 1058 printf_goal(error, Goal), 1059 nl(error), 1060 flush(error), 1061 error(157, _) 1062 ). 1063 1064 % Builtins that can raise EINTR and can be restarted after that 1065 restartable_builtin(accept(_,_,_)). 1066 restartable_builtin(cd(_)). 1067 restartable_builtin(open(_,_,_)). 1068 restartable_builtin(close(_)). 1069 restartable_builtin(close(_,_)). 1070 restartable_builtin(connect(_,_)). 1071 restartable_builtin(stream_select(_,_,_)). 1072 restartable_builtin(wait(_,_,_)). 1073 1074 1075dynamic_handler(_, dynamic(Name/Arity), Module) :- 1076 !, 1077 functor(F, Name, Arity), 1078 retract_all_body(F, Module). 1079dynamic_handler(N, Proc, Module) :- 1080 error_handler(N, Proc, Module). 1081 1082macro_handler(N, define_macro(T, P, F), M) :- !, 1083 macro_handler(N, define_macro_(T, P, F, M), _). 1084macro_handler(N, define_macro_(T, QP, F, M), _) :- 1085 unqualify(QP, M, LMnew, P), 1086 ( 1087 current_macro_body(T, P, F1, LMold, M), 1088 same_macro_flags(F, F1), 1089 same_trans_pred(P, LMnew, LMold) 1090 -> 1091 true % don't warn, definitions are the same 1092 ; 1093 warning_handler(N, define_macro(T, P, F), M), 1094 erase_macro_(T, F, M), 1095 define_macro_(T, P, F, M) 1096 ). 1097 1098 same_macro_flags(A, B) :- 1099 subtract(A, [local,read,term], A1), sort(A1, NormFlags), 1100 subtract(B, [local,read,term], B1), sort(B1, NormFlags). 1101 1102 same_trans_pred(_P, M, M) :- !. 1103 same_trans_pred(P, M1, M2) :- 1104 get_flag_body(P, definition_module, DM, M1), 1105 get_flag_body(P, definition_module, DM, M2). 1106 1107 1108%------------------------------------- 1109% Arithmetic handlers 1110%------------------------------------- 1111 1112integer_overflow_handler(E, Goal) :- 1113 Goal =.. [F,X|T], 1114 ( bignum(X, BigX) -> % convert one arg to bignum if possible 1115 NewGoal =.. [F,BigX|T], 1116 call(NewGoal) % redo the operation with bignums 1117 ; 1118 error_handler(E, Goal) 1119 ). 1120 1121% This one is called when an argument of a comparison 1122% is neither a number nor a free variable. 1123% The arguments are evaluated and the goal is re-called. 1124 1125compare_handler(_, Goal, CM, LM) :- 1126 functor(Goal, F, A), 1127 arg(1, Goal, X), 1128 arg(2, Goal, Y), 1129 ( A > 2 -> 1130 arg(3, Goal, M), % for >= 6.0 culprit is tool body 1131 functor(NewGoal, F, 2), 1132 arg(1, NewGoal, X1), 1133 arg(2, NewGoal, Y1) 1134 ; 1135 functor(NewGoal, F, A), % up to 5.10 culprit is tool 1136 arg(1, NewGoal, X1), 1137 arg(2, NewGoal, Y1), 1138 M = CM 1139 ), 1140 call(X1 is X)@M, % call the visible is/2 (e.g. for iso) 1141 call(Y1 is Y)@M, 1142 ( number(X1), number(Y1) -> 1143 :@(LM,NewGoal,M) 1144 ; var(X1) -> 1145 :@(LM,NewGoal,M) 1146 ; var(Y1) -> 1147 :@(LM,NewGoal,M) 1148 ; 1149 error(24, NewGoal, M) 1150 ). 1151 1152 1153%------------------------------------- 1154% Module related handlers 1155%------------------------------------- 1156 1157% allow certain things even if the module is locked 1158 1159locked_access_handler(_, unskipped PredSpec) :- 1160 unskipping_allowed(PredSpec), 1161 !, 1162 unskipped PredSpec. 1163locked_access_handler(_, export PredSpec) :- 1164 exporting_allowed(PredSpec), 1165 !, 1166 export PredSpec. 1167locked_access_handler(E, Goal) :- 1168 error_handler(E, Goal). 1169 1170% allow certain kernel predicates to be made unskipped 1171 1172unskipping_allowed((is)/2). 1173unskipping_allowed((>)/2). 1174unskipping_allowed((<)/2). 1175unskipping_allowed((>=)/2). 1176unskipping_allowed((=<)/2). 1177unskipping_allowed((=:=)/2). 1178unskipping_allowed((=\=)/2). 1179 1180% and certain not to be global any longer 1181 1182exporting_allowed(wake/0). 1183 1184 1185ambiguous_import_resolve(_, Pred, Module) :- 1186 preferred_predicate(Pred, M), 1187 get_module_info(Module, imports, Imports), 1188 memberchk(M, Imports), 1189 (import Pred from M) @ Module. 1190 1191ambiguous_import_warn(_, Pred, Module) :- 1192 get_module_info(Module, imports, Imports), 1193 findall(M, (member(M,Imports),get_flag(Pred,visibility,E)@M, 1194 (E=exported;E=reexported)), ExportingModules), 1195 printf(warning_output, "Ambiguous import of %w from %w in module %w%n", 1196 [Pred, ExportingModules, Module]). 1197 1198 % These predicates will be preferred over definitions in 1199 % other modules when they are ambiguously imported. 1200 preferred_predicate((>)/2, eclipse_language). 1201 preferred_predicate((<)/2, eclipse_language). 1202 preferred_predicate((>=)/2, eclipse_language). 1203 preferred_predicate((=<)/2, eclipse_language). 1204 preferred_predicate((=:=)/2, eclipse_language). 1205 preferred_predicate((=\=)/2, eclipse_language). 1206 1207 1208%------------------------------------- 1209% Optimization message handler 1210%------------------------------------- 1211 1212cost_handler(_, (Cost, _)) :- 1213 printf("Found a solution with cost %w%n%b", Cost). 1214cost_handler(_, no(Cost, _)) :- 1215 printf("Found no solution with cost %w%n%b", Cost). 1216 1217 1218%------------------------------------- 1219% Symbolic waking triggers 1220%------------------------------------- 1221 1222?- make_array_(trigger_suspensions, global_reference, local, sepia_kernel). 1223 1224% The postponed list is separate because it is also accessed from C 1225% Moreover, the postponed list is emptied on waking. This makes a difference 1226% for demons (which would otherwise stay on the list). This semantics 1227% seems more useful, because demon predicates are often not aware that 1228% they have been transferred to the postponed-list and therefore cause 1229% looping when they stay on the list. Conceptually, every postponed-list 1230% is woken exactly once, and a fresh postponed list is created at that time. 1231 1232:- export 1233 attach_suspensions/2, 1234 attached_suspensions/2, 1235 schedule_suspensions/1, 1236 current_trigger/1, 1237 trigger/1. 1238 1239trigger(postponed) :- !, 1240 trigger_postponed. 1241trigger(N) :- 1242 schedule_suspensions(N), 1243 wake. 1244 1245trigger_postponed :- 1246 get_postponed_nonempty(WL), % and reinitialise 1247 !, 1248 schedule_suspensions(2,WL), 1249 wake, 1250 trigger_postponed. 1251trigger_postponed. 1252 1253 1254attached_suspensions(N, Susps) :- 1255 atom(N), !, 1256 ( find_trigger(N, WL) -> 1257 arg(2, WL, Susps) 1258 ; 1259 Susps = [] 1260 ). 1261attached_suspensions(N, Susps) :- 1262 nonvar(N), !, 1263 error(5, attached_suspensions(N, Susps)). 1264attached_suspensions(N, Susps) :- 1265 error(4, attached_suspensions(N, Susps)). 1266 1267 1268schedule_suspensions(N) :- 1269 ( find_trigger(N, WL) -> 1270 schedule_suspensions(2,WL) 1271 ; 1272 true 1273 ). 1274 1275 1276 find_trigger(postponed, ESusp) :- !, 1277 get_postponed_nonempty(ESusp). % and reinitialise 1278 find_trigger(T, WL) :- 1279 getval(trigger_suspensions, List), 1280 find_trigger(List, T, WL). 1281 1282 :- mode find_trigger(+,+,-). 1283 find_trigger([ESusp|ESusps], T, WL) :- 1284 ( ESusp = es(T,_) -> 1285 WL = ESusp 1286 ; 1287 find_trigger(ESusps, T, WL) 1288 ). 1289 1290 enter_trigger(postponed, ESusp) :- !, 1291 get_postponed(ESusp). 1292 enter_trigger(T, WL) :- 1293 getval(trigger_suspensions, List), 1294 ( find_trigger(List, T, WL) -> % and reinitialise 1295 true 1296 ; 1297 WL = es(T,[]), 1298 setval(trigger_suspensions,[WL|List]) 1299 ). 1300 1301 1302current_trigger(postponed). 1303current_trigger(Trigger) :- 1304 getval(trigger_suspensions, List), 1305 member(es(Trigger, _), List). 1306 1307 1308attach_suspensions(postponed, Susp) ?- !, 1309 postpone_suspensions(Susp). 1310attach_suspensions(Trigger, Susp) :- 1311 atom(Trigger), !, 1312 attach_suspensions1(Trigger, Susp). 1313attach_suspensions(Trigger, Susp) :- 1314 nonvar(Trigger), !, 1315 error(5, attach_suspensions(Trigger, Susp)). 1316attach_suspensions(Trigger, Susp) :- 1317 error(4, attach_suspensions(Trigger, Susp)). 1318 1319attach_suspensions1(Trigger, Susp) :- 1320 var(Susp), !, 1321 error(4, attach_suspensions(Trigger, Susp)). 1322attach_suspensions1(_Trigger, []) :- !. 1323attach_suspensions1(Trigger, Susps) :- 1324 Susps = [_|_], !, 1325 enter_trigger(Trigger, Entry), 1326 enter_suspensions_list(Trigger, Entry, Susps). 1327attach_suspensions1(Trigger, Susp) :- 1328 atomic(Susp), is_suspension(Susp), !, 1329 enter_trigger(Trigger, Entry), 1330 enter_suspension_list(2, Entry, Susp). 1331attach_suspensions1(Trigger, Susp) :- 1332 error(5, attach_suspensions(Trigger, Susp)). 1333 1334 enter_suspensions_list(Trigger, _Entry, Susps) :- 1335 var(Susps), !, 1336 error(4, attach_suspensions(Trigger, Susps)). 1337 enter_suspensions_list(_, _, []) :- !. 1338 enter_suspensions_list(Trigger, Entry, [Susp|Susps]) :- !, 1339 enter_suspension_list(2, Entry, Susp), 1340 enter_suspensions_list(Trigger, Entry, Susps). 1341 enter_suspensions_list(Trigger, _Entry, Susps) :- 1342 error(5, attach_suspensions(Trigger, Susps)). 1343 1344 1345% Specialised code for attach_suspensions(postponed, Susp): 1346% This is not strictly necessary, but we can clean up the postponed 1347% list slightly more eagerly than an arbitrary suspension list. 1348postpone_suspensions(Susp) :- 1349 var(Susp), !, 1350 error(4, attach_suspensions(postponed, Susp)). 1351postpone_suspensions([]) :- !. 1352postpone_suspensions(Susps) :- 1353 Susps = [_|_], !, 1354 postpone_suspensions(1, s(Susps)). 1355postpone_suspensions(Susp) :- 1356 atomic(Susp), is_suspension(Susp), !, 1357 postpone_suspensions(1, s([Susp])). 1358postpone_suspensions(Susp) :- 1359 error(5, attach_suspensions(postponed, Susp)). 1360 1361 1362 1363%------------------------------------- 1364% default error handler definitions 1365%------------------------------------- 1366 1367?- set_default_error_handler_(1, error_handler/2, sepia_kernel), 1368 set_default_error_handler_(2, error_handler/2, sepia_kernel), 1369 set_default_error_handler_(4, error_handler/4, sepia_kernel), 1370 set_default_error_handler_(5, error_handler/4, sepia_kernel), 1371 set_default_error_handler_(6, error_handler/4, sepia_kernel), 1372 set_default_error_handler_(7, error_handler/2, sepia_kernel), 1373 set_default_error_handler_(8, error_handler/2, sepia_kernel), 1374 set_default_error_handler_(11, true/0, sepia_kernel), % set in meta.pl 1375 set_default_error_handler_(15, fail/0, sepia_kernel), 1376 set_default_error_handler_(16, fail/0, sepia_kernel), 1377 set_default_error_handler_(17, error_handler/2, sepia_kernel), 1378 set_default_error_handler_(20, error_handler/2, sepia_kernel), 1379 set_default_error_handler_(21, error_handler/4, sepia_kernel), 1380 set_default_error_handler_(23, compare_handler/4, sepia_kernel), 1381 set_default_error_handler_(24, error_handler/2, sepia_kernel), 1382 set_default_error_handler_(25, integer_overflow_handler/2, sepia_kernel), 1383 set_default_error_handler_(30, error_handler/2, sepia_kernel), 1384 set_default_error_handler_(31, error_handler/2, sepia_kernel), 1385 set_default_error_handler_(32, warning_handler/2, sepia_kernel), 1386 set_default_error_handler_(33, error_handler/2, sepia_kernel), 1387 set_default_error_handler_(40, error_handler/2, sepia_kernel), 1388 set_default_error_handler_(41, undef_array_handler/3, sepia_kernel), 1389 set_default_error_handler_(42, make_array_handler/4, sepia_kernel), 1390 set_default_error_handler_(43, error_handler/2, sepia_kernel), 1391 set_default_error_handler_(44, error_handler/2, sepia_kernel), 1392 set_default_error_handler_(45, undef_record_handler/2, sepia_kernel), 1393 set_default_error_handler_(50, error_handler/2, sepia_kernel), 1394 set_default_error_handler_(60, error_handler/4, sepia_kernel), 1395 set_default_error_handler_(61, error_handler/4, sepia_kernel), 1396 set_default_error_handler_(62, error_handler/4, sepia_kernel), 1397 set_default_error_handler_(63, error_handler/4, sepia_kernel), 1398 set_default_error_handler_(64, dynamic_handler/3, sepia_kernel), 1399 set_default_error_handler_(65, error_handler/4, sepia_kernel), 1400 set_default_error_handler_(66, error_handler/4, sepia_kernel), 1401 set_default_error_handler_(67, error_handler/4, sepia_kernel), 1402 set_default_error_handler_(68, call_handler/4, sepia_kernel), 1403 set_default_error_handler_(69, autoload_handler/4, sepia_kernel), 1404 set_default_error_handler_(70, undef_dynamic_handler/3, sepia_kernel), 1405 set_default_error_handler_(71, error_handler/2, sepia_kernel), 1406 set_default_error_handler_(72, error_handler/2, sepia_kernel), 1407 set_default_error_handler_(73, true/0, sepia_kernel), 1408 set_default_error_handler_(74, true/0, sepia_kernel), 1409 set_default_error_handler_(75, declaration_warning_handler/3, sepia_kernel), 1410 set_default_error_handler_(76, declaration_warning_handler/3, sepia_kernel), 1411 set_default_error_handler_(77, declaration_warning_handler/3, sepia_kernel), 1412 set_default_error_handler_(78, error_handler/2, sepia_kernel), 1413 set_default_error_handler_(79, call_dynamic_/3, sepia_kernel), 1414 set_default_error_handler_(80, error_handler/2, sepia_kernel), 1415 set_default_error_handler_(81, error_handler/2, sepia_kernel), 1416 set_default_error_handler_(82, locked_access_handler/2, sepia_kernel), 1417 set_default_error_handler_(83, warning_handler/2, sepia_kernel), 1418 set_default_error_handler_(84, declaration_warning_handler/3, sepia_kernel), 1419 set_default_error_handler_(85, declaration_warning_handler/3, sepia_kernel), 1420 set_default_error_handler_(86, no_lookup_module_handler/4, sepia_kernel), 1421 set_default_error_handler_(87, warning_handler/3, sepia_kernel), 1422 set_default_error_handler_(88, warning_handler/3, sepia_kernel), 1423 set_default_error_handler_(89, warning_handler/3, sepia_kernel), 1424 set_default_error_handler_(90, error_handler/4, sepia_kernel), 1425 set_default_error_handler_(91, error_handler/2, sepia_kernel), 1426 set_default_error_handler_(92, error_handler/4, sepia_kernel), 1427 set_default_error_handler_(93, error_handler/4, sepia_kernel), 1428 set_default_error_handler_(94, error_handler/4, sepia_kernel), 1429 set_default_error_handler_(96, ambiguous_import_resolve/3, sepia_kernel), 1430 set_default_error_handler_(97, error_handler/2, sepia_kernel), 1431 set_default_error_handler_(98, error_handler/2, sepia_kernel), 1432 set_default_error_handler_(99, ambiguous_import_warn/3, sepia_kernel), 1433 set_default_error_handler_(100, undef_dynamic_handler/3, sepia_kernel), 1434 set_default_error_handler_(101, error_handler/2, sepia_kernel), 1435 set_default_error_handler_(111, parser_error_handler/3, sepia_kernel), 1436 set_default_error_handler_(112, parser_error_handler/3, sepia_kernel), 1437 set_default_error_handler_(113, parser_error_handler/3, sepia_kernel), 1438 set_default_error_handler_(114, parser_error_handler/3, sepia_kernel), 1439 set_default_error_handler_(115, parser_error_handler/3, sepia_kernel), 1440 set_default_error_handler_(116, parser_error_handler/3, sepia_kernel), 1441 set_default_error_handler_(117, parser_error_handler/3, sepia_kernel), 1442 set_default_error_handler_(118, parser_error_handler/3, sepia_kernel), 1443 set_default_error_handler_(119, parser_error_handler/3, sepia_kernel), 1444 set_default_error_handler_(121, parser_error_handler/3, sepia_kernel), 1445 set_default_error_handler_(122, parser_error_handler/3, sepia_kernel), 1446 set_default_error_handler_(123, error_handler/4, sepia_kernel), 1447 set_default_error_handler_(125, parser_error_handler/3, sepia_kernel), 1448 set_default_error_handler_(126, parser_error_handler/3, sepia_kernel), 1449 set_default_error_handler_(127, parser_error_handler/3, sepia_kernel), 1450 set_default_error_handler_(128, parser_error_handler/3, sepia_kernel), 1451 set_default_error_handler_(129, parser_error_handler/3, sepia_kernel), 1452 set_default_error_handler_(130, compiler_error_handler/2, sepia_kernel), 1453 set_default_error_handler_(131, compiler_error_handler/2, sepia_kernel), 1454 set_default_error_handler_(133, true/0, sepia_kernel), 1455 set_default_error_handler_(134, compiler_error_handler/2, sepia_kernel), 1456 set_default_error_handler_(135, compiler_error_handler/2, sepia_kernel), 1457 set_default_error_handler_(136, compiler_error_handler/2, sepia_kernel), 1458 set_default_error_handler_(137, compiler_error_handler/2, sepia_kernel), 1459 set_default_error_handler_(138, singleton_in_loop/2, sepia_kernel), 1460 set_default_error_handler_(139, true/0, sepia_kernel), 1461 set_default_error_handler_(140, error_handler/2, sepia_kernel), 1462 set_default_error_handler_(141, error_handler/2, sepia_kernel), 1463 set_default_error_handler_(142, error_handler/2, sepia_kernel), 1464 set_default_error_handler_(143, compiler_error_handler/2, sepia_kernel), 1465 set_default_error_handler_(145, redef_other_file_handler/2, sepia_kernel), 1466 set_default_error_handler_(146, true/0, sepia_kernel), 1467 set_default_error_handler_(147, compiler_abort_handler/3, sepia_kernel), 1468 set_default_error_handler_(148, pragma_handler/3, sepia_kernel), 1469 set_default_error_handler_(149, unit_loaded_handler/3, sepia_kernel), 1470 set_default_error_handler_(150, true/0, sepia_kernel), 1471 set_default_error_handler_(151, true/0, sepia_kernel), 1472 set_default_error_handler_(152, true/0, sepia_kernel), 1473 set_default_error_handler_(157, error_exit/0, sepia_kernel), 1474 set_default_error_handler_(160, macro_handler/3, sepia_kernel), 1475 set_default_error_handler_(161, macro_handler/3, sepia_kernel), 1476 set_default_error_handler_(162, warning_handler/2, sepia_kernel), 1477 set_default_error_handler_(163, error_handler/2, sepia_kernel), 1478 set_default_error_handler_(165, error_handler/2, sepia_kernel), 1479 set_default_error_handler_(166, record_compiled_file_handler/3, sepia_kernel), 1480 set_default_error_handler_(167, warning_handler/3, sepia_kernel), 1481 set_default_error_handler_(170, system_error_handler/4, sepia_kernel), 1482 set_default_error_handler_(171, error_handler/2, sepia_kernel), 1483 set_default_error_handler_(172, error_handler/2, sepia_kernel), 1484 set_default_error_handler_(173, error_handler/2, sepia_kernel), 1485 set_default_error_handler_(174, error_handler/2, sepia_kernel), 1486 set_default_error_handler_(175, error_handler/2, sepia_kernel), 1487 set_default_error_handler_(176, error_handler/2, sepia_kernel), 1488 set_default_error_handler_(177, error_handler/2, sepia_kernel), 1489 set_default_error_handler_(190, eof_handler/4, sepia_kernel), 1490 set_default_error_handler_(191, output_error_handler/4, sepia_kernel), 1491 set_default_error_handler_(192, error_handler/2, sepia_kernel), 1492 set_default_error_handler_(193, error_handler/2, sepia_kernel), 1493 set_default_error_handler_(194, error_handler/2, sepia_kernel), 1494 set_default_error_handler_(195, io_yield_handler/2, sepia_kernel), 1495 set_default_error_handler_(196, close_handler/2, sepia_kernel), 1496 set_default_error_handler_(197, error_handler/2, sepia_kernel), 1497 set_default_error_handler_(198, past_eof_handler/2, sepia_kernel), 1498 set_default_error_handler_(210, error_handler/2, sepia_kernel), 1499 set_default_error_handler_(211, error_handler/2, sepia_kernel), 1500 set_default_error_handler_(212, error_handler/2, sepia_kernel), 1501 set_default_error_handler_(213, error_handler/2, sepia_kernel), 1502 set_default_error_handler_(214, error_handler/2, sepia_kernel), 1503 set_default_error_handler_(230, error_handler/2, sepia_kernel), 1504 set_default_error_handler_(231, fail/0, sepia_kernel), 1505 set_default_error_handler_(250, true/0, sepia_kernel), 1506 set_default_error_handler_(251, true/0, sepia_kernel), 1507 set_default_error_handler_(252, true/0, sepia_kernel), 1508 set_default_error_handler_(253, true/0, sepia_kernel), 1509 set_default_error_handler_(254, true/0, sepia_kernel), 1510 set_default_error_handler_(255, true/0, sepia_kernel), 1511 set_default_error_handler_(256, true/0, sepia_kernel), 1512 set_default_error_handler_(257, true/0, sepia_kernel), 1513 set_default_error_handler_(258, true/0, sepia_kernel), 1514 set_default_error_handler_(259, true/0, sepia_kernel), 1515 set_default_error_handler_(260, error_handler/2, sepia_kernel), 1516 set_default_error_handler_(261, error_handler/2, sepia_kernel), 1517 set_default_error_handler_(262, error_handler/2, sepia_kernel), 1518 set_default_error_handler_(263, error_handler/2, sepia_kernel), 1519 set_default_error_handler_(264, compiled_file_handler/3, sepia_kernel), 1520 set_default_error_handler_(265, compiled_file_handler/3, sepia_kernel), 1521 set_default_error_handler_(267, error_handler/2, sepia_kernel), 1522 set_default_error_handler_(268, error_handler/2, sepia_kernel), 1523 set_default_error_handler_(270, error_handler/2, sepia_kernel), 1524 set_default_error_handler_(271, error_handler/2, sepia_kernel), 1525 set_default_error_handler_(272, warning_handler/2, sepia_kernel), 1526 set_default_error_handler_(274, error_handler/2, sepia_kernel), 1527 set_default_error_handler_(280, cost_handler/2, sepia_kernel). 1528 1529/* default error handler for MegaLog errors */ 1530 1531'$transaction_deadlock'(317,_) :- throw(abort_transaction). 1532 1533?- set_default_error_handler_(300, error_handler/2, sepia_kernel), 1534 set_default_error_handler_(301, error_handler/2, sepia_kernel), 1535 set_default_error_handler_(302, error_handler/2, sepia_kernel), 1536 set_default_error_handler_(303, error_handler/2, sepia_kernel), 1537 set_default_error_handler_(304, error_handler/2, sepia_kernel), 1538 set_default_error_handler_(305, error_handler/2, sepia_kernel), 1539 set_default_error_handler_(306, error_handler/2, sepia_kernel), 1540 set_default_error_handler_(307, error_handler/2, sepia_kernel), 1541 set_default_error_handler_(308, error_handler/2, sepia_kernel), 1542 set_default_error_handler_(309, error_handler/2, sepia_kernel), 1543 set_default_error_handler_(310, error_handler/2, sepia_kernel), 1544 set_default_error_handler_(311, error_handler/2, sepia_kernel), 1545 set_default_error_handler_(312, error_handler/2, sepia_kernel), 1546 set_default_error_handler_(313, error_handler/2, sepia_kernel), 1547 set_default_error_handler_(314, error_handler/2, sepia_kernel), 1548 set_default_error_handler_(315, error_handler/2, sepia_kernel), 1549 set_default_error_handler_(316, error_handler/2, sepia_kernel), 1550 set_default_error_handler_(317, '$transaction_deadlock'/2, sepia_kernel), 1551 set_default_error_handler_(318, error_handler/2, sepia_kernel), 1552 set_default_error_handler_(319, error_handler/2, sepia_kernel), 1553 set_default_error_handler_(320, error_handler/2, sepia_kernel), 1554 set_default_error_handler_(321, error_handler/2, sepia_kernel), 1555 set_default_error_handler_(322, error_handler/2, sepia_kernel), 1556 set_default_error_handler_(329, warning_handler/2, sepia_kernel), 1557 set_default_error_handler_(333, warning_handler/2, sepia_kernel). 1558 1559?- set_event_handler(postponed, trigger/1), 1560 set_event_handler(requested_fail_event, trigger/1), 1561 set_event_handler(garbage_collect_dictionary, garbage_collect_dictionary/0), 1562 set_event_handler(abort, throw/1). 1563 1564reset_error_handlers :- 1565 current_error(N), 1566 reset_error_handler(N), 1567 fail. 1568reset_error_handlers. 1569 1570?- reset_error_handlers. % set up the handlers 1571 1572%------------------------------------- 1573% interrupt handling builtins 1574%------------------------------------- 1575 1576current_interrupt(N, Name) :- 1577 var(N), var(Name), !, 1578 gen_interrupt_id(N, Name, 1). 1579current_interrupt(N, Name) :- 1580 (integer(N);var(N)), 1581 (atom(Name);var(Name)), 1582 !, 1583 interrupt_id_det(N, Name), 1584 Name \== '.'. 1585current_interrupt(N, Name) :- 1586 error(5, current_interrupt(N, Name)). 1587 1588 gen_interrupt_id(Number, Name, N) :- 1589 ( interrupt_id_det(N, Name) -> 1590 Name \== '.', 1591 Number = N 1592 ; 1593 !, 1594 fail 1595 ). 1596 gen_interrupt_id(Number, Name, N) :- 1597 N1 is N + 1, 1598 gen_interrupt_id(Number, Name, N1). 1599 1600 1601%---------------------------------------------------------------------- 1602% Raising events from socket streams 1603%---------------------------------------------------------------------- 1604 1605io_event_handler :- 1606 findall(Event, ready_sigio_stream_event(Event), Events), 1607 event(Events), 1608 events_nodefer. 1609 1610 ready_sigio_stream_event(Event) :- 1611 current_stream(S), 1612 get_stream_info(S, sigio, on), % it is a sigio stream 1613 get_stream_info(S, event, Event), % it wants an event 1614 stream_select([S], 0, [_]). % it has data 1615 1616 1617?- ( current_interrupt(_, io) -> 1618 set_interrupt_handler(io, event/1), 1619 set_event_handler(io, defers(io_event_handler/0)) 1620% set_interrupt_handler(io, internal/0) % if socket events not needed 1621 ; 1622 true 1623 ). 1624 1625?- ( current_interrupt(_, poll) -> 1626 set_interrupt_handler(poll, event/1), 1627 set_event_handler(poll, defers(io_event_handler/0)) 1628% set_interrupt_handler(poll, internal/0) % if socket events not needed 1629 ; 1630 true 1631 ). 1632 1633 1634%---------------------------------------------------------------------- 1635% An event handler that reads exdr terms (atoms or strings) 1636% from a stream (typically socket) and posts them as events. 1637% We expect this handler to be set up with the defers-option. 1638%---------------------------------------------------------------------- 1639 1640:- export post_events_from_stream/1. 1641 1642post_events_from_stream(Stream) :- 1643 ( stream_select([Stream], 0, [_]), read_exdr(Stream, EventName) -> 1644 ( atom(EventName) -> 1645 event(EventName) 1646 ; string(EventName) -> 1647 atom_string(EventNameAtom, EventName), 1648 event(EventNameAtom) 1649 ; 1650 type_of(EventName, BadType), 1651 printf(warning_output, 1652 "WARNING: ignoring %w on event posting stream %w%n%b", 1653 [BadType,Stream]) 1654 ), 1655 post_events_from_stream(Stream) 1656 ; 1657 events_nodefer 1658 ). 1659 1660 1661%---------------------------------------------------------------------- 1662% postpone_exit(+Tag) is called when a throw was requested inside 1663% an interrupt, but the throw protection is active (e.g. we were 1664% interrupting a garbage collection). The throw is postponed by 1665% saving the Tag and setting the WAS_EXIT flag. 1666%---------------------------------------------------------------------- 1667 1668?- make_array_(postpone_exit, prolog, local, sepia_kernel). 1669 1670postpone_exit(Tag) :- 1671 setval(postpone_exit, Tag), 1672 vm_flags(0, 16'08000000, _), % set the WAS_EXIT flag 1673 sys_return(0). 1674 1675% exit_postponed/0 is called when the throw protection 1676% is dropped and the WAS_EXIT flag is set. 1677 1678exit_postponed :- 1679 getval(postpone_exit, Tag), 1680 vm_flags(16'0c000000, 0, _), % clear NO_EXIT and WAS_EXIT 1681 throw(Tag). 1682 1683%---------------------------------------------------------------------- 1684% after 1685%---------------------------------------------------------------------- 1686 1687% Ordered list of pending events, containing structures of the form: 1688% 1689% ev(PostTime, EventName) 1690% ev(every(Interval), EventName) 1691% 1692% Only modify this variable while event handling is deferred! 1693% After modifying the variable, call adjust_after_timer/1 1694% to make sure the next alarm occurs in time for the next event. 1695:- local variable(after_events). 1696?- setval(after_events, []). 1697 1698% The physical timer used for after events: 'real' or 'virtual' 1699:- local variable(after_event_timer). 1700 1701 1702current_after_event(E) :- 1703 (is_event(E) -> 1704 !, 1705 getval(after_events, EQ), % atomic read, no need to defer events 1706 memberchk(ev(_,E)-_, EQ) 1707 1708 ; var(E) -> 1709 !, 1710 getval(after_events, EQ), % atomic read, no need to defer events 1711 findall(X, member(ev(_,X)-_, EQ), E) 1712 1713 ; set_bip_error(5) 1714 ). 1715current_after_event(E) :- 1716 get_bip_error(Err), 1717 error(Err, current_after_event(E)). 1718 1719current_after_events(DueEvents) :- 1720 getval(after_events, Events), % atomic read, no need to defer events 1721 get_due_event_list(Events, DueEvents). 1722 1723get_due_event_list([], []). 1724get_due_event_list([Event | Events], [DueEvent | DueEvents]) :- 1725 Event = ev(Type, Name)-DueTime, 1726 DueEvent = due(Name-Type, DueTime), 1727 get_due_event_list(Events, DueEvents). 1728 1729 1730% (Synchronous) handler when after-timer expires 1731% This handler is called with events deferred, and must invoke events_nodefer 1732% at the end! It must therefore not fail or throw. 1733% The handler must not contain any calls to wake/0 (however embedded, 1734% e.g. inside call_priority/2) because that would interfere with 1735% the environment's waking state. 1736 1737after_handler :- 1738 current_after_time(CurrentTime), 1739 1740 getval(after_events, EQ0), 1741 ready_events(EQ0, CurrentTime, RepeatEvents, DuedEvents, EQ1), 1742 sort(2, =<, RepeatEvents, SortedRepeatEvents), 1743 merge(2, =<, SortedRepeatEvents, EQ1, EQ2), 1744 setval(after_events, EQ2), 1745 1746 event(DuedEvents), % events are deferred at this point! 1747 1748 adjust_after_timer(EQ2), 1749 1750 events_nodefer. 1751 1752 1753% Default timer is real. 1754 1755?- 1756 set_interrupt_handler(alrm, event/1), 1757 setval(after_event_timer, real), 1758 set_event_handler(alrm, defers(after_handler/0)). 1759 1760% Stop timer events before exiting eclipse 1761?- local finalization(( 1762 get_flag(after_event_timer, Timer), 1763 stop_timer(Timer, _, _) 1764 )). 1765 1766signal_timer(vtalrm, virtual). 1767signal_timer(alrm, real). 1768 1769try_set_after_timer(Timer) :- 1770 % assume here that we can always set timer to 'real' 1771 % alrm/vtalrm signals both do not exist on Windows! 1772 signal_timer(Signal, Timer), 1773 ((Signal == alrm ; current_interrupt(_, Signal)) -> 1774 get_flag(after_event_timer, Timer0), 1775 % reinitialise after_events 1776 stop_timer(Timer0, Remain, Interv), % stop old timer 1777 (catch(stop_timer(Timer, _, _), _, fail) -> 1778 true 1779 ; 1780 printf(error, "%w not available on this configuration.%n", [Timer]), 1781 start_timer(Timer0, Remain, Interv), % restart old timer 1782 fail 1783 ), 1784 signal_timer(Signal0, Timer0), 1785 setval(after_events, []), 1786 (Signal0 == Signal -> 1787 true 1788 ; 1789 set_interrupt_handler(Signal, event/1), 1790 set_event_handler(Signal, defers(after_handler/0)), 1791 setval(after_event_timer, Timer) 1792 ) 1793 ; 1794 1795 printf(error, "%w not available on this platform%n", [Timer]), 1796 fail 1797 ). 1798 1799 1800% To be called whenever after_events has changed, in order to ajust 1801% the timer. The argument is the current value of variable(after_events) 1802% This must be called with events being deferred! 1803 1804adjust_after_timer(CurrentAfterEventQueue) :- 1805 get_flag(after_event_timer, Timer), 1806 stop_timer(Timer, _Remain, _), 1807 current_after_time(CurrentTime), 1808 ( CurrentAfterEventQueue = [_-NextTime|_] -> 1809 Interval is NextTime - CurrentTime, 1810 (Interval > 0 -> 1811 start_timer(Timer, Interval, 0) 1812 ; 1813 signal_timer(Signal, Timer), 1814 event([Signal]) % events are due, handle them immediately 1815 ) 1816 ; 1817 true 1818 ). 1819 1820 1821% 1822% event_after(+Event, Interval) 1823% event_after(+Event, Interval, DueTime) 1824% event_after_every(+Event, Interval) 1825% events_after(+List) 1826 1827event_after(E, Int) :- 1828 event_after(E, Int, _). 1829 1830 1831event_after(E, Int, DueTime) :- 1832 ( 1833 check_event(E), 1834 check_interval(single, Int) 1835 -> 1836 current_after_time(CurrentTime), 1837 ( events_defer -> 1838 unchecked_add_after_event(CurrentTime, CurrentTime, E, Int, DueTime), 1839 events_nodefer 1840 ; 1841 unchecked_add_after_event(CurrentTime, CurrentTime, E, Int, DueTime) 1842 ) 1843 ; 1844 get_bip_error(Id), 1845 error(Id, event_after(E, Int)) 1846 ). 1847 1848event_after_every(E, Int) :- 1849 ( 1850 check_event(E), 1851 check_interval(every, Int) 1852 -> 1853 current_after_time(CurrentTime), 1854 ( events_defer -> 1855 unchecked_add_after_event(every(Int), CurrentTime, E, Int, _DueTime), 1856 events_nodefer 1857 ; 1858 unchecked_add_after_event(every(Int), CurrentTime, E, Int, _DueTime) 1859 ) 1860 ; 1861 get_bip_error(Id), 1862 error(Id, event_after_every(E, Int)) 1863 ). 1864 1865events_after(Es) :- 1866 ( 1867 check_after_events(Es, Names, Ints, Types) 1868 -> 1869 current_after_time(CurrentTime), 1870 ( events_defer -> 1871 unchecked_add_after_events(Names, Ints, Types, CurrentTime), 1872 events_nodefer 1873 ; 1874 unchecked_add_after_events(Names, Ints, Types, CurrentTime) 1875 ) 1876 ; 1877 get_bip_error(Id), 1878 error(Id, events_after(Es)) 1879 ). 1880 1881 1882% may fail with set_bip_error 1883:- mode check_after_events(?,-,-,-). 1884check_after_events(X, _, _, _) :- var(X), !, 1885 set_bip_error(4). 1886check_after_events([], [], [], []) :- !. 1887check_after_events([E|Es], [Name|Names], [Int|Ints], [Type|Types]) :- !, 1888 check_event_spec(E, Name, Type, Int), 1889 check_after_events(Es, Names, Ints, Types). 1890check_after_events(_, _, _, _) :- 1891 set_bip_error(5). 1892 1893 check_event_spec(Spec, _Name, _Type, _Interval) :- var(Spec), !, 1894 set_bip_error(4). 1895 check_event_spec(Name-Type, Name, Type, Interval) :- !, 1896 check_event(Name), 1897 check_event_type(Type, Interval). 1898 check_event_spec(_Spec, _Name, _Type, _Interval) :- 1899 set_bip_error(5). 1900 1901 :- mode check_event_type(?,-). 1902 check_event_type(Spec, _Interval) :- var(Spec), !, 1903 set_bip_error(4). 1904 check_event_type(every(Interval), Interval) :- !, 1905 check_interval(every, Interval). 1906 check_event_type(Interval, Interval) :- 1907 check_interval(single, Interval). 1908 1909 % check_interval(+Type, ?Interval) 1910 :- mode check_interval(+,?). 1911 check_interval(every, Interval) :- % after-every: > 0 1912 check_time_type(Interval), 1913 ( Interval > 0 -> true ; set_bip_error(6) ). 1914 check_interval(single, Interval) :- % simple after: >= 0 1915 check_time_type(Interval), 1916 ( Interval >= 0 -> true ; set_bip_error(6) ). 1917 1918 check_time_type(X) :- var(X), !, set_bip_error(4). 1919 check_time_type(X) :- number(X), \+ breal(X), !. 1920 check_time_type(_) :- set_bip_error(5). 1921 1922 1923% Called with events deferred. Must not fail/throw! 1924unchecked_add_after_events([], [], [], _) :- 1925 getval(after_events, List), 1926 adjust_after_timer(List). 1927unchecked_add_after_events([Name|Names], [Int|Ints], [Type|Types], CurrentTime) :- 1928 unchecked_add_after_event(Type, CurrentTime, Name, Int, _), 1929 unchecked_add_after_events(Names, Ints, Types, CurrentTime). 1930 1931 1932unchecked_add_after_event(Type, CurrentTime, E, Int, NewEventTime) :- 1933 NewEventTime is CurrentTime + Int, 1934 getval(after_events, EQ0), 1935 %sort(2, =<, [ev(Type,E)-NewEventTime|EQ0], EQ1), 1936 insert_into_after_event_queue(EQ0, NewEventTime, ev(Type,E), EQ1), 1937 setval(after_events, EQ1), 1938 adjust_after_timer(EQ1). 1939 1940 1941insert_into_after_event_queue([], NTime, NEvent, EQ) :- EQ = [NEvent-NTime]. 1942insert_into_after_event_queue([Event-Time|EQ0], NewTime, NewEvent, EQ) :- 1943 (NewTime < Time -> 1944 EQ = [NewEvent-NewTime,Event-Time|EQ0] 1945 ; EQ = [Event-Time|EQ1], 1946 insert_into_after_event_queue(EQ0, NewTime, NewEvent, EQ1) 1947 ). 1948 1949 1950ready_events([], _CurrentTime, [], [], []). 1951ready_events(EQ0, CurrentTime, Repeats0, Dued0, EQ) :- 1952 EQ0 = [EventInfo-EventTime|EQ1], 1953 ( CurrentTime >= EventTime -> 1954 EventInfo = ev(Type,Event), 1955 Dued0 = [Event|Dued1], 1956 ( Type = every(Interval) -> 1957 RepeatTime is CurrentTime + Interval, 1958 Repeats0 = [EventInfo-RepeatTime|Repeats1] 1959 ; 1960 Repeats0 = Repeats1 1961 ), 1962 ready_events(EQ1, CurrentTime, Repeats1, Dued1, EQ) 1963 ; 1964 EQ = EQ0, Dued0 = [], Repeats0 = [] 1965 ). 1966 1967 1968cancel_after_event(Event) :- 1969 is_event(Event), 1970 !, 1971 ( events_defer -> 1972 cancel_after_event1(Event, Found), 1973 events_nodefer 1974 ; 1975 cancel_after_event1(Event, Found) 1976 ), 1977 Found = true. 1978cancel_after_event(Event) :- 1979 error(5, cancel_after_event(Event)). 1980 1981 :-mode cancel_after_event1(+,-). 1982 cancel_after_event1(Event, Found) :- 1983 getval(after_events, EQ0), 1984 subtract_template(EQ0, ev(_,Event)-_, EQ1), 1985 ( EQ1 == EQ0 -> 1986 Found = false 1987 ; 1988 Found = true, 1989 setval(after_events, EQ1) 1990 ), 1991 adjust_after_timer(EQ1). 1992 1993cancel_after_event(Event, CancelledEvents) :- 1994 is_event(Event), 1995 !, 1996 ( events_defer -> 1997 cancel_after_event2(Event, CancelledEvents0), 1998 events_nodefer 1999 ; 2000 cancel_after_event2(Event, CancelledEvents0) 2001 ), 2002 CancelledEvents = CancelledEvents0. 2003cancel_after_event(Event, CancelledEvents) :- 2004 error(5, cancel_after_event(Event, CancelledEvents)). 2005 2006 :-mode cancel_after_event2(+,-). 2007 cancel_after_event2(Event, CancelledEvents) :- 2008 current_after_time(CurrentTime), 2009 getval(after_events, EQ0), 2010 extract_and_subtract_cancelled_events(EQ0, Event, CurrentTime, 2011 EQ1, CancelledEvents), 2012 (EQ1 == EQ0 -> 2013 true 2014 ; 2015 setval(after_events, EQ1) 2016 ), 2017 adjust_after_timer(EQ1). 2018 2019 2020% subtract all occurrences of elements matching the template from list 2021subtract_template([], _, []). 2022subtract_template([H|T], Template, Subtracted) :- 2023 (\+(\+(Template = H)) -> 2024 Subtracted = Subtracted0 ; Subtracted = [H|Subtracted0] 2025 ), 2026 subtract_template(T, Template, Subtracted0). 2027 2028% subtract all occurrences of elements matching the template from list 2029% and extract the specified data from the first match 2030extract_and_subtract_cancelled_events([], _, _, [], []). 2031extract_and_subtract_cancelled_events([H|T], Event, CurrentTime, 2032 Subtracted, Extracted) :- 2033 ( H = ev(Type, Event)-DueTime -> 2034 Subtracted = Subtracted0, 2035 ( number(Type) -> 2036 RemainingTime is max(0.0, DueTime - CurrentTime), 2037 CancelledEvent = Event-RemainingTime 2038 ; 2039 CancelledEvent = Event-Type 2040 ), 2041 Extracted = [CancelledEvent|Extracted0] 2042 ; 2043 Subtracted = [H|Subtracted0], 2044 Extracted = Extracted0 2045 ), 2046 extract_and_subtract_cancelled_events(T, Event, CurrentTime, 2047 Subtracted0, Extracted0). 2048 2049 2050 2051% Get the current time from the clock corresponding to the after-timer in use 2052current_after_time(T) :- 2053 get_flag(after_event_timer, Timer), 2054 (Timer == virtual -> T is cputime ; T is statistics(session_time)). 2055 2056 2057 2058%------------------------------------- 2059 2060check_event(E) :- var(E), !, set_bip_error(4). 2061check_event(E) :- is_event(E), !. 2062check_event(_) :- set_bip_error(5). 2063 2064error_(N, G, LM) :- 2065 error_(N, G, LM, LM). % the context module for normal errors is not significant 2066 2067 2068error_(default(N), G, CM, LM) :- 2069 integer(N), 2070 !, 2071 Nneg is -N, 2072 syserror(Nneg, G, CM, LM). 2073error_(N, G, CM, LM) :- 2074 syserror(N, G, CM, LM). 2075 2076 2077event(Var) :- var(Var), !, 2078 error(4, event(Var)). 2079event([]) :- !. 2080event(Events) :- Events = [_|_], !, 2081 post_events(Events). 2082event(N) :- atom(N), !, 2083 post_events([N]). 2084event(N) :- is_handle(N), is_event(N), !, 2085 post_events([N]). 2086event(Junk) :- 2087 error(5, event(Junk)). 2088 2089 2090bip_error_(Goal, LM) :- % for internal use 2091 get_bip_error(E), 2092 syserror(E, Goal, LM, LM). 2093 2094bip_error_(Goal, CM, LM) :- % for internal use 2095 get_bip_error(E), 2096 syserror(E, Goal, CM, LM). 2097 2098 2099:- unskipped % handlers that re-call the culprit 2100 event/1, 2101 compare_handler/4. 2102 2103:- untraceable 2104 error_exit/0, 2105 compare_handler/4, 2106 call_handler/4. 2107 2108:- skipped 2109 call_handler/4, 2110 eof_handler/4, 2111 error_exit/0, 2112 error_handler/2, 2113 error_handler/3, 2114 error_handler/4, 2115 output_error_handler/4, 2116 parser_error_handler/3, 2117 system_error_handler/4. 2118