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: kernel.pl,v 1.56 2015/05/01 00:11:40 jschimpf Exp $ 27% ---------------------------------------------------------------------- 28 29% 30% IDENTIFICATION: kernel.pl 31% 32% DESCRIPTION: Bootstrapping file for SEPIA/ECLiPSe. 33% It is the first Prolog file that an ECLiPSe ever sees. 34% 35% CONTENTS: This file and the files it includes contain all the 36% Prolog definitions that go into sepia_kernel. 37% Note that the sepia_kernel module already exists: it 38% is created in C and already contains external predicates. 39% 40% In this file, the difference between :- (directive) and 41% ?- (query) matters: if something only makes sense at load-time, 42% use a query. 43 44:-(begin_module(sepia_kernel)). 45 46% 47% global operator declarations 48% 49 50:-(op_(global, 1000, xfy, (',') , sepia_kernel)). 51:-(op_(global, 1200, fx, :- , sepia_kernel)). 52:- op_(global, 1200, xfx, ?- , sepia_kernel), 53 op_(global, 1200, fx, ?- , sepia_kernel), 54 op_(global, 1200, xfx, :- , sepia_kernel), 55 op_(global, 1200, xfx, --> , sepia_kernel), 56 op_(global, 1200, xfx, if , sepia_kernel), 57 op_(global, 1190, fy, help , sepia_kernel), 58% op_(global, 1180, xfx, -?-> , sepia_kernel), 59 op_(global, 1180, fx, -?-> , sepia_kernel), 60 op_(global, 1190, fx, delay , sepia_kernel), 61 op_(global, 1170, xfy, else , sepia_kernel), 62 op_(global, 1160, fx, if , sepia_kernel), 63 op_(global, 1150, xfx, then , sepia_kernel), 64 op_(global, 1100, xfy, do , sepia_kernel), 65 op_(global, 1100, xfy, ; , sepia_kernel), 66 op_(global, 1100, xfy, '|' , sepia_kernel), 67 op_(global, 1050, xfy, -> , sepia_kernel), 68 op_(global, 1050, xfx, *-> , sepia_kernel), 69 op_(global, 1050, fy, import, sepia_kernel), 70 op_(global, 1050, fy, reexport, sepia_kernel), 71 op_(global, 1050, xfx, from , sepia_kernel), 72 op_(global, 1050, xfx, except, sepia_kernel), 73 op_(global, 1000, fy, dynamic, sepia_kernel), 74 op_(global, 1000, fy, abolish, sepia_kernel), 75 op_(global, 1000, fy, mode , sepia_kernel), 76 op_(global, 1000, fy, local , sepia_kernel), 77 op_(global, 1000, fy, global, sepia_kernel), 78 op_(global, 1000, fy, export, sepia_kernel), 79 op_(global, 1000, fy, parallel, sepia_kernel), 80 op_(global, 1000, fy, demon , sepia_kernel), 81 op_(global, 900, fy, ~ , sepia_kernel), 82 op_(global, 1000, fy, listing, sepia_kernel), 83 op_(global, 900, fy, once , sepia_kernel), 84 op_(global, 900, fy, not , sepia_kernel), 85 op_(global, 900, fy, \+ , sepia_kernel), 86 op_(global, 1000, fy, spy , sepia_kernel), 87 op_(global, 1000, fy, nospy , sepia_kernel), 88 op_(global, 1000, fy, traceable, sepia_kernel), 89 op_(global, 1000, fy, untraceable, sepia_kernel), 90 op_(global, 1000, fy, skipped, sepia_kernel), 91 op_(global, 1000, fy, unskipped, sepia_kernel), 92 op_(global, 700, xfx, :: , sepia_kernel), 93 op_(global, 700, xfx, #= , sepia_kernel), 94 op_(global, 700, xfx, #\= , sepia_kernel), 95 op_(global, 700, xfx, #> , sepia_kernel), 96 op_(global, 700, xfx, #< , sepia_kernel), 97 op_(global, 700, xfx, #>= , sepia_kernel), 98 op_(global, 700, xfx, #=< , sepia_kernel), 99 op_(global, 700, xfx, #<= , sepia_kernel), 100 op_(global, 700, xfx, =.. , sepia_kernel), 101 op_(global, 700, xfx, = , sepia_kernel), 102 op_(global, 700, xfx, ~= , sepia_kernel), 103 op_(global, 700, xfx, \= , sepia_kernel), 104 op_(global, 700, xfx, == , sepia_kernel), 105 op_(global, 700, xfx, \== , sepia_kernel), 106 op_(global, 700, xfx, @< , sepia_kernel), 107 op_(global, 700, xfx, @=< , sepia_kernel), 108 op_(global, 700, xfx, @> , sepia_kernel), 109 op_(global, 700, xfx, @>= , sepia_kernel), 110 op_(global, 700, xfx, is , sepia_kernel), 111 op_(global, 700, xfx, =:= , sepia_kernel), 112 op_(global, 700, xfx, =\= , sepia_kernel), 113 op_(global, 700, xfx, < , sepia_kernel), 114 op_(global, 700, xfx, =< , sepia_kernel), 115 op_(global, 700, xfx, > , sepia_kernel), 116 op_(global, 700, xfx, >= , sepia_kernel), 117 op_(global, 650, xfx, with , sepia_kernel), 118 op_(global, 650, xfx, of , sepia_kernel), 119 op_(global, 650, xfx, @ , sepia_kernel), 120 op_(global, 600, xfy, : , sepia_kernel), 121 op_(global, 600, xfx, .. , sepia_kernel), 122 op_(global, 500, yfx, + , sepia_kernel), 123 op_(global, 500, yfx, - , sepia_kernel), 124 op_(global, 500, yfx, /\ , sepia_kernel), 125 op_(global, 500, yfx, \/ , sepia_kernel), 126 op_(global, 400, yfx, / , sepia_kernel), 127 op_(global, 400, yfx, * , sepia_kernel), 128 op_(global, 400, yfx, // , sepia_kernel), 129 op_(global, 400, yfx, >> , sepia_kernel), 130 op_(global, 400, yfx, << , sepia_kernel), 131 op_(global, 400, yfx, rem , sepia_kernel), 132 op_(global, 400, yfx, div , sepia_kernel), 133 op_(global, 400, yfx, mod , sepia_kernel), 134% op_(global, 300, fx, * , sepia_kernel), 135 op_(global, 200, xfy, ^ , sepia_kernel), 136 op_(global, 200, fy, + , sepia_kernel), 137 op_(global, 200, fy, - , sepia_kernel), 138 op_(global, 200, fy, \ , sepia_kernel). 139 140 141% Everything is this module is marked as 'built_in' 142:- pragma(system). 143:- pragma(nodebug). 144:- pragma(noexpand). 145 146% Set debug mode for the following tool declarations: 147:- global_flags(16'00000080,0,_). % debug_compile (DBGCOMP) off 148 149:- tool_(tool/2, tool_/3, sepia_kernel). % tool declarations 150:- tool(store_pred/8, store_pred/9). % needed when loading kernel.eco 151:- tool((not)/1, fail_if_body/2), 152 tool(setval/2, setval_body/3), 153 tool(getval/2, getval_body/3), 154 tool(use_module/1, use_module_body/2), 155 tool((<)/2, (<)/3), 156 tool((>)/2, (>)/3), 157 tool((=<)/2, (=<)/3), 158 tool((>=)/2, (>=)/3), 159 tool((=:=)/2, (=:=)/3), 160 tool((=\=)/2, (=\=)/3), 161 tool(is/2, is_body/3), 162 tool((^)/2, exquant_body/3), 163 tool(bagof/3, bagof_body/4), 164 tool(block/3, block/4), 165 tool(block_atomic/3, block_atomic/4), 166 tool(catch/3, catch_/4), 167 tool(coverof/3, coverof_body/4), 168 tool(untraced_block/3, block/4), 169 tool(printf_with_current_modes/2, printf_with_current_modes_body/3), 170 tool(printf_goal/2, printf_goal_body/3), 171 tool(readvar/3, readvar/4), 172 tool(get_chtab/2, get_chtab_/3), 173 tool(set_chtab/2, set_chtab_/3), 174 tool(set_error_handler/2, set_error_handler_/3), 175 tool(set_event_handler/2, set_error_handler_/3), 176 tool(event_create/2, event_create_/3), 177 tool(event_create/3, event_create_/4), 178 tool(set_interrupt_handler/2, set_interrupt_handler_body/3), 179 tool(get_flag/3, get_flag_body/4), 180 tool(get_syntax/2, get_syntax_/3), 181 tool((@)/2, (@)/3), 182 tool((\+)/1, fail_if_body/2), 183 tool(call/1, call_/2), 184 tool(call/2, call2_/3), 185 tool(call_local/1, call_local/2), 186 tool(current_record/1, current_record_body/2), 187 tool(set_syntax/2, set_syntax_/3), 188 tool(ensure_loaded/1, ensure_loaded/2), 189 tool(erase/2, erase_body/3), 190 tool(erase_all/1, erase_all_body/2), 191 tool(erase_all/2, erase_all_body/3), 192 tool(erase_module/1, erase_module/2), 193 tool(error/2, error_/3), 194 tool(error/3, error_/4), 195 tool(bip_error/1, bip_error_/2), 196 tool(bip_error/2, bip_error_/3), 197 tool(findall/3, findall_body/4), 198 tool(get_flag/2, get_flag_body/3), 199 tool(recorded_list/2, recorded_list_body/3), 200 tool(lock/0, lock/1), 201 tool(lock_pass/1, lock_pass_/2), 202 tool(local_record/1, local_record_body/2), 203 tool(mutex_init/1, mutex_init_body/2), 204 tool(mutex/2, mutex_body/3), 205 tool(mutex_one/2, mutex_one_body/3), 206 tool(nested_compile_term/1, nested_compile_term_/2), 207 tool(nested_compile_term_annotated/2, nested_compile_term_annotated_/3), 208 tool(number_string/2, number_string_/3), 209 tool(par_all/2, par_all_body/3), 210 tool(par_findall/4, par_findall_body/5), 211 tool(par_once/2, par_once_body/3), 212 tool(printf/2, printf_body/3), 213 tool(printf/3, printf_body/4), 214 tool(sprintf/3, sprintf_/4), 215 tool(is_predicate/1, is_predicate_/2), 216 tool(is_record/1, is_record_body/2), 217 tool(incval/1, incval_body/2), 218 tool(decval/1, decval_body/2), 219 tool((tool)/1, tool_/2), 220 tool(read/1, read_/2), 221 tool(read/2, read_/3), 222 tool(read_token/2, read_token_/3), 223 tool(record/2, recordz_body/3), 224 tool(recorda/2, recorda_body/3), 225 tool(recorda/3, recorda_body/4), 226 tool(recorded/2, recorded_body/3), 227 tool(recorded/3, recorded_body/4), 228 tool(recordedchk/2, recordedchk_body/3), 229 tool(recordedchk/3, recordedchk_body/4), 230 tool(recorded_list/2, recorded_list_body/3), 231 tool(recorded_refs/3, recorded_refs_body/4), 232 tool(recordz/2, recordz_body/3), 233 tool(recordz/3, recordz_body/4), 234 tool(rerecord/2, rerecord_body/3), 235 tool(set_default_error_handler/2, set_default_error_handler_/3), 236 tool(set_flag/3, set_flag_body/4), 237 tool(setof/3, setof_body/4), 238 tool(shelf_dec/2, shelf_dec_/3), 239 tool(shelf_get/3, shelf_get_/4), 240 tool(shelf_inc/2, shelf_inc_/3), 241 tool(shelf_set/3, shelf_set_/4), 242 tool(store_create_named/1, store_create_named_/2), 243 tool(store_count/2, store_count_/3), 244 tool(store_erase/1, store_erase_/2), 245 tool(store_get/3, store_get_/4), 246 tool(store_inc/2, store_inc_/3), 247 tool(store_set/3, store_set_/4), 248 tool(store_contains/2, store_contains_/3), 249 tool(store_delete/2, store_delete_/3), 250 tool(store_info/1, store_info_/2), 251 tool(stored_keys/2, stored_keys_/3), 252 tool(stored_keys_and_values/2, stored_keys_and_values_/3), 253 tool(bytes_to_term/2, bytes_to_term_/3), 254 tool(term_to_bytes/2, term_to_bytes_/3), 255 tool(term_string/2, term_string_body/3), 256 tool(test_and_setval/3, test_and_setval_body/4), 257 tool(write/1, write_/2), 258 tool(write/2, write_/3), 259 tool(writeclause/1, writeclause_body/2), 260 tool(writeclause/2, writeclause_body/3), 261 tool(writeln/1, writeln_body/2), 262 tool(writeln/2, writeln_body/3), 263 tool(writeq/1, writeq_/2), 264 tool(writeq/2, writeq_/3), 265 tool(write_canonical/1, write_canonical_/2), 266 tool(write_canonical/2, write_canonical_/3), 267 tool((mode)/1, mode_/2). 268 269:- global_flags(0,16'00000880,_). % debug_compile (GOALEXPAND|DBGCOMP) on 270:- tool(trace/1, trace_body/2). % must be traceable 271:- tool(debug/1, debug_body/2). % must be traceable 272:- set_proc_flags(trace/1, spy, off, sepia_kernel). % spy was inherited... 273 274 275%------------------------------ 276% basic system initialisation 277%------------------------------ 278 279?- getval(sepiadir, Sepiadir), % initialized in C 280 concat_strings(Sepiadir, "/lib", Lib), 281 make_array_(library, prolog, local, sepia_kernel), 282 setval(library, Lib), 283 make_array_(library_path, prolog, local, sepia_kernel), 284 setval(library_path, [Lib]). 285 286?- argv(0, Sepia), % set up some global variables 287 setval(whoami, Sepia), % 'whoami' is created in bip_load.c 288 setval(binary, Sepia), % 'binary' is created in bip_load.c 289 make_array_(break_level, prolog, local, sepia_kernel), 290 setval(break_level, 0), 291 make_array_(prolog_suffix, prolog, local, sepia_kernel), 292 setval(prolog_suffix, ["", ".ecl", ".pl"]), 293 make_array_(eclipse_object_suffix, prolog, local, sepia_kernel), 294 setval(eclipse_object_suffix, ".eco"), 295 make_array_(eclipse_info_suffix, prolog, local, sepia_kernel), 296 setval(eclipse_info_suffix, ".eci"), 297 make_array_(version_cache, prolog, local, sepia_kernel). 298 299 300:- local_record(libraries/0), 301 local_record(compiled_modules/0). 302 303 304% Default language determined by: option, envvar, command line 305?- make_array_(default_language, prolog, local, sepia_kernel), 306 get_sys_flag(12, LanguageOption), 307 ( LanguageOption \== '' -> 308 Language = LanguageOption 309 ; getenv("ECLIPSEDEFAULTLANGUAGE", LangString) -> 310 atom_string(Language, LangString) 311 ; 312 Language = eclipse_language 313 ), 314 setval(default_language, Language). 315 316?- make_array_(toplevel_trace_mode, prolog, local, sepia_kernel), 317 setval(toplevel_trace_mode, nodebug). 318?- make_array_(compiled_stream, prolog, local, sepia_kernel), 319 setval(compiled_stream, _). 320?- make_array_(compile_stack, reference([]), local, sepia_kernel). 321 322% ignore_eof is 'on' for Windows, because ^C acts like eof (in Command Prompt) 323?- make_array_(ignore_eof, prolog, local, sepia_kernel), 324 get_sys_flag(8, Arch), % hostarch 325 ( (Arch == "i386_nt" ; Arch == "x86_64_nt") -> setval(ignore_eof, on) ; setval(ignore_eof, off)). 326 327% Hack for Java/Linux: if eclipse was loaded by a Java host program, then its 328% symbols may not be visible (loaded without RTLD_GLOBAL). In this case, 329% try to re-load the eclipse shared library (now with the right options). 330?- ( get_sys_flag(9, "so") -> % object_suffix 331 ( symbol_address("ec_",_) -> % look for any symbol from C kernel 332 true 333 ; 334 getval(sepiadir, Dir), 335 get_sys_flag(8, Arch), % hostarch 336 concat_string([Dir,"/lib/",Arch,"/libeclipse.so"], EclLib), 337 ( sys_file_flag(EclLib, 17 /*readable*/, on) -> 338 load(EclLib) 339 ; 340 true 341 ) 342 ) 343 ; 344 true 345 ). 346 347 348%------------------------------------ 349% Definitions for ,/2 ;/2 ->/2. 350% The definitions here are only used for waking such goals. 351% Occurrences in compiled code are expanded by the compiler, 352% and metacalls are handled by the emulator. 353%------------------------------------ 354 355:- tool((',')/2, ',_body'/3), 356 tool((;)/2, ';_body'/3), 357 tool((*->)/2, ',_body'/3), 358 tool((->)/2, '->_body'/3). 359 360',_body'(A, B, M) :- get_cut(Cut), ','(A, B, M, Cut). 361';_body'(A->B, C, M) :- -?-> !, get_cut(Cut), ';'(A, B, M, Cut, C). 362';_body'(A, B, M) :- get_cut(Cut), ';'(A, B, M, Cut). 363'->_body'(A, B, M) :- get_cut(Cut), '->'(A, B, M, Cut). 364 365 366%---------------------------------------------------------------------- 367% main/1 is invoked whenever the system is started or restarted. 368% This is the code that accepts posted goals, executes them, 369% and yields with the proper return codes. 370%---------------------------------------------------------------------- 371 372main(Restart) :- 373 ( Restart == 0 -> 374 % licence_check, % NOT ENABLED 375 startup_init, 376 restart_init 377 ; 378 restart_init, 379 error(151, _) % extension hook: restart 380 ), 381 embed_block([]). 382 383 embed_block(Goals) :- 384 catch(embed_repeat(Goals),ExitCode,embed_catch(ExitCode)). 385 386 embed_catch(ExitCode) :- 387 yield(2,ExitCode,Goals), % 2 == PTHROW 388 embed_block(Goals). 389 390 embed_repeat(Goals) :- 391 embed_loop(Goals). 392 embed_repeat(_Goals) :- 393 repeat, 394 yield(1,[],Goals), % 1 == PFAIL 395 embed_loop(Goals). 396 397 embed_loop(Goals) :- 398 default_module(M), 399 get_cut(Cut), 400 call_loop(Goals,M), 401 yield(0,Cut,NewGoals), % 0 == PSUCCEED 402 embed_loop(NewGoals). 403 404 call_loop([],_M). 405 call_loop([G|Gs],M) :- 406 call(G)@M, 407 call_loop(Gs,M). 408 409 410yield(ToC,FromC) :- 411 yield(4,ToC,FromC). % 4 == PYIELD == EC_yield 412 413yield(YieldType,ToC,FromC) :- 414 yield(YieldType,ToC,FromC1,ResumeType), 415 yield_or_continue(ResumeType,FromC1,FromC). 416 417 % We may be resumed with one of the following resume codes: 418 % 0 == RESUME_CONT: continue and let yield/2,3 succeed 419 % 1 == RESUME_SIMPLE: handle events only 420 421 yield_or_continue(0, FromC, FromC). % 0 == RESUME_CONT 422 yield_or_continue(1, _FromC, FromC) :- % 1 == RESUME_SIMPLE 423 yield(0, [], FromC). % 0 == PSUCCEED 424 425 426 427% open(queue(""),read,ec_rpc_in,[event(ec_rpc)]) 428?- open(queue(""),read,ec_rpc_in), set_stream_prop_(ec_rpc_in, 17, ec_rpc). 429?- open(queue(""),update,ec_rpc_out). 430 431 432ec_rpc_in_handler(Base) :- 433 concat_atom([Base, '_in'], In), 434 concat_atom([Base, '_out'], Out), 435 ec_rpc_in_handler1(In, Out). 436 437ec_rpc_in_handler1(In, Out) :- 438 ( at_eof(In) -> 439 flush(Out) 440 ; 441 empty_stream(Out), 442 catch((read_exdr_last(In, Goal),execute_rpc(Out, Goal, true)), 443 _, (write_exdr(Out, throw),flush(Out))), 444 ec_rpc_in_handler1(In, Out) 445 ). 446 447 empty_stream(Stream) :- 448 ( at_eof(Stream) -> true ; get(Stream,_), empty_stream(Stream) ). 449 450 read_exdr_last(Stream, Goal) :- 451 read_exdr(Stream, Goal0), 452 ( at_eof(Stream) -> Goal=Goal0 ; read_exdr_last(Stream, Goal) ). 453 454 execute_rpc(Out, GoalString, Extra) :- 455 string(GoalString), !, 456 default_module(M), 457 term_string(Goal, GoalString)@M, 458 execute_rpc(Out, Goal, Extra). 459 execute_rpc(Out, Goal, Extra) :- 460 default_module(M), 461 ( call(Goal)@M -> 462 call(Extra), 463 % write_exdr might fail if Goal is not valid EXDR! 464 (write_exdr(Out, Goal) -> true;true), flush(Out) 465 ; 466 call(Extra), 467 write_exdr(Out, fail), flush(Out) % PFAIL 468 ), 469 fail. 470 execute_rpc(_, _, _). 471 472?- set_error_handler_(ec_rpc,ec_rpc_in_handler/1,sepia_kernel). 473 474startup_init :- 475 default_module(M), 476 default_module(M), % set 477 argv(all, [_|Args]), 478 process_command_line_startup(Args, 1), 479 default_module(TM), % get 480 create_module_if_did_not_exist(TM, []), 481 getval(default_language, Language), 482 import_body(Language, TM), % TM was created in C, no imports yet 483 getval(library_path, Path0), 484 prepend_user_path(Path0, Path), 485 setval(library_path, Path). 486 487restart_init. 488 489 490%--------------------------------------------------------- 491% Parallel execution 492%--------------------------------------------------------- 493 494% When recomputation goes wrong, we loop (and the worker is lost). 495% This is still better than aborting the whole session. A more clever 496% recovery strategy would require special support from the scheduler. 497hang :- hang. 498 499slave :- 500 get_par_goal(pargoal(InitGoal, ParGoal)), 501 (catch(InitGoal, _, fail, eclipse) -> true ; true), 502 catch( 503 (install_pending_oracle, worker_boundary, ParGoal), 504 _, 505 (install_oracle(0),hang) 506 ), 507 fail. 508 509all_sol(Goal, Module) :- 510 call(Goal)@Module, 511 fail. 512 513par_all_body(InitGoal, Goal, Module) :- 514 set_par_goal(pargoal(InitGoal, all_sol(Goal, Module))), 515 ( 516 worker_boundary, % recomputing starts here 517 all_sol(Goal, Module) % fails 518 ; 519 true 520 ). 521 522 523gather_instances(Template, Generator, Module, Ref) :- 524 call(Generator)@Module, 525 true, % force waking before recording 526 dbag_enter(Ref, Template), 527 fail. 528 529par_findall_body(InitGoal, Template, Generator, List, Module) :- 530 % check_nesting 531 dbag_create(Ref), % on worker 1 532 set_par_goal(pargoal(InitGoal, 533 gather_instances(Template, Generator, Module, Ref))), 534 ( 535 worker_boundary, % recomputing starts here 536 gather_instances(Template, Generator, Module, Ref) % fails 537 ; 538 dbag_dissolve(Ref, List) % on worker 1 539 ). 540 541 542find_solution(Goal, Module, Ref) :- 543 call(Goal)@Module, 544 true, % force waking before recording 545 !, 546 dbag_enter(Ref, Goal), 547 fail. 548 549par_once_body(InitGoal, Goal, Module) :- 550 % check_nesting 551 dbag_create(Ref), % on worker 1 552 set_par_goal(pargoal(InitGoal, find_solution(Goal, Module, Ref))), 553 ( 554 worker_boundary, % recomputing starts here 555 find_solution(Goal, Module, Ref) % fails 556 ; 557 dbag_dissolve(Ref, [Goal]) % on worker 1 558 ). 559 560 561%--------------------------------------------------------- 562% defaults handlers for start/restart/end events 563%--------------------------------------------------------- 564 565extension(X):- 566 extension(X,0). 567 568configuration(C) :- 569 open("", string, S), 570 write(S, kernel), 571 ( 572 extension(E), 573 E \== dfid, E \== occur_check, 574 put(S, 0' ), 575 write(S, E), 576 fail 577 ; 578 stream_info_(S, 0, C), % name 579 close(S) 580 ). 581 582sepia_version(List, Stage, Date) :- 583 getval(version_cache, Cached), 584 ( var(Cached) -> 585 get_sys_flag(11, MajorMinorVersionAtom), 586 getval(library,Lib), 587 concat_string([Lib, "/version.pl"], VersionFile), 588 open(VersionFile, read, S), 589 read(S, sepia_date(Date0)), 590 read(S, sepia_stage(Stage)), 591 read(S, sepia_build(Build)), 592 close(S), 593 concat_string([MajorMinorVersionAtom,".",Build], VersionString), 594 split_string(VersionString, ".", " ", List0), 595 strings_to_numbers(List0, List1), 596 Cached = version(List1,Stage,Date0), 597 setval(version_cache, Cached) 598 ; 599 true 600 ), 601 version(List,Stage,Date) = Cached. 602 603 strings_to_numbers([], []). 604 strings_to_numbers([S|Ss], [N|Ns]) :- 605 number_string(N, S), 606 strings_to_numbers(Ss, Ns). 607 608sepia_version_banner(Text, Date) :- 609 get_sys_flag(11, Version), 610 get_sys_flag(8, Arch), 611 sepia_version(List, Stage, Date), 612 append(_, [Build], List), !, 613 configuration(Conf), 614 ( extension(development) -> 615 get_sys_flag(3, Pid), 616 concat_string([", PID=", Pid], PidInfo) 617 ; 618 PidInfo = "" 619 ), 620 ( bignum(0,_) -> 621 GmpCopyright = "\nGMP library copyright Free Software Foundation, see legal/lgpl.txt" 622 ; 623 GmpCopyright = "" 624 ), 625 concat_string([ 626 "ECLiPSe Constraint Logic Programming System [", Conf, "]" 627 "\nKernel and basic libraries copyright Cisco Systems, Inc." 628 "\nand subject to the Cisco-style Mozilla Public Licence 1.1" 629 "\n(see legal/cmpl.txt or http://eclipseclp.org/licence)" 630 "\nSource available at www.sourceforge.org/projects/eclipse-clp", 631 GmpCopyright, 632 "\nFor other libraries see their individual copyright notices" 633 "\nVersion ", Version, Stage, " #", Build, " (", Arch, "), ", 634 Date, PidInfo, "\n" 635 ], Text). 636 637 638%------------------------------ 639% Licensing 640%------------------------------ 641 642licence_check :- 643 LicStream = error, 644 645 % Check whether we have a licence file 646 getval(sepiadir, Dir), 647 concat_string([Dir,"/lib/licence.ecl"], LicFile0), 648 ( existing_file(LicFile0, [""], [readable], LicFile) -> 649 650 % Open licence file and backtrack over all licence entries in it 651 open(LicFile, read, S), 652 repeat, 653 catch(read(S, SignedLicenceTerm), _, SignedLicenceTerm=junk), 654 655 ( SignedLicenceTerm \== end_of_file -> 656 657 % Check signature 658 ( valid_signature(SignedLicenceTerm, LicenceTerm), 659 memberchk(licensee:Licensee, LicenceTerm) -> 660 true 661 ; 662 writeln(LicStream, "Invalid licence file entry"), 663 fail % warn but continue 664 ), 665 666 % Check host restriction, if any 667 ( memberchk(host:Host, LicenceTerm) -> 668 get_sys_flag(1, Host) % check host 669 ; 670 true % no host restriction 671 ), 672 !, % commit to this entry 673 674 % Check expiry date, if any 675 ( memberchk(expiry:Expiry, LicenceTerm) -> 676 local_time_string(Expiry, "%c", ExpiryDate), 677 ( get_sys_flag(5) > Expiry -> 678 printf(LicStream, "ECLiPSe: Licence expired %s, exiting%n", ExpiryDate), 679 fail % expired 680 ; 681 true % not expired 682 ) 683 ; 684 ExpiryDate = "never" % no expiry date 685 ), 686 687 % Check if the licence applies to this version 688 ( memberchk(version:MaxVersion, LicenceTerm) -> 689 sepia_version([Major,Minor|_], _, _), 690 ( [Major,Minor] @=< MaxVersion -> 691 printf(LicStream, "ECLiPSe: Licence only valid up to version %w, exiting%n", MaxVersion), 692 fail % invalid 693 ; 694 true % valid 695 ) 696 ; 697 true % no version limit 698 ), 699 700 printf(LicStream, "ECLiPSe licensed to: %s (expires %s)%n", [Licensee,ExpiryDate]) 701 702 ; 703 704 % No valid licence found, cut the repeat, close and fail 705 !, 706 close(S), 707 writeln(LicStream, "ECLiPSe: No Licence found, exiting"), 708 fail 709 ) 710 711 ; 712 writeln(LicStream, ">>> ECLiPSe Academic Version - strictly not for commercial use! <<<"), 713 true 714 ). 715 716 717% This is a naive implementation of the RSA algorithm 718% sign: Signature is powm(Digest,D,N) with private_key(D,N) 719% validate: Digest =:= powm(Signature,E,N) with public_key(E,N) 720% For the corresponding sign/2 and private key see lib(licensing) 721 722valid_signature(signed(Term, SignatureString), Term) :- 723 string(SignatureString), 724 number_string(Signature, SignatureString), 725 hash_secure(Term, Digest, sha), 726 public_key(E, N), % could succeed with alternative keys 727 Digest =:= powm(Signature,E,N), 728 !. 729 730public_key(65737, N) :- 731 % convert the bignum at runtime, so we don't require gmp for compiling 732 number_string(N, "21914161071951772490417739500054678264714316157992140467021105282300879910358542740162430501913497561468260342080059381256137594184082254908360199026967589435446562798562242943975279574163853396385755498066856539655902646718824668922469051215343559030281711267234935602376733839726736220820352137086182611433"). 733 734 735%------------------------------ 736% Halting the system - this can happen in two ways: 737% 738% If exit/1 is called from Prolog: 739% - run Prolog level finalization directly (to avoid nested emulator) 740% - call low-level cleanup via exit0/1 builtin 741% 742% If ec_cleanup() is called from a host program: 743% - run Prolog level finalization cleanup_before_exit/0 via new emulator 744% - call low-level cleanup directly from host program 745%------------------------------ 746 747halt :- 748 exit(0). 749 750exit(N) :- 751 check_integer_ge(N, 0), !, 752 cleanup_before_exit(N), % may abort 753 exit0(N). 754exit(N) :- 755 bip_error(exit(N)). 756 757% This one is called when ec_cleanup() is used from C 758cleanup_before_exit :- 759 cleanup_before_exit(0). 760 761 762 % All Prolog-level cleanup goes here! 763 cleanup_before_exit(N) :- 764 % Call user handler first, so it can abort the exit if desired 765 ( error(152, N) -> true ; true ), % may abort 766 767 erase_modules. 768 769 770%---------------------------------------- 771% Goal executed by the standalone system 772%---------------------------------------- 773 774standalone_toplevel :- 775 default_module(M), 776 argv(all, [_|Args]), 777 process_command_line(Args, 1, Goal, M), 778 ( var(Goal) -> 779 ensure_loaded(library(toplevel)), 780 call(toplevel:toplevel_init(tty)), 781 call(toplevel:toplevel) 782 783 % In the following, Goal is negated to make sure we always fail and 784 % untrail everything before exiting. Do not simplify this code! 785 ; catch(\+call(Goal)@M, T, top_throw(T)) -> 786 fail 787 ; 788 true 789 ). 790 791 top_throw(Tag) :- 792 ( stack_overflow_message(Tag) -> 793 true 794 ; 795 writeln(error, Tag) 796 ), 797 throw(Tag). 798 799:- mode process_command_line(+,+,-,+). 800process_command_line([], _I, _Goal, _M) :- !. 801process_command_line(["-f"|Args], I, Goal, M) :- !, 802 process_command_line(["-b"|Args], I, Goal, M). 803process_command_line(["-b", Arg |Args], I, Goal, M) :- !, 804 os_file_name(File, Arg), 805 catch(ensure_loaded(File, M), Tag, top_throw(Tag)), 806 MI is -I, argv(MI,2), % delete the 2 arguments 807 process_command_line(Args, I, Goal, M). 808process_command_line(["-e", Arg |Args], I, Goal, M) :- !, 809 open(Arg, string, Stream), 810 read(Stream, ArgTerm), 811 close(Stream), 812 ( var(Goal) -> Goal=ArgTerm ; true ), 813 MI is -I, argv(MI,2), % delete the 2 arguments 814 process_command_line(Args, I, Goal, M). 815process_command_line(["--" |_], I, _Goal, _M) :- !, 816 argv(-1, I). % delete args 1 to I 817process_command_line([_ |Args], I, Goal, M) :- 818 J is I+1, 819 process_command_line(Args, J, Goal, M). 820 821process_command_line_startup([], _I) :- !. 822process_command_line_startup(["-L",Arg|Args], I) :- !, 823 atom_string(Language, Arg), 824 setval(default_language, Language), 825 MI is -I, argv(MI,2), % delete the 2 arguments 826 process_command_line_startup(Args, I). 827process_command_line_startup(["-t",Arg|Args], I) :- !, 828 atom_string(TM, Arg), 829 ( is_a_module(TM) -> true ; 830 getval(default_language, Language), 831 create_module(TM, [], Language) 832 ), 833 default_module(TM), % set 834 MI is -I, argv(MI,2), % delete the 2 arguments 835 process_command_line_startup(Args, I). 836process_command_line_startup([_ |Args], I) :- 837 I1 is I+1, 838 process_command_line_startup(Args, I1). 839 840 841 842printf_with_current_modes_body(Stream, Value, Module) :- 843 printf_current(Stream, Value, '', Module). 844 845printf_goal_body(Stream, Value, Module) :- 846 printf_current(Stream, Value, 'G', Module). 847 848printf_current(Stream, Value, Goal, Module) :- 849 output_mode(Mode), 850 concat_string(['%', Mode, Goal, 'w'], Format), 851 printf_body(Stream, Format, [Value], Module). 852 853 854%------------------------------------------------------------------------ 855% numbers corresponding to permissions for a process's read/write/execute 856% permissions on a file used by sys_file_flag/3. 857% Need to be accessed in several places 858%------------------------------------------------------------------------ 859process_file_permission(readable, 17). 860process_file_permission(writable, 18). 861process_file_permission(executable, 19). 862 863 864%-------------------------------- 865% Mutual exclusion for parallel system 866%-------------------------------- 867 868mutex_init_body(Mutex, Module) :- 869 setval_body(Mutex, 0, Module). 870 871mutex_body(Mutex, Goal, Module) :- 872 get_sys_flag(10, Worker), 873 ( getval_body(Mutex, Worker, Module) -> % already ours (if nested) 874 ( call(Goal)@Module -> true ; fail ) 875 ; 876 catch(mutex_body(Mutex, Goal, Module, Worker), T, 877 mutex_exit(T, Mutex, Worker, Module)) 878 ). 879 880mutex_body(Mutex, Goal, Module, Worker) :- 881 ( test_and_setval_body(Mutex, 0, Worker, Module) -> 882 ( call(Goal)@Module -> 883 setval_body(Mutex, 0, Module) 884 ; 885 setval_body(Mutex, 0, Module), 886 fail 887 ) 888 ; 889 sleep(0.01), 890 mutex_body(Mutex, Goal, Module, Worker) 891 ). 892 893mutex_one_body(Mutex, Goal, Module) :- 894 get_sys_flag(10, Worker), 895 ( getval_body(Mutex, Worker, Module) -> % already ours (if nested) 896 ( call(Goal)@Module -> true ; fail ) 897 ; 898 catch(mutex_one_body(Mutex, Goal, Module, Worker), T, 899 mutex_exit(T, Mutex, Worker, Module)) 900 ). 901 902mutex_one_body(Mutex, Goal, Module, Worker) :- 903 ( test_and_setval_body(Mutex, 0, Worker, Module) -> 904 ( call(Goal)@Module -> 905 setval_body(Mutex, abort, Module) % abort the other workers 906 ; 907 setval_body(Mutex, 0, Module), 908 fail 909 ) 910 ; getval_body(Mutex, abort, Module) -> 911 true % aborted worker just succeeds 912 ; 913 sleep(0.01), 914 mutex_one_body(Mutex, Goal, Module, Worker) 915 ). 916 917mutex_exit(T, Mutex, Worker, Module) :- 918 % We don't know whether the lock was grabbed or not! 919 (test_and_setval_body(Mutex, Worker, 0, Module) -> true ; true), 920 throw(T). 921 922%-------------------------------- 923% Miscellaneous 924%-------------------------------- 925 926:- tool(fail_if/1, fail_if_body/2). 927fail_if_body(X, M) :- call(X)@M, !, fail. 928fail_if_body(_, _). 929 930:- tool((once)/1, once_body/2). 931once_body(X, M):- call(X)@M, !. 932 933default. % dummy definition 934 935untraced_true. 936 937!. 938 939(delay X) :- error(78, delay X). 940 941'?-'(H, B) :- error(78, (H ?- B)). % dummy 942 943'-->'(A, B) :- error(78, (A --> B)). % dummy 944 945X \= X :- true, !, fail. 946_ \= _. 947 948% obsolete 949event_retrieve(Event, Goal) :- 950 event_retrieve(Event, Goal, _). 951 952 953% Utility predicates for embedding 954exec_string(GoalString,Vars,Module) :- 955 open(GoalString,string,Stream), 956 readvar(Stream,Goal,Vars,Module), 957 close(Stream), 958 call(Goal)@Module. 959 960exec_exdr(GoalString,Module) :- 961 open(string(GoalString),read,Stream), 962 read_exdr(Stream, Goal), 963 close(Stream), 964 call_any(Goal, Module). 965 966 call_any(String, Module) :- string(String), !, 967 term_string(Goal, String)@Module, 968 call(Goal)@Module. 969 call_any(Goal, Module) :- 970 call(Goal)@Module. 971 972%------------------------------------------ 973% Some aliases (aliases for tools should 974% be made using duplicate tool definitions) 975%------------------------------------------ 976 977false :- fail. 978 979 980%------------------------------------------ 981% Recorded database 982% The related C code is in bip_record.c 983%------------------------------------------ 984 985 986% current_record_body/2 succeeds iff Key is a key of the indexed database 987% (This is terribly inefficient if Key is uninstantiated) 988 989current_record_body(Key, Module):- 990 var(Key), !, 991 current_functor(Functor, Arity, 1, 0), 992 functor(Key, Functor, Arity), 993 is_record_body(Key, Module). 994current_record_body(Key, Module):- 995 ( valid_key(Key) -> 996 is_record_body(Key, Module) 997 ; 998 bip_error(current_record(Key), Module) 999 ). 1000 1001 1002% rerecord_body/3 removes all values associated with the first argument before 1003% associating the second argument with the first 1004 1005rerecord_body(Key, Value, Module):- 1006 ( valid_key(Key) -> 1007 erase_all_body(Key, Module), 1008 recorda_body(Key, Value, Module) 1009 ; 1010 bip_error(rerecord(Key, Value), Module) 1011 ). 1012 1013 1014% erase_body/3 removes an indexed database entry that has been asserted 1015% by record or rerecord. It erases the first matching value only, so we 1016% don't need to worry about logical update semantics. 1017 1018erase_body(Key, Value, Module):- 1019 ( valid_key(Key) -> 1020 first_recorded_(Key, Value, DbRef, Module), 1021 erase_first_matching(DbRef, Value) 1022 ; 1023 bip_error(erase(Key, Value), Module) 1024 ). 1025 1026 erase_first_matching(DbRef, Value) :- 1027 ( referenced_record(DbRef, Value) -> 1028 erase(DbRef) 1029 ; 1030 next_recorded(DbRef, Value, DbRef1), 1031 erase_first_matching(DbRef1, Value) 1032 ). 1033 1034erase_all_body(Key, Value, Module):- 1035 ( valid_key(Key) -> 1036 ( first_recorded_(Key, Value, DbRef, Module) -> 1037 erase_matching(DbRef, Value) 1038 ; 1039 true 1040 ) 1041 ; 1042 bip_error(erase(Key, Value), Module) 1043 ). 1044 1045 erase_matching(end, _Value) :- !. 1046 erase_matching(DbRef, Value) :- 1047 ( next_recorded(DbRef, Value, DbRef1) -> true ; DbRef1 = end ), 1048 ( \+ referenced_record(DbRef, Value) -> 1049 true 1050 ; 1051 erase(DbRef) 1052 ), 1053 erase_matching(DbRef1, Value). 1054 1055recorded_body(Key, Value, Module) :- 1056 recorded_body(Key, Value, _DbRef, Module). 1057 1058 1059recorded_body(Key, Value, DbRef, Module) :- 1060 ( valid_key(Key) -> 1061 /* Value used as a filter to reduce DbRef returned */ 1062 recorded_refs_body(Key, Value, DbRefs, Module), 1063 member(DbRef, DbRefs), 1064 referenced_record(DbRef, Value) 1065 ; 1066 bip_error(recorded(Key, Value, DbRef), Module) 1067 ). 1068 1069 1070% recordedchk/2,3 find only the first matching record, 1071% so no need to worry about logical update semantics 1072 1073recordedchk_body(Key, Value, Module) :- 1074 recordedchk_body(Key, Value, _DbRef, Module). 1075 1076 1077recordedchk_body(Key, Value, DbRef, Module) :- 1078 ( valid_key(Key) -> 1079 first_recorded_(Key, Value, DbRef0, Module), 1080 recorded_member(DbRef0, Value, DbRef) 1081 ; 1082 bip_error(recordedchk(Key, Value, DbRef), Module) 1083 ). 1084 1085 recorded_member(DbRef0, Value, DbRef) :- 1086 ( referenced_record(DbRef0, Value) -> 1087 DbRef = DbRef0 1088 ; 1089 next_recorded(DbRef0, Value, DbRef1), 1090 recorded_member(DbRef1, Value, DbRef) 1091 ). 1092 1093 1094% Erase all Store entries whose keys match Module:_ 1095store_erase_qualified(Store, Module) :- 1096 stored_keys(Store, Entries), 1097 Key = Module:_, 1098 member(Key, Entries), 1099 store_delete(Store, Key), 1100 fail. 1101store_erase_qualified(_, _). 1102 1103 1104%---------------------------------------------------------------------- 1105% Compiling and loading 1106%---------------------------------------------------------------------- 1107 1108% ensure_loaded(FileNameOrList, Module) 1109 1110ensure_loaded([H|T], Module) :- 1111 -?-> 1112 !, 1113 ensure_loaded(H, Module), 1114 ensure_loaded(T, Module). 1115ensure_loaded([], _) :- -?-> !. 1116ensure_loaded(File, Module) :- 1117 get_file(File, yes, FileAtom), 1118 !, 1119 ensure_loaded1(FileAtom, Module). 1120ensure_loaded(File, Module) :- 1121 bip_error(ensure_loaded(File), Module). 1122 1123ensure_loaded1(FileAtom, Module) :- 1124 ( 1125 current_compiled_file(FileAtom, Time, _Module, _Goal), 1126 get_file_info(FileAtom, mtime, FTime), 1127 ( FTime =< Time -> 1128 true 1129 ; 1130 printf(warning_output, 1131 "WARNING: reloading %w because file has changed (%d -> %d)%n", 1132 [FileAtom, Time, FTime]), 1133 fail 1134 ) 1135 -> 1136 true 1137 ; 1138 compile_or_load(FileAtom, Module) 1139 ). 1140 1141 1142% Load compiler predicates lazily 1143% We can't use import-from currently because they are tools. 1144compile_term(Term) :- ecl_compiler:compile_term(Term). % @sepia_kernel 1145compile_term(Term,Options) :- ecl_compiler:compile_term(Term,Options). % @sepia_kernel 1146 1147 1148compile_or_load(FileAtom, Module) :- 1149 ( 1150 get_flag(eclipse_object_suffix, ECO), 1151 suffix(FileAtom, ECO) 1152 -> 1153 load_eco(FileAtom, Module) 1154 ; 1155 ecl_compiler:compile_(FileAtom,Module) 1156 ). 1157 1158 1159% For loading kernel.eco at boot time, we use the C-level load_eco/4 directly. 1160% Subsequently, we use this code here, which is more complete in the sense 1161% that it raises all the events, changes directory, etc. 1162 1163load_eco(FileAtom, Module) :- 1164 error(146, FileAtom, Module), % COMPILER_START 1165 pathname(FileAtom, ParentDir), 1166 getcwd(OldPath), 1167 cd(ParentDir), 1168 cputime(Time0), 1169 ( catch(load_eco(FileAtom, 0, Module, FileModule), 1170 Tag, 1171 (cd(OldPath), 1172 (error(147, FileAtom) -> true; true), % COMPILER_ABORT 1173 throw(Tag))) 1174 -> 1175 Time is cputime - Time0, 1176 error(149, end_of_file, FileModule), % CODE_UNIT_LOADED 1177 error(139, (FileAtom,-1,Time), FileModule), % COMPILED_FILE 1178 cd(OldPath), 1179 error(166, FileAtom-(sepia_kernel:load_eco(FileAtom,Module)), Module) 1180 ; 1181 cd(OldPath), 1182 fail 1183 ). 1184 1185 1186compiled_stream(S) :- 1187 check_var_or_stream_spec(S), !, 1188 getval(compiled_stream, CS), 1189 nonvar(CS), % fails if nothing is being compiled 1190 ( var(S) -> S = CS ; get_stream(S, CS) ). 1191compiled_stream(S) :- 1192 bip_error(compiled_stream(S)). 1193 1194 1195% This is the body of ./2, no module checking necessary. 1196% When ./2 occurs as a directive, it is taken as include/1. 1197% If it is called, we use this code here, and either load or compile. 1198compile_list_body(H, T, Module) :- %local to the kernel (tool body) 1199 Files = [H|T], 1200 is_list(Files), !, 1201 comp_or_load_list(Files, Module). 1202compile_list_body(H, T, Module) :- 1203 error(5, [H|T], Module). 1204 1205 comp_or_load_list([], _). 1206 comp_or_load_list([File|Files], M) :- 1207 ( get_file(File, yes, FileAtom) -> 1208 compile_or_load(FileAtom, M) 1209 ; 1210 bip_error([File], M) 1211 ), 1212 comp_or_load_list(Files, M). 1213 1214 1215%---------------------------------------------------------------------- 1216% File handling primitives 1217%---------------------------------------------------------------------- 1218 1219exists(File) :- 1220 check_atom_string(File), 1221 !, 1222 expand_filename(File, FileNameS, 1), % EXPAND_STANDARD 1223 existing_path(FileNameS, _any). 1224exists(File) :- 1225 bip_error(exists(File)). 1226 1227 1228existing_file(_, _, _, _) :- 1229 set_bip_error(0). % reset bip_error, always fails 1230existing_file(Base0, Extensions, Permissions, FileName) :- 1231 check_proper_list(Extensions), 1232 check_proper_list(Permissions), 1233 expand_wrapper(Base0, Base, ReturnType), 1234 member(Ext, Extensions), % Caution: fails to bip_error/1 1235 check_basic_atomic(Ext), 1236 concat_string([Base, Ext], FileNameS0), 1237 expand_filename(FileNameS0, FileNameS, 1), % EXPAND_STANDARD 1238 existing_path(FileNameS, file), /* must not be a directory */ 1239 check_permissions(Permissions, FileNameS), 1240 % FileNameS may be absolute, but we want to return 1241 % a relative one if a relative one was given 1242 expand_filename(FileNameS0, FileNameS1, 0), % EXPAND_SYNTACTIC 1243 ( string(ReturnType) -> FileName = FileNameS1 1244 ; atom_string(FileName, FileNameS1) 1245 ). 1246existing_file(Base, Exts, Perms, File) :- 1247 % we may fail here normally, that's why we set_bip_error(0) above 1248 bip_error(existing_file(Base, Exts, Perms, File)). 1249 1250existing_path(Path, Type) :- 1251 % the atime-request fails for nonexisting files and 1252 % for the pseudo-files aux,con,nul,prn on Windows 1253 sys_file_flag(Path, 6, _), % atime 1254 sys_file_flag(Path, 0, Mode), % mode 1255 (8'40000 =:= Mode /\ 8'170000 -> 1256 Type = dir 1257 ; 1258 Type = file 1259 ). 1260 1261 check_permissions([], _) :- !. 1262 check_permissions([P|Ps], FileNameS) :- 1263 ((atom(P), process_file_permission(P, N)) -> 1264 sys_file_flag(FileNameS, N, on), 1265 check_permissions(Ps, FileNameS) 1266 ; set_bip_error(6) 1267 ). 1268 1269 expand_wrapper(library(File), PathFile, ReturnType) :- -?-> 1270 !, 1271 check_atom_string(File), 1272 ReturnType = File, 1273 getval(library_path, Path), 1274 member(Lib, Path), 1275 concat_string([Lib, '/', File], PathFile0), 1276 ( PathFile = PathFile0 1277 ; 1278 pathname(File, _, ModuleS), 1279 concat_string([PathFile0, '/', ModuleS], PathFile) 1280 ). 1281 expand_wrapper(File, File, File) :- 1282 check_atom_string(File). 1283 1284 1285canonical_path_name(Path, CanPath) :- 1286 check_atom_string(Path), 1287 !, 1288 expand_filename(Path, CanPathString0, 3), % EXPAND_NORMALISE 1289 string_length(CanPathString0, L), 1290 ( get_string_code(L, CanPathString0, 0'/) -> 1291 CanPathString = CanPathString0 1292 ; sys_file_flag(CanPathString0, 0) /\ 8'170000 =:= 8'40000 -> 1293 % it's a directory 1294 concat_strings(CanPathString0, "/", CanPathString) 1295 ; 1296 CanPathString = CanPathString0 1297 ), 1298 ( atom(Path) -> 1299 atom_string(CanPathAtom, CanPathString), 1300 CanPath = CanPathAtom 1301 ; 1302 CanPath = CanPathString 1303 ). 1304canonical_path_name(Path, CanPath) :- 1305 bip_error(canonical_path_name(Path, CanPath)). 1306 1307 1308% Get source or precompiled file for compilation, loading, etc. 1309% suceeds or fail with bip error set 1310get_file(Var, _, _) :- 1311 var(Var), 1312 !, 1313 set_bip_error(4). 1314get_file(user, _, user) :- !, 1315 ( get_stream_info(stdin, device, queue) -> set_bip_error(193) ; true ). 1316get_file(Base, WithObj, FullFileAtom) :- 1317 getval(prolog_suffix, Sufs0), 1318 (WithObj == yes -> 1319 getval(eclipse_object_suffix, Obj), 1320 append([Obj], Sufs0, Sufs) 1321 ; Sufs0 = Sufs 1322 ), 1323 (existing_file(Base, Sufs, [readable], FullFile0) -> 1324 % only the first choice 1325 canonical_path_name(FullFile0, FullFile), 1326 (atom(FullFile) -> 1327 FullFile = FullFileAtom ; atom_string(FullFileAtom, FullFile) 1328 ) 1329 ; 1330 nonvar(Base), 1331 (Base = library(_) -> set_bip_error(173) ; set_bip_error(171)) 1332 ), 1333 !. 1334get_file(_, _, _) :- 1335 set_bip_error(5). 1336 1337 1338%---------------------------------------------------------------------- 1339% Checks to be done at the end of a compilation: 1340% 1341% For all modules into which we have compiled something, check for 1342% predicates which are 1343% - declared (demon,tool,visibility,call_type...) but not defined (no code) 1344% - referenced (call compiled) but not declared not defined 1345% Note that this check is only done at the end of the toplevel compilation. 1346% If it were done at the end of every compiled file we would possibly 1347% check incomplete modules and get lots of unjustified warnings. 1348% Instead compiled_file_handler/3 just records every module and we 1349% check them all here in one go. 1350%---------------------------------------------------------------------- 1351 1352declaration_checks :- 1353 recorded_list(compiled_modules, Modules0), 1354 erase_all(compiled_modules), 1355 sort(Modules0, Modules), % remove duplicates 1356 declaration_checks(Modules). 1357 1358 declaration_checks([]). 1359 declaration_checks([M|Ms]) :- 1360 declaration_check(M), 1361 declaration_checks(Ms). 1362 1363 declaration_check(M) :- 1364 atom(M), 1365 current_module(M), 1366% writeln(declaration_check(M)), 1367 \+ is_locked(M), 1368 predicate_class_and_error(Class, Error, DisablingPragma), 1369 \+ current_pragma_(DisablingPragma, M), 1370 current_module_predicate(Class, P, M), 1371 \+ deprecated_reexported(Class, P, M), 1372 error(Error, P, M), 1373 fail. 1374 declaration_check(_). 1375 1376 predicate_class_and_error(undefined, 76, undefined_warnings(off)). 1377 predicate_class_and_error(undeclared, 77, undeclared_warnings(off)). 1378 predicate_class_and_error(no_module, 85, no_module_warnings(off)). 1379 predicate_class_and_error(no_export, 84, no_export_warnings(off)). 1380 predicate_class_and_error(deprecated, 75, deprecated_warnings(off)). 1381 1382 % Suppress deprecation warnings for reexported predicates 1383 % if pragma(deprecated_warnings(not_reexports)) is active 1384 deprecated_reexported(deprecated, P, M) :- 1385 current_pragma_(deprecated_warnings(not_reexports), M), 1386 get_flag_body(P, visibility, reexported, M). 1387 1388 1389%---------------------------------------------------------------------- 1390% Pragmas 1391% 1392% Pragmas are initially seen and interpreted by the compiler. If the 1393% compiler doesn't understand a pragma, it raises error 148 BAD_PRAGMA. 1394% The handler then records the pragma (together with its module context) 1395% for later retrieval via current_pragma/1. Pragmas can be either: 1396% 1397% Compound terms: any pragma with identical functor name overrides any 1398% previously given pragma with the same functor, e.g. in 1399% :- pragma(verbose(little)). 1400% :- pragma(verbose(very)). 1401% the second will override the first. It can't be erased completely. 1402% 1403% Atoms: a pragma called 'noxxx' replaces a previously given pragma 'xxx', 1404% a pragma called 'xxx' replaces a previously given pragma 'noxxx'. 1405% 1406%---------------------------------------------------------------------- 1407 1408:- store_create_named(pragmas). 1409 1410record_pragma(Pragma, Module) :- 1411 atom(Pragma), 1412 atom_string(Pragma, PragmaString), 1413 ( substring(PragmaString, "no", 1) -> 1414 substring(PragmaString, 2, _, 0, YesPragmaString), 1415 atom_string(YesPragma, YesPragmaString), 1416 store_delete(pragmas, Module:YesPragma), 1417 store_set(pragmas, Module:Pragma, Pragma) 1418 ; 1419 concat_atoms(no, Pragma, NoPragma), 1420 store_delete(pragmas, Module:NoPragma), 1421 store_set(pragmas, Module:Pragma, Pragma) 1422 ). 1423record_pragma(Pragma, Module) :- 1424 compound(Pragma), 1425 functor(Pragma, Name, Arity), 1426 store_set(pragmas, Module:Name/Arity, Pragma). 1427 1428 1429:- tool(current_pragma/1, current_pragma_/2). 1430current_pragma_(Pragma, Module) :- 1431 var(Pragma), 1432 stored_keys_and_values(pragmas, Pragmas), 1433 member((Module:_)-Pragma, Pragmas). 1434current_pragma_(Pragma, Module) :- 1435 atom(Pragma), 1436 store_get(pragmas, Module:Pragma, Pragma). 1437current_pragma_(Pragma, Module) :- 1438 compound(Pragma), 1439 functor(Pragma, Name, Arity), 1440 store_get(pragmas, Module:Name/Arity, Pragma). 1441 1442 1443erase_module_pragmas(Module) :- 1444 reset_name_ctr(Module), 1445 store_erase_qualified(pragmas, Module). 1446 1447 1448%---------------------------------------------------------------------- 1449% Compiled-file database 1450% We record tuples of the form: 1451% .(AtomicCanonicalFile,Module,Time,CompId,RecompilationGoal) 1452%---------------------------------------------------------------------- 1453 1454:- local_record(compiled_file/0). 1455 1456% File is assumed to be an atom, and the canonical name 1457record_compiled_file(File, Goal, Module) :- 1458 ( exists(File) -> 1459 get_file_info(File, mtime, Time), 1460 (recordedchk(compiled_file, .(File, _, _, _), Ref) -> 1461 erase(Ref) 1462 ; 1463 true 1464 ), 1465 recorda(compiled_file, .(File, Module, Time, Goal)) 1466 ; 1467 % some phony file name, like 'user' 1468 true 1469 ). 1470 1471 1472current_compiled_file(File, Time, Module, Goal) :- 1473 ( var(File) -> 1474 true 1475 ; 1476 ( string(File) -> 1477 atom_string(FileA, File) 1478 ; 1479 FileA = File 1480 ), 1481 canonical_path_name(FileA, CanonicalFileA) 1482 ), 1483 recorded(compiled_file, .(CanonicalFileA, Module, Time, Goal)), 1484 % don't leave a choicepoint in + mode 1485 ( var(File) -> File = CanonicalFileA ; File = CanonicalFileA, ! ). 1486 1487 1488% change the module-field of a record 1489change_compiled_file_module(FileAtom, FileMod) :- 1490 ( recordedchk(compiled_file, .(FileAtom, _Module, Time, Goal), Ref) -> 1491 erase(Ref), 1492 recorda(compiled_file, .(FileAtom, FileMod, Time, Goal)) 1493 ; 1494 true 1495 ). 1496 1497 1498% erase information about which files were compiled into Module 1499forget_module_files(Module) :- 1500 ( 1501 recorded(compiled_file, .(_File, Module, _Time, _Goal), Ref), 1502 erase(Ref), 1503 fail 1504 ; 1505 true 1506 ). 1507 1508 1509%---------------------------------------------------------------------- 1510% Initialization and finalization Goals 1511%---------------------------------------------------------------------- 1512 1513:- store_create_named(initialization_goals). 1514:- store_create_named(finalization_goals). 1515 1516store_goals(Which, Goal, Module) :- 1517 check_callable(Goal), % may fail with bip_error set 1518 ( store_get(Which, Module, Bag) -> 1519 true 1520 ; 1521 bag_create(Bag), 1522 store_set(Which, Module, Bag) 1523 ), 1524 bag_enter(Bag, Goal). 1525 1526 1527run_stored_goals(Which, Module) :- 1528 ( store_get(Which, Module, Bag) -> 1529 store_delete(Which, Module), 1530 bag_dissolve(Bag, Goals), 1531 run_list_of_goals(Goals, Module) 1532 ; 1533 true 1534 ). 1535 1536 run_list_of_goals([], _). 1537 run_list_of_goals([Goal|Goals], Module) :- 1538 ( catch(call(Goal)@Module, _Tag, fail) -> 1539 true 1540 ; 1541 error(167, Goal, Module) 1542 ), 1543 run_list_of_goals(Goals, Module). 1544 1545 1546forget_stored_goals(Which, Module) :- 1547 store_delete(Which, Module). 1548 1549 1550%---------------------------------------------------------------------- 1551% Discontiguous predicates (ISO) 1552% 1553% Discontiguous predicates are handled by initially recording their 1554% (annotated) source, rather than compiling them immediately. 1555% Clauses are stored in a bag which itself is stored in a hash store 1556% which maps: module:name/arity -> BagHandle 1557% At the end of a compilation unit, collect_discontiguous_predicates/2 1558% is invoked, and all discontiguous clauses for this unit compiled. 1559% The source store entries are removed. We could make it possible to 1560% call the predicates (e.g. in a file query) before the end of file 1561% is reached by invoking demand-driven compilation in the undefined-handler. 1562%---------------------------------------------------------------------- 1563 1564:- store_create_named(discontiguous_clauses). 1565 1566 1567% discontiguous declaration 1568:- tool(discontiguous/1, discontiguous_/2). 1569 1570discontiguous_(X, Module) :- -?-> X = [_|_], !, 1571 discontiguous_list(X, Module). 1572discontiguous_(X, Module) :- -?-> X = (_,_), !, 1573 discontiguous_seq(X, Module). 1574discontiguous_(X, Module) :- 1575 discontiguous1(X, Module). 1576 1577 discontiguous_list(X, Module) :- var(X), !, 1578 error(4, discontiguous(X), Module). 1579 discontiguous_list([], _). 1580 discontiguous_list([P|Ps], Module) :- 1581 discontiguous1(P, Module), 1582 discontiguous_list(Ps, Module). 1583 discontiguous_list(X, Module) :- 1584 error(5, discontiguous(X), Module). 1585 1586 discontiguous_seq((P,Ps), Module) :- -?-> !, 1587 discontiguous1(P, Module), 1588 discontiguous_seq(Ps, Module). 1589 discontiguous_seq(X, Module) :- 1590 discontiguous1(X, Module). 1591 1592 discontiguous1(PredSpec, Module) :- var(PredSpec), !, 1593 error(4, discontiguous(PredSpec), Module). 1594 discontiguous1(PredSpec, Module) :- 1595 PredSpec = _/_, 1596 !, 1597 ( get_flag(PredSpec, stability, dynamic)@Module -> 1598 true % ignore discontiguous declaration 1599 ; 1600 % Various cases: 1601 % - already declared (ok) 1602 % - has clauses from previous compilation of the same file 1603 % (silently replace) 1604 % - has clauses that were compiled earlier in this file 1605 % (silently replace, since we can't distinguish from previous case) 1606 % - already has clauses from other file 1607 % (will raise multifile-event when compiled later) 1608 ( get_flag(PredSpec, declared, on)@Module -> 1609 true 1610 ; 1611 local(PredSpec)@Module 1612 ), 1613 Key = Module:PredSpec, 1614 ( store_contains(discontiguous_clauses, Key) -> 1615 % ISO allows multiple declarations for the same predicate 1616 true 1617 ; 1618 % Start collecting clauses from now on 1619 bag_create(Bag), 1620 store_set(discontiguous_clauses, Key, Bag) 1621 ) 1622 ). 1623 discontiguous1(PredSpec, Module) :- 1624 error(5, discontiguous(PredSpec), Module). 1625 1626record_discontiguous_predicate(Pred, Clauses, AnnClauses, Module) :- 1627 store_get(discontiguous_clauses, Module:Pred, Bag), % may fail 1628 record_discontiguous_clauses(Bag, Clauses, AnnClauses). 1629 1630 record_discontiguous_clauses(_Bag, [], _). 1631 record_discontiguous_clauses(Bag, [Clause|Clauses], AnnClauses0) :- 1632 ( nonvar(AnnClauses0) -> AnnClauses0 = [AnnClause|AnnClauses1] ; true ), 1633 bag_enter(Bag, Clause-AnnClause), 1634 record_discontiguous_clauses(Bag, Clauses, AnnClauses1). 1635 1636collect_discontiguous_predicates(Module, Preds) :- 1637 stored_keys(discontiguous_clauses, Keys), 1638 collect_discontiguous_predicates(Keys, Module, Preds, []). 1639 1640 collect_discontiguous_predicates([], _Module, Preds, Preds). 1641 collect_discontiguous_predicates([Key|Keys], Module, Preds0, Preds) :- 1642 ( Key = Module:Pred -> 1643 store_get(discontiguous_clauses, Key, Bag), 1644 store_delete(discontiguous_clauses, Key), 1645 bag_dissolve(Bag, Clauses), 1646 Preds0 = [Pred-Clauses|Preds1] 1647 ; 1648 Preds0 = Preds1 1649 ), 1650 collect_discontiguous_predicates(Keys, Module, Preds1, Preds). 1651 1652% module has been erased: forget the declarations and bagged clauses 1653forget_discontiguous_predicates(Module) :- 1654 stored_keys(discontiguous_clauses, Keys), 1655 forget_discontiguous_predicates(Keys, Module). 1656 1657 forget_discontiguous_predicates([], _Module). 1658 forget_discontiguous_predicates([Key|Keys], Module) :- 1659 ( Key = Module:_ -> 1660 % the clause macro is already gone because the module was erased! 1661 store_get(discontiguous_clauses, Key, Bag), 1662 bag_abolish(Bag), 1663 store_delete(discontiguous_clauses, Key) 1664 ; 1665 true % other module, ignore 1666 ), 1667 forget_discontiguous_predicates(Keys, Module). 1668 1669 1670%---------------------------------------------------------------------- 1671% Inlined predicates 1672% 1673% Inlined predicates are handled by recording their (normalised) source 1674% while they are being compiled, and using that via the normal inline 1675% (goal expansion) mechanism. The transformation predicate is unfold/6. 1676%---------------------------------------------------------------------- 1677 1678:- store_create_named(inlined_predicates). 1679 1680inline_(Proc, Module) :- 1681 define_macro_(Proc, unfold/6, [goal], Module), 1682 store_delete(inlined_predicates, Module:Proc). 1683 1684inline_(Proc, Trans, Module) :- 1685 define_macro_(Proc, Trans, [goal], Module). 1686 1687 1688unfold(Goal, Unfolded, AnnGoal, AnnUnfolded, _CM, LM) :- 1689 functor(Goal, F, N), 1690 store_get(inlined_predicates, LM:F/N, Stored), % may fail 1691 Stored = source(Head, Body, AnnBody), 1692 ( Goal=Head -> Unfolded=Body ; Unfolded=true ), 1693 ( var(AnnGoal) -> 1694 % leave AnnUnfolded uninstantiated 1695 true 1696 ; var(AnnBody) -> 1697 % inherit Goal's annotation for everything 1698 transformed_annotate_anon(Unfolded, AnnGoal, AnnUnfolded) 1699 ; 1700 % Body keeps its annotations. CAUTION: the Goal=Head unification 1701 % above may instantiate variables, and thus render the 'var' 1702 % annotations invalid. However, currently the AnnBody returned 1703 % by the compiler does not contain annotated variable, so we are ok. 1704 % repair_annotation(AnnBody, AnnUnfolded) 1705 AnnUnfolded = AnnBody 1706 ). 1707 /* 1708 % conservative expansion, ever useful? 1709 Unfolded = (Goal=Head, Body), 1710 ( var(AnnGoal) -> 1711 % leave AnnUnfolded uninstantiated 1712 true 1713 ; var(AnnBody) -> 1714 % inherit Goal's annotation for everything 1715 transformed_annotate_anon(Unfolded, AnnGoal, AnnUnfolded) 1716 ; 1717 % Argument unification inherits Goal's annotation 1718 transformed_annotate_anon(Head, AnnGoal, AnnHead), 1719 inherit_annotation(AnnGoal=AnnHead, AnnGoal, AnnUnify), 1720 % Body keeps its annotations, comma inherits Body's annotation, 1721 inherit_annotation((AnnUnify,AnnBody), AnnBody, AnnUnfolded) 1722 ) 1723 */ 1724 1725 1726% Called by the compiler 1727record_inline_source(Head, Body, AnnBody, Module) :- 1728 functor(Head, F, N), 1729 store_set(inlined_predicates, Module:F/N, source(Head,Body,AnnBody)). 1730 1731 1732% module has been erased: forget the stored source 1733forget_inlined_predicates(Module) :- 1734 store_erase_qualified(inlined_predicates, Module). 1735 1736 1737%-------------------------------- 1738% Environment 1739%-------------------------------- 1740 1741abort :- 1742 get_sys_flag(10, W), % get_flag(worker, W) 1743 ( W==0 -> 1744 Where = "" 1745 ; 1746 concat_string([" on worker ", W], Where) 1747 ), 1748 printf(log_output, "Aborting execution%s ...\n%b", Where), 1749 throw(abort). 1750 1751sepiadir(S) :- 1752 getval(sepiadir, S). 1753 1754%:- system. 1755use_module_body([H|T], Module) :- 1756 -?-> 1757 !, 1758 use_module_body(H, Module), 1759 use_module_body(T, Module). 1760use_module_body([], _) :- -?-> !. 1761use_module_body(File, Module) :- 1762 get_module_name(File, FileMod, IsModuleName), 1763 ( load_module_if_needed(File, FileMod, Module) -> 1764 true 1765 ; 1766 % backward compatibility: if only a module name was specified, 1767 % and such a module exists, use it even if there is no such file 1768 IsModuleName == true, 1769 is_a_module(FileMod), 1770 (ignore_bip_error(171) -> true ; ignore_bip_error(173)) 1771 ), 1772 import_(FileMod, Module), 1773 import_interface(FileMod, Module), 1774 !. 1775use_module_body(File, Module) :- 1776 bip_error(use_module(File), Module). 1777 1778 ignore_bip_error(Ignored) :- 1779 get_bip_error(Err), 1780 ( Err == Ignored -> true ; set_bip_error(Err) ). 1781 1782% May fail with bip_error set 1783load_module_if_needed(_, _, Module) :- 1784 illegal_unlocked_module(Module, Err), 1785 !, 1786 set_bip_error(Err). 1787load_module_if_needed(File, FileMod, Module) :- 1788 get_file(File, yes, FileAtom), 1789 ensure_loaded1(FileAtom, Module), 1790 !, 1791 (is_a_module(FileMod) -> 1792 % fix the compiled_file-record to refer to the module that the 1793 % file defines rather than the one from which it was loaded. 1794 % This is necessary to erase the record when we erase the module. 1795 change_compiled_file_module(FileAtom, FileMod) 1796 ; 1797 set_bip_error(80) 1798 ). 1799load_module_if_needed(_, _, _) :- 1800 set_bip_error(173). 1801 1802 1803 1804% Extract the module name from a File/Library specification 1805 1806get_module_name(File, _, _) :- 1807 var(File), 1808 !, 1809 set_bip_error(4). 1810get_module_name(File, Module, IsModName) :- 1811 (string(File); atom(File)), 1812 !, 1813 pathname(File, Path, ModuleS, Suffix), 1814 atom_string(Module, ModuleS), 1815 ( Path="", Suffix="", atom(File) -> IsModName=true ; IsModName=false ). 1816get_module_name(library(File), Module, IsModName) :- 1817 -?-> 1818 !, 1819 get_module_name(File, Module, IsModName). 1820get_module_name(_, _, _) :- 1821 set_bip_error(5). 1822 1823 1824% If module LibModule already exists, succeed. 1825% Otherwise load library(LibModule) and check that LibModule was created. 1826% Fails with bip_error set. 1827 1828check_module_or_load_library(LibModule, _ContextModule) :- 1829 illegal_module(LibModule, Err), !, 1830 set_bip_error(Err). 1831check_module_or_load_library(LibModule, _ContextModule) :- 1832 is_a_module(LibModule), !. 1833check_module_or_load_library(LibModule, ContextModule) :- 1834 Library = library(LibModule), 1835 get_file(Library, yes, FileAtom), 1836 ensure_loaded1(FileAtom, ContextModule), 1837 !, 1838 (is_a_module(LibModule) -> 1839 true % it worked 1840 ; 1841 set_bip_error(80) 1842 ). 1843check_module_or_load_library(_, _) :- 1844 set_bip_error(173). 1845 1846 1847lib(Library, Module) :- % obsolete 1848 lib_(Library, Module). 1849 1850lib_(Library, Module) :- 1851 use_module_body(library(Library), Module). 1852 1853 1854current_module_predicate(Which, Pred, M) :- 1855 module_predicates(Which, Preds, M), 1856 % don't leave a choicepoint in ++ mode 1857 ( ground(Pred) -> memberchk(Pred, Preds) ; member(Pred, Preds) ). 1858 1859 1860% this predicate is called on macro transformation 1861% trans_term( <trans_pred>(OldTerm, NewTerm, Module), <trans_module>) 1862 1863trans_term(Goal, Module) :- 1864 subcall_init, % expanded subcall 1865 untraced_call(Goal, Module), 1866 !, 1867 subcall_fini(DG), 1868 ( DG == [] -> 1869 true 1870 ; 1871 error(129, Goal, Module) 1872 ). 1873trans_term(Goal, _) :- 1874 arg(1, Goal, Term), % if it fails return the old term 1875 arg(2, Goal, Term). 1876 1877%---------------------------------------------------------------- 1878% subcall(Goal, Delayed) 1879% call a goal, return the remaining delayed goals and undelay them 1880%---------------------------------------------------------------- 1881 1882:- tool(subcall/2, subcall/3). 1883 1884subcall(Goal, Delayed, Module) :- 1885 subcall_init, 1886 untraced_call(Goal, Module), 1887 true, % force all wakings 1888 subcall_fini(Delayed). 1889 1890% call_priority(Goal, Prio, Module) 1891% call the specified goal with the given priority, on return force waking 1892:- tool(call_priority/2, call_priority/3). 1893call_priority(Goal, Prio, Module) :- 1894 integer(Prio), !, 1895 get_priority(P), 1896 ( Prio < P -> 1897 set_priority(Prio, 1), 1898 call(Goal)@Module, 1899 set_priority(P, 1), 1900 wake 1901 ; Prio > P -> 1902 make_suspension(Goal, Prio, S, Module), 1903 schedule_suspensions(1, s([S])) 1904 % no wake/0 necessary 1905 ; 1906 call(Goal)@Module 1907 ). 1908call_priority(Goal, Prio, Module) :- 1909 ( var(Prio) -> E=4 ; E=5 ), 1910 error(E, call_priority(Goal,Prio), Module). 1911 1912 1913inline_calls(subcall(Goal, Delayed), Inlined, Module) :- -?-> 1914 nonvar(Goal), 1915 tr_goals(Goal, TrGoal, Module), 1916 Inlined = ( 1917 sepia_kernel:subcall_init, 1918 TrGoal, 1919 true, % force all wakings 1920 sepia_kernel:subcall_fini(Delayed) 1921 ). 1922inline_calls(call_priority(Goal, Prio), Inlined, Module) :- -?-> 1923 nonvar(Goal), 1924 tr_goals(Goal, TrGoal, Module), 1925 Inlined0 = ( 1926 get_priority(P), 1927 ( Prio =< P -> 1928 sepia_kernel:set_priority(Prio), 1929 TrGoal, % expand Goal only once, could be big! 1930 sepia_kernel:set_priority(P), 1931 wake 1932 ; 1933 make_suspension(Goal, Prio, S, Module), 1934 schedule_suspensions(1, s([S])) 1935 ) 1936 ), 1937 (integer(Prio) -> 1938 Inlined = Inlined0 1939 ; 1940 Inlined = ( 1941 integer(Prio) -> 1942 Inlined0 1943 ; var(Prio) -> 1944 error(4, call_priority(Goal, Prio), Module) 1945 ; 1946 error(5, call_priority(Goal, Prio), Module) 1947 ) 1948 ). 1949inline_calls(call_explicit(Goal, LM), Inlined, Module) :- -?-> 1950 tr_goals(LM:Goal, Inlined, Module). 1951 1952 1953% call_local(Goal, Module) 1954% [ This used to call Goal in an independent local computation, separating 1955% its woken goals from the current ones. That does not seem to make much 1956% sense though, since the saved goals temporarily effectively disappear from 1957% the resolvent, ie they are there but don't run even when woken again.] 1958% We are now just creating a local postponed-list. 1959call_local(Goal, Module) :- 1960 reinit_postponed(OldPL), 1961 call(Goal)@Module, 1962 trigger_postponed, 1963 reset_postponed(OldPL). 1964 1965 1966call_explicit_body(Goal, DefMod, CallerMod) :- 1967 :@(DefMod, Goal, CallerMod). 1968 1969'[]:@'(X, Goal, CallerMod) :- var(X), !, 1970 error(4, X:Goal, CallerMod). 1971'[]:@'([], _Goal, _CallerMod) :- !. 1972'[]:@'([LookupMod|LookupMods], Goal, CallerMod) :- !, 1973 :@(LookupMod, Goal, CallerMod), 1974 '[]:@'(LookupMods, Goal, CallerMod). 1975'[]:@'(LookupMod, Goal, CallerMod) :- 1976 :@(LookupMod, Goal, CallerMod). 1977 1978 1979% Backward compatibility: 1980call2_(Goal, CM, _) :- 1981 atom(CM), 1982 is_a_module(CM), 1983 !, 1984 call(Goal)@CM. 1985call2_(Goal, Arg, CM) :- 1986 call_(Goal, Arg, CM). 1987 1988 1989% 1990% call_boxed(Goal, OnCall, OnExit, OnRedo, OnFail) 1991% wrap a goal into four port actions 1992% 1993% Careful: this is all quite tricky and easy to break! 1994% 1995% The actions OnCall, OnExit, OnRedo, OnFail should always succeed without 1996% leaving choicepoints. Order of these actions: 1997% 1998% OnCall is done after requesting OnFail (if other order is needed, you can 1999% always call OnCall' before call_boxed and set OnCall to true). 2000% OnExit is done before requesting OnRedo (if other order is needed, you can 2001% always call OnExit' after call_boxed and set OnExit to true). 2002% 2003% Item serves two purposes: (1) it is the container for the timestamp. 2004% (2) it indicates to the GC that the fail-event trail frames are garbage 2005% when Item becomes garbage (the trail frames contain a weak pointer to Item). 2006% It is therefore important that there is an occurrence of Item in the code 2007% _after_ the call to Goal (otherwise Item could become garbage too early). 2008% 2009% OnFailEvent is not conditional on a choicepoint (always timestamp=old). 2010% OnFailEvent is disabled on exit and reenabled on redo. 2011% OnFailEvent is garbage collected after Item becomes garbage. 2012% OnRedoEvent is conditional on a choicepoint in Goal (timestamp=old/current). 2013% OnRedoEvent is garbage collected when its timestamp becomes current or when 2014% Item becomes garbage (which will normally happen simultaneously). 2015% 2016% The Age = current test is just an optimisation. Doing the else-case would 2017% also work: request_fail_event wouldn't do anything because of the timestamp. 2018% 2019 2020 2021call_boxed_(Goal, OnCall, OnExit, OnRedo, OnFail, Module) :- 2022 call_boxed_(Goal, OnCall, OnExit, OnRedo, OnFail, Module, Module). 2023 2024call_boxed_(Goal, OnCall, OnExit, OnRedo, OnFail, GoalModule, ActionModule) :- 2025 2026 Item = f(_F), timestamp_init(Item, 1), 2027 event_create(OnFail, OnFailEvent)@ActionModule, 2028 request_fail_event(Item, Item, 1, OnFailEvent), 2029 2030 call(OnCall)@ActionModule, 2031 2032 timestamp_update(Item, 1), 2033 call(Goal)@GoalModule, 2034 2035 call(OnExit)@ActionModule, 2036 event_disable(OnFailEvent), 2037 2038 timestamp_age(Item, 1, Age), % don't merge this line with the next! 2039 ( Age = current -> 2040 true 2041 ; 2042 event_create((event_enable(OnFailEvent),OnRedo), OnRedoEvent)@ActionModule, 2043 request_fail_event(Item, Item, 1, OnRedoEvent) 2044 ). 2045 2046 2047 2048%-------------------------------- 2049% Stuff moved here from the list library because the kernel needs it. 2050% Will be reexeported through lists later. 2051%-------------------------------- 2052 2053% member/2 2054% (This version doesn't leave a choicepoint after the last result) 2055member(X, [H|T]) :- member(X, H, T). 2056member(X, X, _). 2057member(X, _, [H|T]) :- member(X, H, T). 2058 2059 2060memberchk(X,[X|_]) :- true, !. 2061memberchk(X,[_|T]):- memberchk(X,T). 2062 2063 2064nonmember(Arg,[Arg|_]) :- true, !, 2065 fail. 2066nonmember(Arg,[_|Tail]) :- !, 2067 nonmember(Arg,Tail). 2068nonmember(_,[]). 2069 2070 2071% delete (?Element, ?List, ?Result) 2072% Result is List with Element removed 2073delete(A, [A|C], C). 2074delete(A, [B|C], [B|D]) :- 2075 delete(A, C, D). 2076 2077 2078append([], Ys, Ys). 2079append([X|Xs], Ys, [X|XsYs]) :- append(Xs, Ys, XsYs). 2080 2081 2082reverse(List, Rev) :- 2083 reverse(List, Rev, []). 2084 2085 reverse([], L, L). 2086 reverse([H|T], L, SoFar) :- 2087 reverse(T, L, [H|SoFar]). 2088 2089 2090% length(?List, ?Length) 2091% succeeds iff List is a list of length Length 2092 2093length(List, Length) :- 2094 var(Length), 2095 !, 2096 length(List, 0, Length). 2097length(List, Length) :- 2098 integer(Length), 2099 Length >= 0, 2100 length1(List, Length). 2101 2102 :- mode length(?,+,?). 2103 length([], Length, Length). 2104 length([_|L], N, Length) :- 2105 +(N, 1, N1), % because no inlining yet 2106 length(L, N1, Length). 2107 2108 :- mode length1(?,+). 2109 length1(L, 0) :- !, L=[]. 2110 length1([_|L], Length) :- 2111 -(Length, 1, N1), % because no inlining yet 2112 length1(L, N1). 2113 2114 2115% subtract(L1, L2, L3) 2116% L3 = L1 - L2 2117 2118subtract([], _, []). 2119subtract([Head|L1tail], L2, L3) :- 2120 memberchk(Head, L2), 2121 !, 2122 subtract(L1tail, L2, L3). 2123subtract([Head|L1tail], L2, [Head|L3tail]) :- 2124 subtract(L1tail, L2, L3tail). 2125 2126 2127same_length([], []). 2128same_length([_|Xs], [_|Ys]) :- 2129 same_length(Xs, Ys). 2130 2131%----------------------------- 2132% Module system 2133%----------------------------- 2134 2135% The compiler wraps queries inside module_interfaces 2136% into calls to record_interface/2 2137 2138record_interface((G1,G2), Module) :- -?-> 2139 record_interface(G1, Module), 2140 record_interface(G2, Module). 2141record_interface(Goal, Module) :- 2142 interpret_obsolete_queries(Goal, IGoal), !, 2143 ( IGoal == true -> 2144 true 2145 ; 2146 record_interface_directive(IGoal, Module) 2147 ), 2148 call(Goal)@Module. 2149record_interface(Goal, Module) :- 2150% printf(warning_output, 2151% "WARNING: not a proper interface query in interface of %w: %w%n", 2152% [Module,Goal]), 2153 call(Goal)@Module. 2154 2155 2156 % How to interpret queries in old-style module interfaces 2157 % in terms of new export directives 2158 % Non-interface export/reexport are interpreted as-is. 2159 2160 :- mode interpret_obsolete_queries(?,-). 2161 interpret_obsolete_queries(Var, _) :- var(Var), !, fail. 2162 interpret_obsolete_queries(global(_), true). 2163 interpret_obsolete_queries(local(_), true). 2164 interpret_obsolete_queries(export(_), true). 2165 interpret_obsolete_queries(reexport(_), true). 2166 interpret_obsolete_queries(call(_), true). 2167 interpret_obsolete_queries(use_module(M), use_module(M)). 2168 interpret_obsolete_queries(lib(M), use_module(library(M))). 2169 interpret_obsolete_queries(import(From), import(From)). 2170 interpret_obsolete_queries(op(A,B,C), export op(A,B,C)). 2171 interpret_obsolete_queries(set_chtab(A,B), export chtab(A,B)). 2172 interpret_obsolete_queries(define_macro(A,B,C), export macro(A,B,C)). 2173 interpret_obsolete_queries(set_flag(syntax_option,A), export syntax_option(A)). 2174 interpret_obsolete_queries(meta_attribute(A,B), global meta_attribute(A,B)). 2175 interpret_obsolete_queries(call_explicit(Goal,sepia_kernel), IGoal) :- 2176 interpret_obsolete_queries(Goal, IGoal). 2177 interpret_obsolete_queries(sepia_kernel:Goal, IGoal) :- 2178 interpret_obsolete_queries(Goal, IGoal). 2179 2180 2181% The interface is recorded as follows: 2182% - The interface queries of module M are recorded 2183% under the key M/1 (predicate exports are not recorded) 2184% - If M1 uses M2, the record M2 is recorded under the key M1/2 2185 2186record_interface_directive((export _/_), _Module) :- -?-> !. 2187record_interface_directive((export macro(F,TransPred,Options)), Module) :- -?-> !, 2188 qualify_(TransPred, QualTransPred, Module), 2189 init_module_record(1, (export macro(F,QualTransPred,Options)), Module). 2190record_interface_directive((export portray(F,TransPred,Options)), Module) :- -?-> !, 2191 qualify_(TransPred, QualTransPred, Module), 2192 init_module_record(1, (export portray(F,QualTransPred,Options)), Module). 2193record_interface_directive(Directive, Module) :- 2194 init_module_record(1, Directive, Module). 2195 2196 unqualify(Thing, CM, CM, Thing) :- var(Thing), !. 2197 unqualify(LM:Thing, _, LM, Thing) :- !. 2198 unqualify(Thing, CM, CM, Thing). 2199 2200 2201 init_module_record(N, Value, Module) :- 2202 functor(Key, Module, N), 2203 ( is_record(Key) -> true ; local_record(Module/N) ), 2204 ( recorded(Key, Old), compare_instances(=, Old, Value, _) -> 2205 true 2206 ; 2207 recordz(Key, Value) 2208 ). 2209 2210recorded_interface_directive(Module, Directive) :- 2211 functor(Key, Module, 1), 2212 recorded(Key, Directive). 2213 2214 2215record_module_import(Import, Module) :- 2216 init_module_record(2, Import, Module). 2217 2218recorded_module_import(Module, Import) :- 2219 functor(Key, Module, 2), 2220 recorded(Key, Import). 2221 2222erase_module_related_records(Module) :- 2223 % erase information about Module's interface queries 2224 functor(Key1, Module, 1), 2225 ( is_record(Key1) -> erase_all(Key1) ; true ), 2226 2227 % erase information about which modules were imported into Module 2228 functor(Key, Module, 2), 2229 ( is_record(Key) -> erase_all(Key) ; true ), 2230 2231 % erase any information stored on behalf of the module 2232 erase_module_structs(Module), 2233 erase_module_domains(Module), 2234 erase_module_pragmas(Module), 2235 erase_deprecation_advice(Module), 2236 erase_meta_predicates(Module), 2237 forget_discontiguous_predicates(Module), 2238 forget_inlined_predicates(Module), 2239 forget_stored_goals(initialization_goals, Module), 2240 forget_stored_goals(finalization_goals, Module), 2241 reset_name_ctr(Module), 2242 2243 % erase information about which files were compiled into Module 2244 forget_module_files(Module). 2245 2246erase_module(Mod, From_mod) :- 2247 check_atom(Mod), 2248 check_module(From_mod), 2249 ( is_a_module(Mod) -> 2250 ( Mod == From_mod -> 2251 set_bip_error(101) 2252 ; is_locked(Mod), From_mod\==sepia_kernel, \+authorized_module(From_mod) -> 2253 % locked modules can only be deleted from sepia_kernel 2254 % (needed only for system cleanup, i.e. erase_modules/0) 2255 set_bip_error(82) 2256 ; 2257 erase_module_unchecked(Mod, From_mod) 2258 ) 2259 ; 2260 true 2261 ), 2262 !. 2263erase_module(Mod, From_mod) :- 2264 get_bip_error(Error), 2265 error(Error, erase_module(Mod), From_mod). 2266 2267 2268% may fail with bip_error set 2269erase_module_unchecked(Mod, From_mod) :- 2270 run_stored_goals(finalization_goals, Mod), 2271 erase_module_attribute_handlers(Mod), 2272 erase_module_(Mod, From_mod), 2273 erase_module_related_records(Mod). 2274 2275 2276% Cleanup: Erase all modules except sepia_kernel, and finalize sepia_kernel. 2277% Because we currently don't keep track of module dependencies, we first 2278% finalize all modules, and then delete them. This should avoid problems 2279% caused by finalizers that assume the existence of other modules. 2280erase_modules :- 2281 module_tag(sepia_kernel, Self), 2282 ( 2283 current_module(Module), Module \== Self, 2284 run_stored_goals(finalization_goals, Module), 2285 erase_module_attribute_handlers(Module), 2286 fail 2287 ; 2288 current_module(Module), Module \== Self, 2289 % erase_module won't run the finalizers again 2290 ( erase_module_unchecked(Module, Self) -> true ; get_bip_error(_) ), 2291 fail 2292 ; 2293 run_stored_goals(finalization_goals, Self) 2294 ). 2295 2296 2297% 2298% get_module_info(+Module, +What, -Info) 2299% Built-in to query the module interface and other properties 2300% 2301 2302get_module_info(Module, What, Info) :- 2303 illegal_existing_module(Module, Error), !, 2304 error(Error, get_module_info(Module, What, Info)). 2305get_module_info(Module, raw_interface, Info) :- 2306 findall(D, raw_interface(Module, D), Info). 2307get_module_info(Module, interface, Info) :- 2308 findall(D, interface_closure(Module, [Module], D), Info). 2309get_module_info(Module, imports, Info) :- 2310 findall(D, recorded_module_import(Module, D), Info). 2311get_module_info(Module, locked, Info) :- 2312 ( is_locked(Module) -> Info=on ; Info=off). 2313% no range check because of get_module_info(+,-,-) mode 2314 2315 raw_interface(Module, (export Pred)) :- 2316 current_module_predicate(exported, Pred, Module). 2317 raw_interface(Module, Directive) :- 2318 recorded_interface_directive(Module, Directive). 2319 2320 2321% 2322% Primitives to enumerate the module interface, expanding 2323% reexports and applying 'from' and 'except' filters: 2324% 2325% interface_closure(+Module, +VisitedModules, -Directive) is nondet 2326% interface_closure_only(+Module, +Preds, +Others, +VisitedModules, -Directive) is nondet 2327% interface_closure_except(+Module, +Preds, +Others, +VisitedModules, -Directive) is nondet 2328% 2329 2330interface_closure(Module, Visited, Directive) :- 2331 interface_closure_preds(Module, Visited, Directive). 2332interface_closure(Module, Visited, Directive) :- 2333 interface_closure_nopreds(Module, Visited, Directive). 2334 2335interface_closure_preds(Module, _, (export Pred)) :- 2336 current_module_predicate(exported_reexported, Pred, Module). 2337 2338interface_closure_nopreds(Module, Visited, Directive) :- 2339 recorded_interface_directive(Module, D), 2340 ( D = (reexport Items from M) -> 2341 nonmember(M, Visited), % prevent looping 2342 split_export_list(Items, _Preds, [], Other, []), 2343 interface_closure_nopreds_only(M, Other, [M|Visited], Directive) 2344 ; D = (reexport M except Except) -> 2345 nonmember(M, Visited), % prevent looping 2346 split_export_list(Except, _Preds, [], Other, []), 2347 interface_closure_nopreds_except(M, Other, [M|Visited], Directive) 2348 ; D = (reexport M) -> 2349 nonmember(M, Visited), % prevent looping 2350 interface_closure_nopreds(M, [M|Visited], Directive) 2351 ; 2352 Directive = D 2353 ). 2354 2355interface_closure_preds_only(_Module, Preds, _Visited, (export Pred)) :- 2356 member(Pred, Preds). 2357% current_module_predicate(exported_reexported, Pred, Module). 2358 2359interface_closure_nopreds_only(Module, Other, Visited, Directive) :- 2360 interface_closure_nopreds(Module, Visited, Directive), 2361 Directive = (export Item), 2362 not nonmember(Item, Other). 2363 2364interface_closure_preds_except(Module, Preds, _Visited, (export Pred)) :- 2365 current_module_predicate(exported_reexported, Pred, Module), 2366 nonmember(Pred, Preds). 2367 2368interface_closure_nopreds_except(Module, Other, Visited, Directive) :- 2369 interface_closure_nopreds(Module, Visited, Directive), 2370 ( Directive = (export Item) -> 2371 nonmember(Item, Other) 2372 ; 2373 true 2374 ). 2375 2376 2377% 2378% Import Module's interface into Where 2379% This only needs to deal with the non-predicate directives, 2380% because the predicate visibility is implemented on a lower level. 2381% 2382 2383import_interface(Module, Where) :- % may fail with bip_error 2384 ( recorded_module_import(Where, Module) -> 2385 true % already imported 2386 ; 2387 ( 2388 interface_closure(Module, [Module], Goal), 2389 ( import_interface_directive(Goal, Module, Where) -> true ; ! ), 2390 fail 2391 ; 2392 true 2393 ), 2394 record_module_import(Module, Where) 2395 ). 2396 2397 2398 % Doesn't have to deal with reexports, they are expanded before 2399 2400 import_interface_directive(export(Items), From, M) :- -?-> !, 2401 import_exported(Items, From, M). 2402 import_interface_directive(global(_), _From, _M) :- -?-> !. 2403 import_interface_directive(use_module(File), _From, M) :- -?-> !, % compatibility 2404 use_module(File)@M. 2405 import_interface_directive(import(From), _From, M) :- -?-> !, % compatibility 2406 import(From)@M. 2407 import_interface_directive((A,B), F, M) :- -?-> !, 2408 import_interface_directive(A, F, M), 2409 import_interface_directive(B, F, M). 2410 import_interface_directive(Goal, _From, _Module) :- 2411 write(error, "Unrecognized interface spec (ignored): "), 2412 write(error, Goal), nl(error). 2413 2414 2415 % Split a comma-list of reexport exceptions into predicates 2416 % and others, and return them in two proper lists 2417 % may fail with bip_error 2418 split_export_list((Except,Excepts), Preds, Preds0, Other, Other0) :- -?-> !, 2419 split_export_list(Except, Preds, Preds1, Other, Other1), 2420 split_export_list(Excepts, Preds1, Preds0, Other1, Other0). 2421 split_export_list(N/A, Preds, Preds0, Other, Other0) :- -?-> !, 2422 check_partial_predspec(N/A), 2423 Preds = [N/A|Preds0], Other = Other0. 2424 split_export_list(Except, Preds, Preds0, Other, Other0) :- 2425 valid_export_spec(Except), !, 2426 Preds = Preds0, Other = [Except|Other0]. 2427 split_export_list(_Except, _Preds, _Preds0, _Other, _Other0) :- 2428 set_bip_error(6). 2429 2430 2431% The compiler calls this for both module/1 and module_interface/1 2432% It erases the module and re-creates it 2433 2434module_directive(New_module, From_module, Exports, Language) :- 2435 ( 2436 check_atom(New_module), 2437 erase_module_unchecked(New_module, From_module) 2438 -> 2439 create_module(New_module, Exports, Language) 2440 ; 2441 bip_error(module(New_module)) 2442 ). 2443 2444module(M):- 2445 error(81, module(M)). 2446 2447get_unqualified_goal(_QM:Goal, UGoal) :- -?-> !, UGoal=Goal. 2448get_unqualified_goal(Goal, Goal). 2449 2450create_module_if_did_not_exist(M, Language) :- 2451 (is_a_module(M) -> true ; create_module(M, [], Language) ). 2452 2453create_module(M) :- 2454 create_module(M, [], eclipse_language). 2455 2456create_module(M, Exports, Language) :- 2457 create_module_(M), 2458 import_body(Language, M), 2459 export_list(Exports, M). 2460 2461set_toplevel_module(M) :- % fails on error with bip_error set 2462 ( var(M) -> 2463 set_bip_error(4) 2464 ; \+atom(M) -> 2465 set_bip_error(5) 2466 ; is_a_module(M) -> 2467 ( is_locked(M) -> set_bip_error(82) ; true ) 2468 ; 2469 error(83, module(M)), 2470 getval(default_language, Language), 2471 create_module(M, [], Language) 2472 ), 2473 default_module(M). % set 2474 2475 2476%----------------------------- 2477 2478prepend_user_path(List0, List) :- 2479 getenv("ECLIPSELIBRARYPATH", Dirs), 2480 !, 2481 open(Dirs, string, Stream), 2482 prepend_user_path(Stream, List0, List). 2483prepend_user_path(List, List). 2484 2485prepend_user_path(S, List0, List) :- 2486 read_string(S, ":", _, Dir) -> 2487 prepend_user_path(S, List0, List1), 2488 List = [Dir|List1] 2489 ; 2490 close(S), 2491 List = List0. 2492 2493 2494stack_overflow_message(global_trail_overflow) :- 2495 write(error, "*** Overflow of the global/trail stack"), 2496 ( get_flag(gc, off) -> 2497 writeln(error, "!"), 2498 writeln(error, "Switch on the garbage collector with \"set_flag(gc,on).\"") 2499 ; 2500 writeln(error, " in spite of garbage collection!") 2501 ), 2502 statistics(global_stack_peak, G), 2503 statistics(trail_stack_peak, T), 2504 ( G+T >= get_flag(max_global_trail) -> 2505 writeln(error, "You can use the \"-g kBytes\" (GLOBALSIZE) option to have a larger stack.") 2506 ; 2507 writeln(error, "You are probably out of virtual memory (swap space).") 2508 ), 2509 GK is G//1024, TK is T//1024, 2510 printf(error, "Peak sizes were: global stack %d kbytes, trail stack %d kbytes%n", 2511 [GK,TK]). 2512stack_overflow_message(local_control_overflow) :- 2513 writeln(error, "*** Overflow of the local/control stack!"), 2514 statistics(local_stack_peak, L), 2515 statistics(control_stack_peak, C), 2516 ( L+C >= get_flag(max_local_control) -> 2517 writeln(error, "You can use the \"-l kBytes\" (LOCALSIZE) option to have a larger stack.") 2518 ; 2519 writeln(error, "You are probably out of virtual memory (swap space).") 2520 ), 2521 LK is L//1024, CK is C//1024, 2522 printf(error, "Peak sizes were: local stack %d kbytes, control stack %d kbytes%n", 2523 [LK,CK]). 2524stack_overflow_message(fatal_signal_caught) :- 2525 write(error, "Segmentation violation - possible reasons are:\n" 2526 "- a faulty external C function\n" 2527 "- certain operations on circular terms\n" 2528 "- machine stack overflow\n" 2529 "- an internal error in ECLiPSe\n" 2530 "ECLiPSe may have become unstable, restart recommended\n" 2531 ), 2532 flush(error). 2533stack_overflow_message(error(IsoError,ImpDefTerm)) :- 2534 nonvar(IsoError), 2535 ( IsoError = syntax_error(Description) -> 2536 print_syntax_error(Description, ImpDefTerm) 2537 ; 2538 ( iso_print_error(IsoError, String, Params) -> 2539 printf(error, String, Params) 2540 ; 2541 printf(error, "Error \"%w\"", [IsoError]) 2542 ), 2543 ( var(ImpDefTerm) -> 2544 nl(error) 2545 ; 2546 output_mode(Mode), 2547 concat_string([" in %", Mode, "w%n"], Format), 2548 printf(error, Format, [ImpDefTerm]) 2549 ), 2550 flush(error) 2551 ). 2552 2553iso_print_error(instantiation_error, "instantiation fault", []). 2554iso_print_error(uninstantiation_error(Actual), "variable expected, found %w", [Actual]). 2555iso_print_error(type_error(Expected,Actual), "type error: expected %w, found %w", [Expected,Actual]). 2556iso_print_error(domain_error(Expected,Actual), "domain error: expected %w, found %w", [Expected,Actual]). 2557iso_print_error(existence_error(ObjectType, Culprit), "%w does not exist: %w", [ObjectType, Culprit]). 2558iso_print_error(permission_error(Operation, PermissionType, Culprit), "permission error during %w of %w: %w", [Operation,PermissionType,Culprit]). 2559iso_print_error(representation_error(Flag), "cannot represent %w", [Flag]). 2560iso_print_error(evaluation_error(Error), "arithmetic exception %w", [Error]). 2561iso_print_error(resource_error(Resource), "resource %w exhausted", [Resource]). 2562iso_print_error(syntax_error(Description), "syntax error: %w", [Description]). 2563iso_print_error(system_error, "unspecified system error", []). 2564 2565 2566is_macro(Type, Pred, List, PredModule, Module) :- 2567 % CAUTION: 12 == TRANS_PROP, 17 == WRITE_CLAUSE_TRANS_PROP 2568 between(12, 17, 1, Prop), 2569 is_macro(Type, Pred, List, PredModule, Module, Prop). 2570 2571current_type(compound). 2572current_type(string). 2573current_type(rational). 2574current_type(breal). 2575current_type(goal). 2576current_type(integer). 2577current_type(float). 2578current_type(atom). 2579current_type(handle). 2580 2581 2582%----------------------------- 2583% autoload declarations 2584%----------------------------- 2585 2586autoload(File, List) :- 2587 autoload(File, List, File, []). 2588 2589autoload_tool(File, List) :- 2590 error(267, autoload_tool(File, List)). 2591 2592autoload_system(File, List) :- 2593 autoload(File, List, File, [system]). 2594 2595 2596autoload(File, Var, Module, _) :- 2597 (var(File) ; var(Var)), 2598 !, 2599 error(4, autoload(File, Var), Module). 2600autoload(File, Procs, Module, Flags) :- 2601 atom(File), 2602 create_module_if_did_not_exist(Module, eclipse_language), 2603 set_procs_flags(Procs, Module, [autoload|Flags]), 2604 !. 2605autoload(File, Nonsense, _, _):- 2606 error(5, autoload(File, Nonsense)). 2607 2608 2609set_procs_flags([], _, _). 2610set_procs_flags([F/A->TF/TA|Rest], Module, Flags) :- !, 2611 export_body(F/A, Module), 2612 tool_(F/A, TF/TA, Module), 2613 set_flags(Flags, F, A, Module), 2614 set_flags(Flags, TF, TA, Module), 2615 set_procs_flags(Rest, Module, Flags). 2616set_procs_flags([F/A|Rest], Module, Flags) :- 2617 export_body(F/A, Module), 2618 set_flags(Flags, F, A, Module), 2619 set_procs_flags(Rest, Module, Flags). 2620 2621set_flags([], _, _, _). 2622set_flags([Flag|Flags], F, A, Module) :- 2623 set_proc_flags(F/A, Flag, on, Module), 2624 set_flags(Flags, F, A, Module). 2625 2626 2627%-------------------------------- 2628% I/O 2629%-------------------------------- 2630 2631tyi(X) :- tyi(input, X). 2632tyo(X) :- tyo(output, X). 2633get_char(X) :- get_char(input, X). 2634put_char(X) :- put_char(output, X). 2635display(X) :- display(output, X). 2636 2637 2638printf_body(Format, List, Module) :- 2639 printf_(output, Format, List, Module, 0'%, ErrF, ErrL, Res), 2640 (Res = 0 -> 2641 true 2642 ; 2643 error(Res, printf(ErrF, ErrL), Module) 2644 ). 2645 2646printf_body(Stream, Format, List, Module) :- 2647 printf_(Stream, Format, List, Module, 0'%, ErrF, ErrL, Res), 2648 (Res = 0 -> 2649 true 2650 ; 2651 error(Res, printf(Stream, ErrF, ErrL), Module) 2652 ). 2653 2654sprintf_(String, Format, List, Module) :- 2655 ( check_var_or_string(String) -> 2656 open(string(""), write, Stream), 2657 printf_(Stream, Format, List, Module, 0'%, ErrF, ErrL, Res), 2658 (Res == 0 -> 2659 get_stream_info(Stream, name, Written), 2660 close(Stream), 2661 String = Written 2662 ; 2663 close(Stream), 2664 error(Res, sprintf(String, ErrF, ErrL), Module) 2665 ) 2666 ; 2667 bip_error(sprintf(String, Format, List), Module) 2668 ). 2669 2670 2671read_token_(Token, Class, Module) :- 2672 read_token_(input, Token, Class, Module). 2673 2674read_string(StreamOrDelString, Length, String) :- 2675 ( string(StreamOrDelString) -> 2676 read_string(input, StreamOrDelString, Length, String) % compatibility 2677 ; StreamOrDelString == end_of_line -> 2678 read_string(input, StreamOrDelString, Length, String) % compatibility 2679 ; StreamOrDelString == end_of_file -> 2680 read_string(input, StreamOrDelString, Length, String) % compatibility 2681 ; 2682 read_string(StreamOrDelString, "", Length, String) % new 2683 ). 2684 2685pathname(Name, Path) :- 2686 pathname(Name, Path, _). 2687 2688pathname(DirBaseSuffix, Dir, Base, Suffix) :- 2689 pathname(DirBaseSuffix, Dir, BaseSuffix), 2690 suffix(BaseSuffix, Suffix), 2691 BaseLen is string_length(BaseSuffix) - string_length(Suffix), 2692 substring(BaseSuffix, 1, BaseLen, Base). 2693 2694writeln_body(X, M) :- writeln_body(output, X, M). 2695 2696nl :- nl(output). 2697 2698compiled_file(File, Line) :- 2699 compiled_stream(Stream), 2700 get_stream_info(Stream, name, File), 2701 get_stream_info(Stream, line, Line). 2702 2703 2704%-------------------------------- 2705% Arithmetic 2706%-------------------------------- 2707 2708% the general evaluation predicate is/2 2709% Note that it is usually optimised away by the compiler 2710 2711is_body(R, X, M) :- 2712 var(X), !, 2713 ( coroutining -> % delay R is X if var(X). 2714 make_suspension(R is X, 0, Susp, M), 2715 insert_suspension(X, Susp, 1 /*inst*/, suspend) 2716 ; 2717 error(4, R is X, M) 2718 ). 2719is_body(R, X, M) :- callable(X), !, eval(X, R, M). 2720is_body(R, X, _) :- number(X), !, R=X. 2721is_body(R, X, M) :- error(24, R is X, M). 2722 2723 2724% eval(X, R, M) - evaluate an arithmetic expression. 2725% 2726% This is used by is/2 and compare_handler/4. 2727% The arithmetic expression X must be syntactically valid, 2728% ie. (number(X) ; compound(X) ; atom(X)). 2729% eval/3 itself does not raise errors. This is done to ensure that 2730% the errors are reported in the builtin that tries to use 2731% the result (to make it consistent with the expanded arithmetic). 2732 2733:- mode eval(?,?,+). 2734 2735eval(X, R, _) :- var(X), !, R=X. 2736eval(X, R, _) :- number(X), !, R=X. 2737eval(eval(X), R, M) :- !, eval(X,R,M). 2738eval(+X, R, M) :- !, eval(X,X1,M), +(X1, R). 2739eval(-X, R, M) :- !, eval(X,X1,M), -(X1, R). 2740eval(abs(X), R, M) :- !, eval(X,X1,M), abs(X1, R). 2741eval(sgn(X), R, M) :- !, eval(X,X1,M), sgn(X1, R). 2742eval(fix(X), R, M) :- !, eval(X,X1,M), fix(X1, R). 2743eval(integer(X), R, M) :- !, eval(X,X1,M), integer(X1, R). 2744eval(rational(X), R, M) :- !, eval(X,X1,M), rational(X1, R). 2745eval(rationalize(X), R, M) :- !, eval(X,X1,M), rationalize(X1, R). 2746eval(numerator(X), R, M) :- !, eval(X,X1,M), numerator(X1, R). 2747eval(denominator(X), R, M) :- !, eval(X,X1,M), denominator(X1, R). 2748eval(float(X), R, M) :- !, eval(X,X1,M), float(X1, R). 2749eval(breal(X), R, M) :- !, eval(X,X1,M), breal(X1, R). 2750eval(breal_from_bounds(L, U), R, M) :- !, eval(L,L1,M), eval(U,U1,M), breal_from_bounds(L1, U1, R). 2751eval(breal_min(X), R, M) :- !, eval(X,X1,M), breal_min(X1, R). 2752eval(breal_max(X), R, M) :- !, eval(X,X1,M), breal_max(X1, R). 2753eval(floor(X), R, M) :- !, eval(X,X1,M), floor(X1, R). 2754eval(ceiling(X), R, M) :- !, eval(X,X1,M), ceiling(X1, R). 2755eval(round(X), R, M) :- !, eval(X,X1,M), round(X1, R). 2756eval(truncate(X), R, M) :- !, eval(X,X1,M), truncate(X1, R). 2757eval(\X, R, M) :- !, eval(X,X1,M), \(X1, R). 2758eval(X + Y, R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), +(X1, Y1, R). 2759eval(X - Y, R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), -(X1, Y1, R). 2760eval(X * Y, R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), *(X1, Y1, R). 2761eval(X / Y, R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), /(X1, Y1, R). 2762eval(X // Y, R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), //(X1, Y1, R). 2763eval(X rem Y, R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), rem(X1, Y1, R). 2764eval(X div Y, R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), div(X1, Y1, R). 2765eval(X mod Y, R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), mod(X1, Y1, R). 2766eval(X ^ Y, R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), ^(X1, Y1, R). 2767eval(min(X,Y), R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), min(X1, Y1, R). 2768eval(max(X,Y), R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), max(X1, Y1, R). 2769eval(gcd(X,Y), R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), gcd(X1, Y1, R). 2770eval(lcm(X,Y), R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), lcm(X1, Y1, R). 2771eval(X /\ Y, R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), /\(X1, Y1, R). 2772eval(X \/ Y, R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), \/(X1, Y1, R). 2773eval(xor(X,Y), R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), xor(X1, Y1, R). 2774eval(X >> Y, R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), >>(X1, Y1, R). 2775eval(X << Y, R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), <<(X1, Y1, R). 2776eval(setbit(X,Y), R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), setbit(X1, Y1, R). 2777eval(getbit(X,Y), R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), getbit(X1, Y1, R). 2778eval(clrbit(X,Y), R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), clrbit(X1, Y1, R). 2779eval(sin(X), R, M) :- !, eval(X,X1,M), sin(X1, R). 2780eval(cos(X), R, M) :- !, eval(X,X1,M), cos(X1, R). 2781eval(tan(X), R, M) :- !, eval(X,X1,M), tan(X1, R). 2782eval(atan(X,Y), R, M) :- !, eval(X,X1,M), eval(Y,Y1,M), atan(X1, Y1, R). 2783eval(asin(X), R, M) :- !, eval(X,X1,M), asin(X1, R). 2784eval(acos(X), R, M) :- !, eval(X,X1,M), acos(X1, R). 2785eval(atan(X), R, M) :- !, eval(X,X1,M), atan(X1, R). 2786eval(exp(X), R, M) :- !, eval(X,X1,M), exp(X1, R). 2787eval(ln(X), R, M) :- !, eval(X,X1,M), ln(X1, R). 2788eval(sqrt(X), R, M) :- !, eval(X,X1,M), sqrt(X1, R). 2789eval(sum(X), R, M) :- !, sum_body(X, R, M). 2790eval(min(X), R, M) :- !, min_body(X, R, M). 2791eval(max(X), R, M) :- !, max_body(X, R, M). 2792eval(pi, R, _) :- !, pi(R). 2793eval(e, R, _) :- !, e(R). 2794eval(LM:X, R, CM) :- !, (evaluating_goal(X, R, CM, LM, Goal) -> 2795 :@(LM,Goal,CM) % same as LM:Goal@CM 2796 ; 2797 R=LM:X). 2798eval(X, R, M) :- evaluating_goal(X, R, M, M, Goal) -> 2799 call(Goal)@M 2800 ; 2801 R=X. 2802 2803:- mode evaluating_goal(?,?,+,+,-). 2804evaluating_goal(X, R, CM, LM, _Goal) :- 2805 var(X), 2806 ( LM == CM -> 2807 error(4, (R is X), CM) % no evaluating predicate 2808 ; 2809 error(4, (R is LM:X), CM) % no evaluating predicate 2810 ). 2811evaluating_goal(X, R, CM, LM, Goal) :- 2812 nonvar(X), 2813 functor(X, F, A), 2814 atom(F), % fails for strings etc. 2815 +(A, 1, A1), % because no inlining yet 2816 functor(Goal, F, A1), 2817 ( is_predicate_(F/A1, LM) -> 2818 unify_args(A, X, Goal), 2819 arg(A1, Goal, R) 2820 ; LM = CM -> 2821 error(21, (R is X), CM) % no evaluating predicate 2822 ; 2823 error(21, (R is LM:X), CM) % no evaluating predicate 2824 ). 2825 2826% unify the first N arguments of two structures 2827 2828:- mode unify_args(+,+,+). 2829 2830unify_args(0, _, _) :- !. 2831unify_args(N, S1, S2) :- 2832 arg(N, S1, Arg), 2833 arg(N, S2, Arg), 2834 -(N, 1, N1), 2835 unify_args(N1, S1, S2). 2836 2837 2838sum_body(X, R, M) :- 2839 sum(X, R, 0, M). 2840 2841sum(X, R, R0, M) :- var(X), !, 2842 ( coroutining -> 2843 make_suspension(sum([R0|X],R), 0, Susp, M), 2844 insert_suspension(X, Susp, 1 /*inst*/, suspend) 2845 ; 2846 error(4, sum(X,R), M) 2847 ). 2848sum([], R, R0, _M) :- !, R=R0. 2849sum([X|Xs], R, R0, M) :- !, 2850 eval(X, R1, M), 2851 +(R0, R1, R2), 2852 sum(Xs, R, R2, M). 2853sum(subscript(Array,Index), R, R0, M) :- !, 2854 subscript(Array, Index, Elems, M), 2855 ( number(Elems) -> +(R0, Elems, R) 2856 ; var(Elems) -> eval(Elems, R1, M), +(R0, R1, R) 2857 ; sum(Elems, R, R0, M) 2858 ). 2859sum(X, R, _R0, M) :- 2860 error(5, sum(X, R), M). 2861 2862 2863% min(+List, ?Min) 2864% max(+List, ?Max) 2865% The type of the result is the most general numeric type of the list elements. 2866% This is compatible with all arithmetic operations. It means that min/max 2867% should be seen as an arithmetic operation, not a list element selection 2868% predicate: the result may not be identical to any of the list elements! 2869 2870/* 2871% simple version without delaying 2872 2873min_body(X, R, M) :- var(X), !, 2874 error(4, min(X,R), M). 2875min_body(subscript(Array,Index), R, M) :- !, 2876 subscript(Array, Index, Elems, M), 2877 ( number(Elems) -> R = Elems 2878 ; var(Elems) -> error(4, min(Elems,R), M) 2879 ; min_body(Elems, R, M) 2880 ). 2881min_body([X1|Xs], R, M) :- 2882 eval(X1, R0, M), 2883 min1(Xs, R, R0, M). 2884min_body(X, R, M) :- 2885 error(5, min(X, R), M). 2886 2887 min1(Xs, R, R0, M) :- var(Xs), !, 2888 error(4, min(Xs,R), M). 2889 min1([], R, R0, _M) :- !, R=R0. 2890 min1([X|Xs], R, R0, M) :- !, 2891 eval(X, R1, M), 2892 min(R0, R1, R2), 2893 min1(Xs, R, R2, M). 2894 min1(Xs, R, _R0, M) :- 2895 error(5, min(Xs, R), M). 2896*/ 2897 2898min_body(X, R, M) :- var(X), !, 2899 ( coroutining -> 2900 make_suspension(min(X,R), 0, Susp, M), 2901 insert_suspension(X, Susp, 1 /*inst*/, suspend) 2902 ; 2903 error(4, min(X,R), M) 2904 ). 2905min_body(subscript(Array,Index), R, M) :- !, 2906 subscript(Array, Index, Elems, M), 2907 ( number(Elems) -> R = Elems 2908 ; var(Elems) -> R is Elems 2909 ; min_body(Elems, R, M) 2910 ). 2911min_body([X1|Xs], R, M) :- !, 2912 ( nonvar(X1) -> 2913 eval(X1, R0, M), 2914 min1(Xs, R, R0, M) 2915 ; coroutining -> 2916 make_suspension(min([X1|Xs],R), 0, Susp, M), 2917 insert_suspension(X1, Susp, 1 /*inst*/, suspend) 2918 ; 2919 error(4, min([X1|Xs],R), M) 2920 ). 2921min_body(X, R, M) :- 2922 error(5, min(X, R), M). 2923 2924 min1(Xs, R, R0, M) :- var(Xs), !, 2925 ( coroutining -> 2926 make_suspension(min([R0|Xs],R), 0, Susp, M), 2927 insert_suspension(Xs, Susp, 1 /*inst*/, suspend) 2928 ; 2929 error(4, min(Xs,R), M) 2930 ). 2931 min1([], R, R0, _M) :- !, R=R0. 2932 min1([X|Xs], R, R0, M) :- !, 2933 % nonvar(R0), 2934 ( nonvar(X) -> 2935 eval(X, R1, M), 2936 min(R0, R1, R2), 2937 min1(Xs, R, R2, M) 2938 ; coroutining -> 2939 make_suspension(min([R0,X|Xs],R), 0, Susp, M), 2940 insert_suspension(X, Susp, 1 /*inst*/, suspend) 2941 ; 2942 error(4, min([X|Xs],R), M) 2943 ). 2944 min1(Xs, R, _R0, M) :- 2945 error(5, min(Xs, R), M). 2946 2947 2948max_body(X, R, M) :- var(X), !, 2949 ( coroutining -> 2950 make_suspension(max(X,R), 0, Susp, M), 2951 insert_suspension(X, Susp, 1 /*inst*/, suspend) 2952 ; 2953 error(4, max(X,R), M) 2954 ). 2955max_body(subscript(Array,Index), R, M) :- !, 2956 subscript(Array, Index, Elems, M), 2957 ( number(Elems) -> R = Elems 2958 ; var(Elems) -> R is Elems 2959 ; max_body(Elems, R, M) 2960 ). 2961max_body([X1|Xs], R, M) :- !, 2962 ( nonvar(X1) -> 2963 eval(X1, R0, M), 2964 max1(Xs, R, R0, M) 2965 ; coroutining -> 2966 make_suspension(max([X1|Xs],R), 0, Susp, M), 2967 insert_suspension(X1, Susp, 1 /*inst*/, suspend) 2968 ; 2969 error(4, max([X1|Xs],R), M) 2970 ). 2971max_body(X, R, M) :- 2972 error(5, max(X, R), M). 2973 2974 max1(Xs, R, R0, M) :- var(Xs), !, 2975 ( coroutining -> 2976 make_suspension(max([R0|Xs],R), 0, Susp, M), 2977 insert_suspension(Xs, Susp, 1 /*inst*/, suspend) 2978 ; 2979 error(4, max(Xs,R), M) 2980 ). 2981 max1([], R, R0, _M) :- !, R=R0. 2982 max1([X|Xs], R, R0, M) :- !, 2983 % nonvar(R0), 2984 ( nonvar(X) -> 2985 eval(X, R1, M), 2986 max(R0, R1, R2), 2987 max1(Xs, R, R2, M) 2988 ; coroutining -> 2989 make_suspension(max([R0,X|Xs],R), 0, Susp, M), 2990 insert_suspension(X, Susp, 1 /*inst*/, suspend) 2991 ; 2992 error(4, max([X|Xs],R), M) 2993 ). 2994 max1(Xs, R, _R0, M) :- 2995 error(5, max(Xs, R), M). 2996 2997 2998/* 2999scalprod(X, Y, R) :- 3000 (number(X);number(Y)) 3001scalprod([X|Xs], [Y|Ys], R) :- 3002 scalprod(X, Xs, Y, Ys, 0, R). 3003 3004scalprod(X, [], Y, [], R, R). 3005scalprod(X0, [X1|Xs], Y0, [Y1|Ys], R0, R) :- 3006 *(X0,Y0,XY), +(R0,XY,R1), 3007 scalprod(X1, Xs, Y1, Ys, R1, R). 3008*/ 3009 3010%------------------------------- 3011% checking utilities 3012%------------------------------- 3013 3014check_predspec(Functor, Module) :- 3015 check_predspec(Functor), 3016 ( is_predicate_(Functor, Module) -> true ; set_bip_error(60) ). 3017 3018check_predspec(X) :- var(X), !, 3019 set_bip_error(4). 3020check_predspec(N/A) :- !, 3021 check_atom(N), 3022 check_arity(A). 3023check_predspec(_) :- 3024 set_bip_error(5). 3025 3026check_partial_predspec(X) :- var(X), !, 3027 set_bip_error(4). 3028check_partial_predspec(N/A) :- !, 3029 check_var_or_atom(N), 3030 check_var_or_arity(A). 3031check_partial_predspec(_) :- 3032 set_bip_error(5). 3033 3034check_var_or_partial_predspec(X) :- var(X), !. 3035check_var_or_partial_predspec(X) :- 3036 check_partial_predspec(X). 3037 3038check_var_or_partial_qual_predspec(X) :- var(X), !. 3039check_var_or_partial_qual_predspec(M:NA) :- !, 3040 check_var_or_atom(M), 3041 check_var_or_partial_predspec(NA). 3042check_var_or_partial_qual_predspec(X) :- 3043 check_partial_predspec(X). 3044 3045check_var_or_partial_macro_spec(X) :- var(X), !. 3046check_var_or_partial_macro_spec(type(Type)) :- !, 3047 check_var_or_type(Type). 3048check_var_or_partial_macro_spec(X) :- 3049 check_partial_predspec(X). 3050 3051check_var_or_atom(X) :- var(X), !. 3052check_var_or_atom(X) :- check_atom(X). 3053 3054check_var_or_integer(X) :- var(X), !. 3055check_var_or_integer(X) :- integer(X), !. 3056check_var_or_integer(_) :- set_bip_error(5). 3057 3058check_var_or_atomic(X) :- var(X), !. 3059check_var_or_atomic(X) :- atomic(X), !. 3060check_var_or_atomic(_) :- set_bip_error(5). 3061 3062check_var_or_arity(A) :- var(A), !. 3063check_var_or_arity(A) :- check_arity(A). 3064 3065check_atom(X) :- var(X), !, set_bip_error(4). 3066check_atom(X) :- atom(X), !. 3067check_atom(_) :- set_bip_error(5). 3068 3069check_functor(X,_,_) :- var(X), !, set_bip_error(4). 3070check_functor(X,N,A) :- functor(X,N,A), !. 3071check_functor(_,_,_) :- set_bip_error(5). 3072 3073check_fieldspecs(X) :- var(X), !, set_bip_error(4). 3074check_fieldspecs(N:_) :- atom(N), !. 3075check_fieldspecs([N:_|More]) :- -?-> atom(N), !, check_fieldspecs(More). 3076check_fieldspecs([]) :- !. 3077check_fieldspecs(_) :- set_bip_error(5). 3078 3079check_nonvar(X) :- var(X), !, set_bip_error(4). 3080check_nonvar(_). 3081 3082check_var(X) :- var(X), !. 3083check_var(_) :- set_bip_error(5). 3084 3085check_arity(A) :- check_integer_ge(A, 0). 3086 3087check_integer_ge(A, _) :- var(A), !, set_bip_error(4). 3088check_integer_ge(A, Min) :- integer(A), !, ( A>=Min -> true ; set_bip_error(6) ). 3089check_integer_ge(_, _) :- set_bip_error(5). 3090 3091check_string(X) :- var(X), !, set_bip_error(4). 3092check_string(X) :- string(X), !. 3093check_string(_) :- set_bip_error(5). 3094 3095check_var_or_atom_string(X) :- var(X), !. 3096check_var_or_atom_string(X) :- check_atom_string(X). 3097 3098check_atom_string(X) :- var(X), !, set_bip_error(4). 3099check_atom_string(X) :- atom(X), !. 3100check_atom_string(X) :- string(X), !. 3101check_atom_string(_) :- set_bip_error(5). 3102 3103% basic_atomic excludes `atomic' types such as handles and suspensions 3104check_basic_atomic(X) :- var(X), !, set_bip_error(4). 3105check_basic_atomic(X) :- atom(X), !. 3106check_basic_atomic(X) :- string(X), !. 3107check_basic_atomic(X) :- number(X), !. 3108check_basic_atomic(_) :- set_bip_error(5). 3109 3110check_var_or_string(X) :- var(X), !. 3111check_var_or_string(X) :- check_string(X). 3112 3113check_compound(X) :- var(X), !, set_bip_error(4). 3114check_compound(X) :- compound(X), !. 3115check_compound(_) :- set_bip_error(5). 3116 3117check_callable(X) :- var(X), !, set_bip_error(4). 3118check_callable(X) :- callable(X), !. 3119check_callable(_) :- set_bip_error(5). 3120 3121check_var_or_type(X) :- var(X), !. 3122check_var_or_type(X) :- 3123 check_atom(X), 3124 ( current_type(X) -> true ; set_bip_error(6) ). 3125 3126check_module(X) :- 3127 check_atom(X), 3128 ( is_a_module(X) -> true ; set_bip_error(80) ). 3129 3130check_var_or_stream_spec(X) :- var(X), !. 3131check_var_or_stream_spec(X) :- check_stream_spec(X). 3132 3133check_var_or_partial_list(X) :- var(X), !. 3134check_var_or_partial_list([]) :- !. 3135check_var_or_partial_list([_|T]) :- !, 3136 check_var_or_partial_list(T). 3137check_var_or_partial_list(_) :- 3138 set_bip_error(5). 3139 3140check_proper_list(X) :- var(X), !, set_bip_error(4). 3141check_proper_list([]) :- !. 3142check_proper_list([_|T]) :- !, 3143 check_proper_list(T). 3144check_proper_list(_) :- 3145 set_bip_error(5). 3146 3147 3148:- mode illegal_module(?, -). 3149illegal_module(Module, 4) :- 3150 var(Module). 3151illegal_module(Module, 5) :- 3152 nonvar(Module), 3153 \+atom(Module). 3154 3155% illegal_or_nonexisting_module 3156:- mode illegal_existing_module(?, -). 3157illegal_existing_module(Module, 4) :- 3158 var(Module). 3159illegal_existing_module(Module, 5) :- 3160 nonvar(Module), 3161 not atom(Module). 3162illegal_existing_module(Module, 80) :- 3163 atom(Module), 3164 \+is_a_module(Module). 3165 3166% illegal_or_nonexisting_or_locked_module 3167:- mode illegal_unlocked_module(?, -). 3168illegal_unlocked_module(Module, 4) :- 3169 var(Module). 3170illegal_unlocked_module(Module, 5) :- 3171 nonvar(Module), 3172 not atom(Module). 3173illegal_unlocked_module(Module, 80) :- 3174 atom(Module), 3175 \+is_a_module(Module). 3176illegal_unlocked_module(Module, 82) :- 3177 atom(Module), 3178 \+authorized_module(Module). 3179 3180 3181%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 3182% 3183% the local declaration 3184% 3185 3186 3187:- tool((local)/1, local_body/2). 3188 3189local_body(X, M) :- 3190 var(X), !, 3191 error(4, local(X), M). 3192local_body((X,Y), M):- !, 3193 local_body(X, M), 3194 local_body(Y, M). 3195local_body(domain(S), M) :- 3196 define_domain(S, M, local), !. 3197local_body(record(Key), M) :- !, 3198 local_record_body(Key, M). 3199local_body(store(Key), M) :- 3200 store_create_named_(Key, M), !. 3201local_body(shelf(Name,Init), M) :- 3202 check_compound(Init), 3203 shelf_create(Init, Handle), 3204 shelf_name(Name, Handle, M), !. 3205local_body(struct(S), M) :- 3206 define_struct(S, M, local), !. 3207local_body(reference(Name,Init), M) :- 3208 check_atom(Name), 3209 make_array_(Name, reference(Init), local, M), !. 3210local_body(reference(Name), M) :- 3211 check_atom(Name), 3212 make_array_(Name, global_reference, local, M), !. 3213local_body(variable(Name), M) :- 3214 check_atom(Name), 3215 make_array_(Name, prolog, local, M), !. 3216local_body(variable(Name,Init), M) :- 3217 check_atom(Name), 3218 make_array_(Name, prolog, local, M), !, 3219 setval(Name, Init)@M. 3220local_body(array(Name), M) :- 3221 check_compound(Name), 3222 make_array_(Name, prolog, local, M), !. 3223local_body(array(Name,Type), M) :- 3224 check_compound(Name), 3225 make_array_(Name, Type, local, M), !. 3226local_body(op(Pred,Assoc,Name), M) :- 3227 local_op_body(Pred, Assoc, Name, M), !. 3228local_body(macro(Functor,Trans,Options), M) :- !, 3229 define_macro_(Functor, Trans, [local|Options], M). 3230local_body(portray(Functor,Trans,Options), M) :- !, 3231 define_macro_(Functor, Trans, [local,write|Options], M). 3232local_body(chtab(Char,Class), M) :- !, 3233 set_chtab_(Char, Class, M). 3234local_body(syntax_option(Option), M) :- !, 3235 set_flag_body(syntax_option, Option, M). 3236local_body(initialization(Goal), M) :- 3237 store_goals(initialization_goals, Goal, M), !. 3238local_body(finalization(Goal), M) :- 3239 store_goals(finalization_goals, Goal, M), !. 3240local_body(X, M) :- X = _/_, 3241 local_(X, M), !. 3242local_body(X, _M) :- 3243 \+ valid_local_spec(X), 3244 set_bip_error(5). 3245local_body(X, M) :- 3246 bip_error(local(X), M). 3247 3248 :- mode valid_local_spec(+). 3249 valid_local_spec(domain(_)). 3250 valid_local_spec(record(_)). 3251 valid_local_spec(shelf(_,_)). 3252 valid_local_spec(store(_)). 3253 valid_local_spec(struct(_)). 3254 valid_local_spec(reference(_)). 3255 valid_local_spec(variable(_)). 3256 valid_local_spec(variable(_,_)). 3257 valid_local_spec(array(_)). 3258 valid_local_spec(array(_,_)). 3259 valid_local_spec(op(_,_,_)). 3260 valid_local_spec(macro(_,_,_)). 3261 valid_local_spec(portray(_,_,_)). 3262 valid_local_spec(chtab(_,_)). 3263 valid_local_spec(syntax_option(_)). 3264 valid_local_spec(initialization(_)). 3265 valid_local_spec(_/_). 3266 3267% 3268% the global declaration 3269% 3270 3271:- tool((global)/1, global_body/2). 3272 3273global_body(X, M) :- var(X), !, 3274 error(4, global(X), M). 3275global_body((X,Y), M):- !, 3276 global_body(X, M), 3277 global_body(Y, M). 3278global_body(X, M):- 3279 valid_global_spec(X), !, 3280 record_interface_directive(global(X), M), 3281 global_item(X, M). 3282global_body(X, M) :- 3283 error(5, global(X), M). 3284 3285global_item(record(Key), M) :- !, 3286 global_record_body(Key, M). 3287global_item(struct(S), M) :- 3288 define_struct(S, M, export), !. 3289global_item(reference(Name), M) :- 3290 make_array_(Name, global_reference, global, M), !. 3291global_item(variable(Name), M) :- 3292 ( atom(Name) -> true ; var(Name) -> set_bip_error(4) ; set_bip_error(5) ), 3293 make_array_(Name, prolog, global, M), !. 3294global_item(array(Name), M) :- 3295 make_array_(Name, prolog, global, M), !. 3296global_item(array(Name,Type), M) :- 3297 make_array_(Name, Type, global, M), !. 3298global_item(op(Pred,Assoc,Name), M) :- 3299 global_op_body(Pred, Assoc, Name, M), !. 3300global_item(macro(Functor,Trans,Options), M) :- !, 3301 define_macro_(Functor, Trans, [global|Options], M). 3302global_item(portray(Functor,Trans,Options), M) :- !, 3303 define_macro_(Functor, Trans, [global,write|Options], M). 3304global_item(meta_attribute(Name,Handlers), M) :- !, 3305 meta_attribute_body(Name, Handlers, M). 3306global_item(X, M) :- X = _/_, 3307 printf(warning_output, "WARNING: Global predicates no longer supported%n", []), 3308 printf(warning_output, " (using export instead): %w%n", [global(X)@M]), 3309 export_(X, M), !. 3310global_item(X, M) :- 3311 bip_error(global(X), M). 3312 3313 :- mode valid_global_spec(+). 3314 valid_global_spec(record(_)). 3315 valid_global_spec(struct(_)). 3316 valid_global_spec(reference(_)). 3317 valid_global_spec(variable(_)). 3318 valid_global_spec(array(_)). 3319 valid_global_spec(array(_,_)). 3320 valid_global_spec(op(_,_,_)). 3321 valid_global_spec(macro(_,_,_)). 3322 valid_global_spec(portray(_,_,_)). 3323 valid_global_spec(meta_attribute(_,_)). 3324 valid_global_spec(_/_). 3325 3326% 3327% the export declaration 3328% 3329 3330:- tool((export)/1, export_body/2). 3331 3332export_body(X, M) :- var(X), !, 3333 error(4, export(X), M). 3334export_body((X,Y), M):- !, 3335 export_body(X, M), 3336 export_body(Y, M). 3337export_body(X, M):- 3338 valid_export_spec(X), !, 3339 record_interface_directive(export(X), M), 3340 export_item(X, M). 3341export_body(X, M) :- 3342 error(5, export(X), M). 3343 3344export_list(X, M) :- var(X), !, 3345 error(4, export(X), M). 3346export_list([], _M) :- !. 3347export_list([X|Xs], M):- !, 3348 ( valid_export_spec(X) -> 3349 record_interface_directive(export(X), M), 3350 export_item(X, M), 3351 export_list(Xs, M) 3352 ; 3353 error(5, export(X), M) 3354 ). 3355export_list(X, M) :- 3356 error(5, export(X), M). 3357 3358export_item(domain(S), M) :- 3359 define_domain(S, M, export), !. 3360export_item(struct(S), M) :- 3361 define_struct(S, M, export), !. 3362export_item(op(Pred,Assoc,Name), M) :- 3363 local_op_body(Pred, Assoc, Name, M), !. 3364export_item(macro(Functor,Trans,Options), M) :- !, 3365 define_macro_(Functor, Trans, [local|Options], M). 3366export_item(portray(Functor,Trans,Options), M) :- !, 3367 define_macro_(Functor, Trans, [local,write|Options], M). 3368export_item(chtab(Char,Class), M) :- !, 3369 set_chtab_(Char, Class, M). 3370export_item(syntax_option(Option), M) :- !, 3371 set_flag_body(syntax_option, Option, M). 3372export_item(initialization(_Goal), _M) :- !. 3373 % Not called, since typically it is not desirable to call 3374 % the same goal for local and import initialization. 3375export_item(X, M) :- X = _/_, 3376 export_(X, M), !. 3377export_item(X, M) :- 3378 bip_error(export(X), M). 3379 3380 valid_export_spec(X) :- var(X), !, fail. 3381 valid_export_spec(domain(_)). 3382 valid_export_spec(struct(_)). 3383 valid_export_spec(op(_,_,_)). 3384 valid_export_spec(macro(_,_,_)). 3385 valid_export_spec(portray(_,_,_)). 3386 valid_export_spec(chtab(_,_)). 3387 valid_export_spec(syntax_option(_)). 3388 valid_export_spec(initialization(_)). 3389 valid_export_spec(_/_). 3390 3391 3392% import_exported/3 is applied to export-declarations in module interfaces 3393 3394import_exported(X, Mi, M) :- 3395 var(X), !, 3396 error(4, import(from(X, Mi)), M). 3397import_exported(domain(S), Mi, M) :- 3398 import_domain(S, Mi, M), !. 3399import_exported(struct(S), Mi, M) :- 3400 import_struct(S, Mi, M), !. 3401import_exported(op(Pred,Assoc,Name), _Mi, M) :- 3402 local_op_body(Pred, Assoc, Name, M), !. 3403import_exported(macro(Functor,Trans,Options), _Mi, M) :- 3404 define_macro_(Functor, Trans, [local|Options], M). 3405import_exported(portray(Functor,Trans,Options), _Mi, M) :- 3406 define_macro_(Functor, Trans, [local,write|Options], M). 3407import_exported(chtab(Char,Class), _Mi, M) :- !, 3408 set_chtab_(Char, Class, M). 3409import_exported(syntax_option(Option), _Mi, M) :- !, 3410 set_flag_body(syntax_option, Option, M). 3411import_exported(initialization(Goal), _Mi, M) :- !, 3412 run_list_of_goals([Goal], M). 3413import_exported(X, _Mi, _M) :- X = _/_, !. 3414import_exported(X, _Mi, _M) :- 3415 \+ valid_export_spec(X), 3416 set_bip_error(5). 3417import_exported(X, Mi, M) :- 3418 bip_error(import(from(X, Mi)), M). 3419 3420 3421% 3422% the reexport declaration 3423% 3424 3425:- tool((reexport)/1, reexport_body/2). 3426 3427reexport_body(X, M) :- var(X), !, 3428 error(4, reexport(X), M). 3429reexport_body(Things from Module, M) :- 3430 record_interface_directive(reexport(Things from Module), M), 3431 check_module_or_load_library(Module, M), 3432 reexport_only(Module, M, Things), 3433 !. 3434reexport_body(Module except Except, M) :- 3435 record_interface_directive(reexport(Module except Except), M), 3436 check_module_or_load_library(Module, M), 3437 reexport_except(Module, M, Except), 3438 !. 3439reexport_body(Module, M):- 3440 Module \= (_ except _), 3441 Module \= (_ from _), 3442 record_interface_directive(reexport(Module), M), 3443 check_module_or_load_library(Module, M), 3444 reexport_all(Module, M), 3445 !. 3446reexport_body(Any, M):- 3447 bip_error(reexport(Any), M). 3448 3449 reexport_only(Module, Where, Things) :- 3450 split_export_list(Things, Preds, [], Other, []), 3451 ( 3452 member(Pred, Preds), 3453 ( reexport_from_(Module, Pred, Where) -> 3454 fail ; !, fail % error as pred. list is explicit 3455 ) 3456 ; 3457 interface_closure_nopreds_only(Module, Other, [Module], Goal), 3458 ( import_interface_directive(Goal, Module, Where) -> 3459 fail ; !, fail 3460 ) 3461 ; 3462 true 3463 ). 3464 3465 3466 reexport_except(Module, Where, Except) :- 3467 split_export_list(Except, Preds, [], Other, []), 3468 ( 3469 interface_closure_preds_except(Module, Preds, [Module], (export Pred)), 3470 ( reexport_from_(Module, Pred, Where) -> 3471 fail ; reexport_error_warning(Module, Pred, Where), fail 3472 ) 3473 ; 3474 interface_closure_nopreds_except(Module, Other, [Module], Goal), 3475 ( import_interface_directive(Goal, Module, Where) -> 3476 fail ; reexport_error_warning(Module, Goal, Where), fail 3477 ) 3478 ; 3479 true 3480 ). 3481 3482 3483 reexport_all(Module, Where) :- 3484 ( 3485 interface_closure_preds(Module, [Module], (export Pred)), 3486 ( reexport_from_(Module, Pred, Where) -> 3487 fail ; reexport_error_warning(Module, Pred, Where), fail 3488 ) 3489 ; 3490 interface_closure_nopreds(Module, [Module], Goal), 3491 ( import_interface_directive(Goal, Module, Where) -> 3492 fail ; reexport_error_warning(Module, Goal, Where), fail 3493 ) 3494 ; 3495 true 3496 ). 3497 3498 reexport_error_warning(Module, Pred, Where) :- 3499 get_bip_error(ErrorId), 3500 error_id(ErrorId, ErrorMsg), 3501 write(warning_output, "WARNING: "), 3502 write(warning_output, ErrorMsg), 3503 write(warning_output, " in reexport "), 3504 write(warning_output, Pred)@Where, 3505 write(warning_output, " from "), 3506 write(warning_output, Module), 3507 write(warning_output, " in module "), 3508 write(warning_output, Where), 3509 nl(warning_output). 3510 3511% 3512% the import declaration 3513% 3514 3515:- tool((import)/1, import_body/2). 3516 3517import_body(X, M) :- 3518 var(X), !, 3519 error(4, import(X), M). 3520import_body(from(X, Mi), M) :- !, 3521 import_from_body(Mi, X, M). 3522import_body(X, M):- 3523 import_module_list(X, M). 3524 3525 import_module_list(X, M) :- var(X), !, 3526 error(4, import(X), M). 3527 import_module_list([], _M) :- !. 3528 import_module_list([X|Xs], M) :- !, 3529 import_module_body(X, M), 3530 import_module_list(Xs, M). 3531 import_module_list(X, M) :- 3532 import_module_body(X, M). 3533 3534 import_module_body(LibMod, M) :- 3535 ( check_module_or_load_library(LibMod, M) -> 3536 ( LibMod == M -> 3537 true % don't import into yourself 3538 ; import_(LibMod, M), import_interface(LibMod, M) -> 3539 true 3540 ; 3541 bip_error(import(LibMod), M) 3542 ) 3543 ; 3544 bip_error(import(LibMod), M) 3545 ). 3546 3547 import_from_body(Mi, (X, Y), M) :- -?-> !, 3548 import_from_body(Mi, X, M), 3549 import_from_body(Mi, Y, M). 3550 import_from_body(Mi, X, M) :- 3551 ( import_from_(Mi, X, M) -> 3552 true 3553 ; 3554 bip_error(import(from(X, Mi)), M) 3555 ). 3556 3557 3558 3559% 3560% Various predicate property declarations 3561% They all implicitly create the predicate if it doesn't exist 3562% 3563 3564:- tool((traceable)/1, traceable_body/2). 3565traceable_body(PredSpec, Module) :- 3566 declaration(PredSpec, leash, stop, Module), !. 3567traceable_body(PredSpec, Module) :- 3568 bip_error(traceable(PredSpec), Module). 3569 3570:- tool((untraceable)/1, untraceable_body/2). 3571untraceable_body(PredSpec, Module) :- 3572 declaration(PredSpec, leash, notrace, Module), !. 3573untraceable_body(PredSpec, Module) :- 3574 bip_error(untraceable(PredSpec), Module). 3575 3576:- tool((skipped)/1, skipped_body/2). 3577skipped_body(PredSpec, Module) :- 3578 declaration(PredSpec, skip, on, Module), !. 3579skipped_body(PredSpec, Module) :- 3580 bip_error(skipped(PredSpec), Module). 3581 3582:- tool((unskipped)/1, unskipped_body/2). 3583unskipped_body(PredSpec, Module) :- 3584 declaration(PredSpec, skip, off, Module), !. 3585unskipped_body(PredSpec, Module) :- 3586 bip_error(unskipped(PredSpec), Module). 3587 3588:- tool((parallel)/1, parallel_body/2). 3589parallel_body(PredSpec, Module) :- 3590 declaration(PredSpec, parallel, on, Module), !. 3591parallel_body(PredSpec, Module) :- 3592 bip_error(parallel(PredSpec), Module). 3593 3594:- tool((demon)/1, demon_body/2). 3595demon_body(PredSpec, Module) :- 3596 declaration(PredSpec, demon, on, Module), !. 3597demon_body(PredSpec, Module) :- 3598 bip_error(demon(PredSpec), Module). 3599 3600% comment declares the predicate so you get 3601% a warning if you don't define it 3602:- tool(comment/2, comment_body/3). 3603comment_body(N/A, C, Module) :- -?-> !, 3604 ( 3605 check_predspec(N/A), 3606 ( get_flag_body(N/A, visibility, _Any, Module) -> 3607 true % already declared 3608 ; 3609 local_(N/A, Module) 3610 ) 3611 -> 3612 true 3613 ; 3614 bip_error(comment(N/A, C), Module) 3615 ). 3616comment_body(_,_,_). 3617 3618 3619 declaration(PredSpec, _Flag, _Value, _Module) :- 3620 var(PredSpec), !, 3621 set_bip_error(4). 3622 declaration((A,B), Flag, Value, Module) :- !, 3623 declaration(A, Flag, Value, Module), 3624 declaration(B, Flag, Value, Module). 3625 declaration(PredSpec, Flag, Value, M) :- 3626 check_predspec(PredSpec), 3627 ( get_flag_body(PredSpec, definition_module, M, M) -> 3628 true 3629 ; 3630 local_(PredSpec, M) % may fail with bip_error 3631 ), 3632 set_proc_flags(PredSpec, Flag, Value, M). % may fail with bip_error 3633 3634 3635% 3636% deprecated/2 declaration 3637% 3638 3639:- store_create_named(deprecation_advice). 3640 3641:- export deprecated/2. 3642:- tool(deprecated/2, deprecated_body/3). 3643deprecated_body(PredSpec, Advice, Module) :- 3644 check_predspec(PredSpec), 3645 check_string(Advice), 3646 ( get_flag_body(PredSpec, definition_module, Module, Module) -> 3647 true % already declared 3648 ; 3649 local_(PredSpec, Module) 3650 ), 3651 !, 3652 set_flag_body(PredSpec, deprecated, on, Module), 3653 store_set(deprecation_advice, Module:PredSpec, Advice). 3654deprecated_body(PredSpec, Advice, Module) :- 3655 bip_error(deprecated(PredSpec, Advice), Module). 3656 3657 3658get_deprecation_advice(PredSpec, Module, Advice) :- 3659 store_get(deprecation_advice, Module:PredSpec, Advice). 3660 3661 3662erase_deprecation_advice(Module) :- 3663 store_erase_qualified(deprecation_advice, Module). 3664 3665 3666% 3667% get_flag/3 3668% 3669 3670get_flag_body(Proc, Flag, Value, Module) :- 3671 check_predspec(Proc), 3672 check_var_or_atom(Flag), 3673 %check_var_or_flag_value(Flag), 3674 !, 3675 pri_flag_code(Flag, Code), 3676 ( integer(Code), 3677 proc_flags(Proc, Code, Value, Module) 3678 ; atom(Code), 3679 proc_flags(Proc, 0/*definition_module*/, DM, Module), 3680 store_get(Code, DM:Proc, Value) 3681 ). 3682get_flag_body(Proc, Flag, Value, Module) :- 3683 bip_error(get_flag(Proc, Flag, Value), Module). 3684 3685proc_flags(P, C, V, M) :- 3686 local_proc_flags(P, C, V, M, G), 3687 G = global. 3688 3689 3690% The numbers here have to match those in local_proc_flags/5 in bip_db.c 3691 3692pri_flag_code(mode, 6). % name and visibility 3693pri_flag_code(meta_predicate, meta_predicate). 3694pri_flag_code(visibility, 23). 3695pri_flag_code(definition_module, 0). 3696pri_flag_code(declared, 12). 3697pri_flag_code(defined, 14). 3698 3699pri_flag_code(autoload, 13). % various flags, alphabetic 3700pri_flag_code(auxiliary, 9). 3701pri_flag_code(call_type, 10). 3702pri_flag_code(demon, 25). 3703pri_flag_code(deprecated, 16). 3704pri_flag_code(inline, 8). 3705pri_flag_code(invisible, 27). 3706pri_flag_code(parallel, 26). 3707pri_flag_code(priority, 24). 3708pri_flag_code(run_priority, 34). 3709pri_flag_code(stability, 20). 3710pri_flag_code(tool, 21). 3711pri_flag_code(type, 22). 3712 3713pri_flag_code(debugged, 11). % debugging-related, almost alphabetic 3714pri_flag_code(leash, 15). 3715pri_flag_code(skip, 17). 3716pri_flag_code(spy, 18). 3717pri_flag_code(start_tracing, 19). 3718pri_flag_code(source_file, 3). 3719pri_flag_code(source_line, 4). 3720pri_flag_code(source_offset, 5). 3721pri_flag_code(port_calls, 32). 3722pri_flag_code(port_lines, 31). 3723pri_flag_code(break_lines, 30). 3724 3725pri_flag_code(code_size, 29). % statistics 3726 3727 3728check_var_or_flag_value(X) :- var(X), !. 3729check_var_or_flag_value(X) :- integer(X), !. 3730check_var_or_flag_value(X) :- atom(X), !. 3731check_var_or_flag_value(X) :- compound(X), !. 3732check_var_or_flag_value(_) :- set_bip_error(5). 3733 3734 3735% 3736% set_flag/3 3737% 3738 3739set_flag_body([], _Name, _Value, _Module) :- !. 3740set_flag_body([Proc|Procs], Name, Value, Module) :- 3741 !, 3742 set_flag_body(Proc, Name, Value, Module), 3743 set_flag_body(Procs, Name, Value, Module). 3744set_flag_body(Proc, Name, Value, Module) :- 3745 (do_set_flag(Proc, Name, Value, Module) -> 3746 true 3747 ; 3748 bip_error(set_flag(Proc, Name,Value), Module) 3749 ). 3750 3751do_set_flag(_, Flag, _, _) :- var(Flag), !, set_bip_error(4). 3752do_set_flag(_, definition_module, _, _) :- !, set_bip_error(30). %readonly 3753do_set_flag(_, visibility, _, _) :- !, set_bip_error(30). 3754do_set_flag(_, tool, _, _) :- !, set_bip_error(30). 3755do_set_flag(_, call_type, _, _) :- !, set_bip_error(30). 3756do_set_flag(_, mode, _, _) :- !, set_bip_error(30). 3757do_set_flag(_, debugged, _, _) :- !, set_bip_error(30). 3758do_set_flag(_, defined, _, _) :- !, set_bip_error(30). 3759do_set_flag(_, declared, _, _) :- !, set_bip_error(30). 3760do_set_flag(_, type, user, _) :- !, set_bip_error(30). % allow setting to built_in 3761do_set_flag(_, invisible, _, Module) :- 3762 Module \== sepia_kernel, !, 3763 set_bip_error(30). 3764do_set_flag(_, debug, _, _) :- !, 3765 set_bip_error(6). % to protect set_proc_flags/4 below 3766do_set_flag(_, system, _, _) :- !, 3767 set_bip_error(6). % to protect set_proc_flags/4 below 3768do_set_flag(_, break, _, _) :- !, 3769 set_bip_error(6). % to protect set_proc_flags/4 below 3770do_set_flag(Proc, inline, Trans, Module) :- !, 3771 define_macro_(Proc, Trans, [goal], Module). 3772do_set_flag(Proc, Flag, Value, Module) :- 3773 set_proc_flags(Proc, Flag, Value, Module). 3774 3775 3776 3777/****** Tool declarations *******/ 3778 3779:- 3780 tool(abolish_record/1, abolish_record_body/2), 3781 tool((:)/2, '[]:@'/3), 3782 tool(call_boxed/5, call_boxed_/6), 3783 tool(call_boxed/6, call_boxed_/7), 3784 tool(call_explicit/2, call_explicit_body/3), 3785 tool('.'/2, compile_list_body/3), 3786 tool(define_macro/3, define_macro_/4), 3787 tool(erase_array/1, erase_array_body/2), 3788 tool(erase_macro/1, erase_macro_/2), 3789 tool(erase_macro/2, erase_macro_/3), 3790 tool(eval/2, eval/3), 3791 tool(exec_string/2, exec_string/3), 3792 tool(exec_exdr/1, exec_exdr/2), 3793 tool(external/2, external_/3), 3794 tool(expand_clause/2, expand_clause_/3), 3795 tool(expand_goal/2, expand_goal/3), 3796 tool(expand_goal_annotated/4, expand_goal_annotated_/5), 3797 tool(expand_macros/2, expand_macros_/3), 3798 tool(expand_macros_annotated/4, expand_macros_annotated_/5), 3799 tool(expand_clause_annotated/4, expand_clause_annotated_/5), 3800 tool(b_external/2, b_external_/3), 3801 tool(external/1, external_body/2), 3802 tool(b_external/1, b_external_body/2), 3803 tool(inline/2, inline_/3), 3804 tool(inline/1, inline_/2), 3805 tool(insert_suspension/3, insert_suspension/4), 3806 tool(add_attribute/2, add_attribute/3), 3807 tool(get_attribute/2, get_attribute/3), 3808 tool(get_attributes/3, get_attributes/4), 3809 tool(replace_attribute/2, replace_attribute/3), 3810 tool(tool_body/3, tool_body_/4), 3811 tool(lib/1, lib_/2), 3812 tool(make_suspension/3, make_suspension/4), 3813 tool(max/2, max_body/3), 3814 tool(min/2, min_body/3), 3815 tool(current_module_predicate/2, current_module_predicate/3), 3816 tool(remote_connect/3, remote_connect/4), 3817 tool(remote_connect_accept/6, remote_connect_accept/7), 3818 tool(print/1, print_/2), 3819 tool(print/2, print_/3), 3820 tool(read_token/3, read_token_/4), 3821 tool(set_proc_flags/3, set_proc_flags/4), 3822 tool(sum/2, sum_body/3), 3823 tool(subscript/3, subscript/4). 3824 3825 3826/****** export declarations *******/ 3827 3828 3829:- export % undocumented exports 3830 record_discontiguous_predicate/4, 3831 record_inline_source/4, 3832 collect_discontiguous_predicates/2, 3833 valid_signature/2, 3834 reset/0, 3835 printf_with_current_modes/2, 3836 proc_flags/4, 3837 sepia_version_banner/2, 3838 tr_match/4, 3839 trprotect/2, 3840 trdcg/5, 3841 call_local/1, 3842 check_callable/1, 3843 check_predspec/1, 3844 erase_module_pragmas/1, 3845 exec_exdr/1, 3846 exec_string/2, 3847 expand_clause_annotated/4, 3848 expand_goal_annotated/4, 3849 expand_macros_annotated/4, 3850 extension/1, 3851 replace_attribute/2, 3852 get_pager/1, 3853 illegal_macro/5, 3854 more/1, 3855 prof_predicate_list/3, 3856 sepiadir/1, 3857 tr_goals/3. 3858 3859:- export % exports for lib(lists) 3860 append/3, 3861 delete/3, 3862 length/2, 3863 member/2, 3864 memberchk/2, 3865 nonmember/2, 3866 subtract/3, 3867 reverse/2. 3868 3869:- export % built-ins 3870 (@)/2, 3871 (:)/2, 3872 (*->)/2, 3873 '.'/2, 3874 (\=)/2, 3875 'C'/3, 3876 !/0, 3877 (\+)/1, 3878 (?-)/2, 3879 (-->)/2, 3880 abort/0, 3881 abolish_record/1, 3882 add_attribute/2, 3883 add_attribute/3, 3884 autoload/2, 3885 autoload_tool/2, 3886 autoload_system/2, 3887 b_external/1, 3888 b_external/2, 3889 between/4, 3890 block/3, 3891 block_atomic/3, 3892 bytes_to_term/2, 3893 call/1, 3894 call/2, 3895 call_boxed/5, 3896 call_boxed/6, 3897 call_explicit/2, 3898 call_priority/2, 3899 cancel_after_event/1, 3900 cancel_after_event/2, 3901 canonical_path_name/2, 3902 close_embed_queue_eclipseside/2, 3903 comment/2, 3904 compiled_stream/1, 3905 coroutine/0, 3906 create_module/1, 3907 create_module/3, 3908 current_error/1, 3909 current_pragma/1, 3910 current_after_event/1, 3911 current_after_events/1, 3912 current_interrupt/2, 3913 current_record/1, 3914 current_suspension/1, 3915 debug/1, 3916 decval/1, 3917 define_macro/3, 3918 (delay)/1, 3919 (demon)/1, 3920 discontiguous/1, 3921 display/1, 3922 e/1, 3923 ecl_create_embed_queue/3, 3924 ensure_loaded/1, 3925 error/2, 3926 error/3, 3927 erase/2, 3928 erase_all/1, 3929 erase_all/2, 3930 erase_array/1, 3931 erase_macro/1, 3932 erase_macro/2, 3933 erase_module/1, 3934 event/1, 3935 exit/1, 3936 exists/1, 3937 existing_file/4, 3938 expand_clause/2, 3939 expand_goal/2, 3940 expand_macros/2, 3941 (export)/1, 3942 external/1, 3943 external/2, 3944 eval/2, 3945 event_after/2, 3946 event_after/3, 3947 event_after_every/2, 3948 events_after/1, 3949 event_create/2, 3950 event_retrieve/2, 3951 event_retrieve/3, 3952 fail_if/1, 3953 false/0, 3954 flatten_array/2, 3955 get_attribute/2, 3956 get_char/1, 3957 get_chtab/2, 3958 get_error_handler/3, 3959 get_event_handler/3, 3960 get_flag/3, 3961 get_interrupt_handler/3, 3962 get_module_info/3, 3963% get_statistics/2, 3964 getval/2, 3965 (global)/1, 3966% set_statistics/2, 3967 halt/0, 3968 (help)/0, 3969 (import)/1, 3970 incval/1, 3971 insert_suspension/3, 3972 inline/1, 3973 inline/2, 3974 (is)/2, 3975 is_predicate/1, 3976 kill_suspension/1, 3977 lib/1, 3978 lib/2, 3979 load_eco/2, 3980 (local)/1, 3981 local_record/1, 3982 lock/0, 3983 lock_pass/1, 3984 make_suspension/3, 3985 make_suspension/4, 3986 max/2, 3987 min/2, 3988 (mode)/1, 3989 module/1, 3990 mutex/2, 3991 mutex_init/1, 3992 mutex_one/2, 3993 nl/0, 3994 new_socket_server/3, 3995 (not)/1, 3996 (once)/1, 3997 (parallel)/1, 3998% par_all/2, 3999% par_findall/4, 4000% par_once/2, 4001 pathname/2, 4002 pathname/4, 4003 pi/1, 4004 print/1, 4005 print/2, 4006 printf/2, 4007 printf/3, 4008 sprintf/3, 4009 put_char/1, 4010 read/1, 4011 read/2, 4012 read_string/3, 4013 read_token/2, 4014 readvar/3, 4015 recorda/2, 4016 recorda/3, 4017 recorded/2, 4018 recorded/3, 4019 recordedchk/2, 4020 recordedchk/3, 4021 recorded_list/2, 4022 record/2, 4023 recordz/2, 4024 recordz/3, 4025 rerecord/2, 4026 (reexport)/1, 4027 reset_error_handlers/0, 4028 read_token/3, 4029 remote_yield/1, 4030 remote_connect/3, 4031 remote_connect_setup/3, 4032 remote_connect_accept/6, 4033 remote_disconnect/1, 4034 set_chtab/2, 4035 set_default_error_handler/2, 4036 set_flag/3, 4037 set_embed_peer/2, 4038 set_error_handler/2, 4039 set_event_handler/2, 4040 set_interrupt_handler/2, 4041 setval/2, 4042 stack_overflow_message/1, 4043 standalone_toplevel/0, 4044 subcall/2, 4045 subscript/3, 4046 sum/2, 4047 (skipped)/1, 4048 term_to_bytes/2, 4049 test_and_setval/3, 4050 (tool)/1, 4051 (tool)/2, 4052 tool_body/3, 4053 trace/1, 4054 (traceable)/1, 4055 tyi/1, 4056 tyo/1, 4057 (unskipped)/1, 4058 (untraceable)/1, 4059 use_module/1, 4060 wait/2, 4061 wait/3, 4062 write/1, 4063 write/2, 4064 write_canonical/1, 4065 write_canonical/2, 4066 writeln/1, 4067 writeln/2, 4068 writeq/1, 4069 writeq/2, 4070 yield/2. 4071 4072 4073/******making the built-in procedures invisible to the debugger*******/ 4074 4075:- untraceable 4076 (.)/2, 4077 (',')/2, 4078 (;)/2, 4079 (->)/2, 4080 ':'/2, 4081 '[]:@'/3, 4082 ',_body'/3, 4083 ';_body'/3, 4084 '->_body'/3, 4085 bip_error/1, 4086 bip_error/2, 4087 block/4, 4088 block_atomic/4, 4089 compile_list_body/3, 4090 create_module_if_did_not_exist/2, 4091 dbgcomp/0, 4092 ensure_loaded/2, 4093 eval/3, 4094 evaluating_goal/5, 4095 fail_if_body/2, 4096 get_bip_error/1, 4097 get_file/3, 4098% get_statistics/2, 4099 (help)/0, 4100 insert_suspension/4, % to hide it in delay clauses 4101 lib/1, 4102 set_bip_error/1, 4103% set_statistics/2, 4104 make_suspension/3, % to hide it in delay clauses 4105 make_suspension/4, 4106 new_delays/2, 4107% subcall_init/0, 4108% subcall_fini/1, 4109 nodbgcomp/0, 4110 once_body/2, 4111% print_statistics/0, 4112 (skipped)/1, 4113 syserror/4, 4114 (traceable)/1, 4115 debug_body/2, 4116 trace_body/2, 4117 trans_term/2, 4118 (unskipped)/1, 4119 (untraceable)/1, 4120 untraced_block/3, 4121 untraced_call/2, 4122 untraced_true/0, 4123 valid_error/1. 4124 4125% dbgcomp procedures and tools must be made skipped explicitly 4126 4127:- skipped 4128 (.)/2, 4129 (export)/1, 4130 (global)/1, 4131 (import)/1, 4132 (local)/1, 4133 (skipped)/1, 4134 (traceable)/1, 4135 (unskipped)/1, 4136 (untraceable)/1, 4137 abort/0, 4138 canonical_path_name/2, 4139 coroutine/0, 4140 current_interrupt/2, 4141 display/1, 4142 ensure_loaded/1, 4143 ensure_loaded/2, 4144 erase_array/1, 4145 erase_module/1, 4146 evaluating_goal/5, 4147 existing_file/4, 4148 exit/1, 4149 extension/1, 4150 false/0, 4151 get_char/1, 4152 get_error_handler/3, 4153 get_event_handler/3, 4154 get_file/3, 4155 get_flag/3, 4156 get_interrupt_handler/3, 4157 halt/0, 4158 lib/1, 4159 lib/2, 4160 make/0, 4161 nl/0, 4162 (demon)/1, 4163 (parallel)/1, 4164 pathname/2, 4165 printf/2, 4166 printf/3, 4167 printf_goal_body/3, 4168 sprintf/3, 4169 proc_flags/4, 4170 put_char/1, 4171 read_string/3, 4172 read_token/2, 4173 reset_error_handler/1, 4174 reset_error_handlers/0, 4175 sepia_version_banner/2, 4176 set_default_error_handler/2, 4177 set_error_handler/2, 4178 set_interrupt_handler/2, 4179 tyi/1, 4180 tyo/1, 4181 use_module/1, 4182 wait/2, 4183 wait/3, 4184 writeln/1, 4185 writeln/2. 4186 4187:- traceable 4188 (is)/2, % because it inherits untraceable from is_body/3 4189 use_module/1. 4190 4191:- unskipped 4192 ',_body'/3, 4193 ';_body'/3, 4194 '->_body'/3. 4195 4196 4197:- set_flag([trace_body/2,debug_body/2], start_tracing, on). 4198:- set_flag(make_suspension/3, invisible, on). 4199 4200:- set_flag(subcall/3, trace_meta, on). 4201:- set_flag(call_local/2, trace_meta, on). 4202:- set_flag(fail_if_body/2, trace_meta, on). 4203:- set_flag((not)/1, trace_meta, on). 4204:- set_flag((\+)/1, trace_meta, on). 4205:- set_flag(once_body/2, trace_meta, on). 4206:- set_flag(call_priority/3, trace_meta, on). 4207 4208 4209%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 4210% 4211% Profile support 4212% 4213% Flags: 1 simples, not only prolog 4214% Flags: 2 all, even locals, no substitution 4215% 4216% creates a list of 4217% pred(StartAddress, start of wam code 4218% Index, variable for normal preds 4219% or index for module/replacement pred 4220% Pred, Name/Arity or ' ' 4221% Module) 4222% 4223?- make_array_(profile_module, prolog, local, sepia_kernel). 4224prof_predicate_list(Flags, Preds, Fixed) :- 4225 prof_fixed_entries(F), 4226 setval(profile_module, F), 4227 findall(pred(Start, I, P, M), prof_predicate(Flags, P, M, Start, I), Preds), 4228 getval(profile_module, Fixed). 4229 4230prof_predicate(Flags, Pred, Module, Start, I) :- 4231 P = N/A, 4232 current_module(Module), 4233% getval(profile_module, J), 4234 incval(profile_module), 4235 current_functor(N, A, 2, 0), % functors with predicates only 4236 local_proc_flags(P, 0, Module, Module, Private), % definition_module 4237 local_proc_flags(P, 14, on, Module, _Private), % defined 4238 local_proc_flags(P, 1, ProcFlags, Module, _Private), % flags 4239 (ProcFlags /\ 16'00000300 =:= 16'00000200 -> % CODETYPE==VMCODE 4240 true 4241 ; 4242 Flags /\ 1 =:= 1 4243 ), 4244 local_proc_flags(P, 7, Start, Module, _), 4245 % If N/A is local to a locked Module, and the 'all'-flag is not given, 4246 % then try to map it to a more useful exported predicate name (using table). 4247 ( Private=local, Flags/\2 =:= 0, prof_replace_pred(N, A, Module, Pred, I) -> 4248 true 4249 ; 4250 Pred = N/A 4251 ). 4252 4253% prof_replace_pred(Name, Arity, Module, NewPred, Index) 4254:- mode prof_replace_pred(++, ++, ++, -, -). 4255 4256prof_replace_pred(free_variables, 4, sepia_kernel, bagof_body/4, 0) :- !. 4257prof_replace_pred(free_variables, 5, sepia_kernel, bagof_body/4, 0) :- !. 4258prof_replace_pred(collect_instances, 4, sepia_kernel, bagof_body/4, 0) :- !. 4259prof_replace_pred(make_key, 3, sepia_kernel, bagof_body/4, 0) :- !. 4260prof_replace_pred(eval, 3, sepia_kernel, arithmetic, 1) :- !. 4261prof_replace_pred(compare_handler, 4, sepia_kernel, arithmetic, 1) :- !. 4262prof_replace_pred(evaluating_goal, 5, sepia_kernel, arithmetic, 1) :- !. 4263prof_replace_pred(recordz_instances, 3, sepia_kernel, all_solutions, 2) :- !. 4264prof_replace_pred(chk_nmbr_lst, 2, sepia_kernel, name/2, 3) :- !. 4265prof_replace_pred(susps_to_goals, 2, sepia_kernel, delayed_goals/2,4):- !. 4266prof_replace_pred(collect_goals, 3, sepia_kernel, coroutining, 5) :- !. 4267prof_replace_pred(collect_goals, 4, sepia_kernel, coroutining, 5) :- !. 4268prof_replace_pred(extract_goals, 4, sepia_kernel, coroutining, 5) :- !. 4269prof_replace_pred(wake_list, 1, sepia_kernel, coroutining, 5) :- !. 4270prof_replace_pred(untraced_call, 2, sepia_kernel, metacall, 6) :- !. 4271prof_replace_pred(call_priority, 3, sepia_kernel, metacall, 6) :- !. 4272prof_replace_pred((','), 4, sepia_kernel, metacall, 6) :- !. 4273prof_replace_pred((;), 4, sepia_kernel, metacall, 6) :- !. 4274prof_replace_pred((;), 5, sepia_kernel, metacall, 6) :- !. 4275prof_replace_pred(length1, 2, sepia_kernel, length/2, 7) :- !. 4276prof_replace_pred(length, 3, sepia_kernel, length/2, 7) :- !. 4277prof_replace_pred(member, 3, sepia_kernel, member/2, 8) :- !. 4278prof_replace_pred(reverse, 3, sepia_kernel, reverse/2, 9) :- !. 4279prof_replace_pred(subscript1, 5, sepia_kernel, subscript/3, 10) :- !. 4280prof_replace_pred(subscript2, 6, sepia_kernel, subscript/3, 10) :- !. 4281prof_replace_pred(subscript3, 5, sepia_kernel, subscript/3, 10) :- !. 4282prof_replace_pred(subscript, 4, sepia_kernel, subscript/3, 10) :- !. 4283prof_replace_pred(forallc, 4, sepia_kernel, do/2, 11) :- !. 4284 4285prof_fixed_entries(12). 4286 4287:- local % because the tool declaration has made them exported ... 4288 get_syntax_/3, 4289 mutex_one_body/3, 4290 set_syntax_/3, 4291 set_proc_flags/4. 4292 4293%----------------------------- 4294% help 4295%----------------------------- 4296 4297help :- 4298 error(231, help), 4299 !. 4300help :- 4301 writeln("\n\ 4302 After the prompt [<module>]: ECLiPSe waits for a goal.\n\ 4303 Don't forget to terminate your input with a full stop.\n\ 4304 To type in clauses, call [user] or compile(user), and then\n\ 4305 enter the clauses, ended by ^D (Unix) or ^Z (Windows).\n\n\ 4306 Call help(Pred/Arity) or help(Pred) or help(String)\n\ 4307 to get help on a specific built-in predicate."), 4308 getval(sepiadir, Eclipsedir), 4309 printf("\n\ 4310 To access the documentation in html-format, point your browser to\n\ 4311 file:%s/doc/index.html\n", Eclipsedir), 4312 writeln("\n\ 4313 This message can be modified by setting the handler for event 231."). 4314 4315 4316%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 4317%% Predefined macros 4318%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 4319 4320% 4321% The protecting functor no_macro_expansion/1 4322% 4323% Should just be 4324% trprotect(no_macro_expansion(X), X). 4325% but to avoid problems we don't use no_macro_expansion/1 in the definition. 4326 4327trprotect(In, Out) :- arg(1, In, Out). 4328 4329:- define_macro(no_macro_expansion/1, trprotect/2, [protect_arg,global]). 4330 4331 4332/* Backward-compatibility transformation for matching clauses */ 4333 4334tr_match((Head ?- Body), (Head :- -?-> Body), AnnMatch, AnnTrans) :- 4335 same_annotation((AnnHead ?- AnnBody), AnnMatch, 4336 (AnnHead :- AnnMatchBody), AnnTrans), 4337 inherit_annotation(-?-> AnnBody, AnnMatch, AnnMatchBody). 4338 4339:- define_macro((?-)/2, tr_match/4, [clause, global]). 4340 4341 4342% 4343% Goal macros / Inlining of general goals 4344% 4345% We use a special convention for goal expansion (inlining) code: 4346% If it exits with a positive integer Tag, this is interpreted as 4347% an error number and the error will be raised in a higher level 4348% predicate, e.g. the compiler or expand_goal/2. 4349% 4350% Using annotated_term in raw form, as macro expansion not available yet! 4351%:- export struct(annotated_term( 4352% term, % var, atomic or compound 4353% type, % atom 4354% file, % atom 4355% line, % integer 4356% from, % integer 4357% to % integer 4358% % may be extended in future 4359% )). 4360% This is defined later in this file 4361 4362expand_goal(Goal, Expanded, Module) :- 4363 expand_goal_annotated_(Goal, _, Expanded, _, Module). 4364 4365expand_goal_annotated_(Goal, AnnGoal, Expanded, AnnExpanded, Module) :- 4366 catch(tr_goals_annotated(Goal, AnnGoal, Expanded, AnnExpanded, Module), 4367 Tag, 4368 ( integer(Tag), Tag > 0 -> 4369 error(Tag, Goal, Module) 4370 ; 4371 throw(Tag) 4372 ) 4373 ). 4374 4375tr_goals(Goal, Expanded, Module) :- 4376 tr_goals_annotated(Goal, _, Expanded, _, Module). 4377 4378 4379% Check an annotation 4380good_annotation(_TermIn, In) :- var(In), !. 4381good_annotation(Term, annotated_term(TermAnn,_,_,_,_,_)) :- 4382 ( var(Term) -> true ; functor(Term, F, N), functor(TermAnn, F, N) ). 4383 4384annotated_arg(_I, AnnTerm, _AnnArg) :- var(AnnTerm), !. 4385annotated_arg(I, annotated_term(TermAnn,_,_,_,_,_), AnnArg) :- 4386 arg(I, TermAnn, AnnArg). 4387 4388annotated_match(AnnTerm, _TermAnn) :- var(AnnTerm), !. 4389annotated_match(annotated_term(TermAnn,_,_,_,_,_), TermAnn). 4390 4391% Make annotated term for TermOut with same annotation as In. 4392% TermIn and TermOut are assumed to have the same structure. Similar to: 4393% In = annotated_term{term:TermIn}, 4394% update_struct(annotated_term, [term:TermOut], In, Out) 4395% but leave Out uninstantiated if In was. 4396 4397same_annotation(_TermIn, In, _TermOut, _Out) :- var(In), !. 4398same_annotation(TermIn, annotated_term(TermIn,Type,File,Line,From,To), 4399 TermOut, annotated_term(TermOut,Type,File,Line,From,To)). 4400 4401% Make annotated term for TermOut, inheriting location from In. Similar to: 4402% update_struct(annotated_term, [term:TermOut,type:TypeOut], In, Out) 4403% but leave Out uninstantiated if In was. 4404inherit_annotation(TermOut, In, Out) :- 4405 inherit_annotation(TermOut, In, Out, true). 4406 4407inherit_annotation(_TermOut, In, _Out, _UseVarNames) :- var(In), !. 4408inherit_annotation(TermOut, 4409 annotated_term(_TermIn,_TypeIn,File,Line,From,To), 4410 annotated_term(TermOut,TypeOut,File,Line,From,To), UseVarNames) :- 4411 ( var(TermOut), UseVarNames==true, get_var_info(TermOut, name, Name) -> 4412 % try to add the variable name if it is available from the parser 4413 TypeOut = var(Name) 4414 ; 4415 type_of(TermOut, TypeOut) 4416 ). 4417 4418tr_goals_annotated(G, Ann, GC, AnnGC, M) :- 4419 ( current_pragma(inline_depth(D))@M, integer(D) -> true ; D=10 ), 4420 tr_goals_annotated(G, Ann, GC, AnnGC, D, M). 4421 4422tr_goals_annotated(Var, Ann, Var, Ann, _, _) :- var(Var), !. 4423tr_goals_annotated((G1, G2), Ann, (GC1, GC2), AnnExp, D, M) :- !, 4424 same_annotation((AnnG1,AnnG2), Ann, (AnnGC1,AnnGC2), AnnExp), 4425 tr_goals_annotated(G1, AnnG1, GC1, AnnGC1, D, M), 4426 tr_goals_annotated(G2, AnnG2, GC2, AnnGC2, D, M). 4427tr_goals_annotated((G1*->G2;G3), Ann, Expanded, AnnExp, D, M) ?- !, Expanded = (GC1*->GC2;GC3), 4428 same_annotation((AnnLhs;AnnG3), Ann, (AnnLhsC;AnnGC3), AnnExp), 4429 same_annotation((AnnG1*->AnnG2), AnnLhs, (AnnGC1*->AnnGC2), AnnLhsC), 4430 tr_goals_annotated(G1, AnnG1, GC1, AnnGC1, D, M), 4431 tr_goals_annotated(G2, AnnG2, GC2, AnnGC2, D, M), 4432 tr_goals_annotated(G3, AnnG3, GC3, AnnGC3, D, M). 4433tr_goals_annotated((G1; G2), Ann, (GC1; GC2), AnnExp, D, M) :- !, 4434 same_annotation((AnnG1;AnnG2), Ann, (AnnGC1;AnnGC2), AnnExp), 4435 tr_goals_annotated(G1, AnnG1, GC1, AnnGC1, D, M), 4436 tr_goals_annotated(G2, AnnG2, GC2, AnnGC2, D, M). 4437tr_goals_annotated((G1 -> G2), Ann, (GC1 -> GC2), AnnExp, D, M) :- !, 4438 same_annotation((AnnG1->AnnG2), Ann, (AnnGC1->AnnGC2), AnnExp), 4439 tr_goals_annotated(G1, AnnG1, GC1, AnnGC1, D, M), 4440 tr_goals_annotated(G2, AnnG2, GC2, AnnGC2, D, M). 4441tr_goals_annotated(-?->(G), Ann, -?->(GC), AnnExp, D, M) :- !, 4442 same_annotation(-?->(AnnG), Ann, -?->(AnnGC), AnnExp), 4443 tr_goals_annotated(G, AnnG, GC, AnnGC, D, M). 4444tr_goals_annotated(once(G), Ann, once(GC), AnnExp, D, M) :- 4445 !, 4446 same_annotation(once(AnnG), Ann, once(AnnGC), AnnExp), 4447 tr_goals_annotated(G, AnnG, GC, AnnGC, D, M). 4448tr_goals_annotated(not(G), Ann, not(GC), AnnExp, D, M) :- 4449 !, 4450 same_annotation(not(AnnG), Ann, not(AnnGC), AnnExp), 4451 tr_goals_annotated(G, AnnG, GC, AnnGC, D, M). 4452tr_goals_annotated(\+(G), Ann, \+(GC), AnnExp, D, M) :- 4453 !, 4454 same_annotation(\+(AnnG), Ann, \+(AnnGC), AnnExp), 4455 tr_goals_annotated(G, AnnG, GC, AnnGC, D, M). 4456tr_goals_annotated(LM:G, Ann, GC, AnnGC, D, M) :- !, 4457 annotated_arg(2, Ann, AnnG), 4458 tr_colon(G, AnnG, GC, AnnGC, M, LM, D). 4459tr_goals_annotated(Goal, Ann, GC, AnnGC, D, M) :- 4460 ( try_tr_goal(Goal, Ann, G1, AnnG1, M, M, D, D1) -> 4461 tr_goals_annotated(G1, AnnG1, GC, AnnGC, D1, M) 4462 ; 4463 GC = Goal, 4464 AnnGC = Ann 4465 ). 4466 4467 4468% Inlining of ModuleList:Goal 4469 4470 tr_colon(G, AnnG, NewG, AnnNewG, _M, LM, _D) :- 4471 var(LM), !, 4472 NewG = LM:G, 4473 transformed_annotate(LM, AnnG, AnnLM), 4474 inherit_annotation((AnnLM:AnnG), AnnG, AnnNewG). 4475 tr_colon(_G, AnnG, NewG, AnnNewG, _M, [], _D) :- !, 4476 NewG = true, 4477 inherit_annotation(NewG, AnnG, AnnNewG). 4478 tr_colon(G, AnnG, NewG, AnnNewG, M, [LM|LMs], D) :- !, 4479 ( try_tr_goal(G, AnnG, LMG0, AnnLMG0, LM, M, D, D1) -> 4480 tr_goals_annotated(LMG0, AnnLMG0, LMG, AnnLMG, D1, M) 4481 ; 4482 LMG = LM:G, 4483 transformed_annotate(LM, AnnG, AnnLM), 4484 inherit_annotation((AnnLM:AnnG), AnnG, AnnLMG) 4485 ), 4486 ( LMs == [] -> 4487 NewG = LMG, 4488 AnnNewG = AnnLMG 4489 ; 4490 NewG = (LMG,LMsG), 4491 % make sure AnnLMsG inherits source position 4492 inherit_annotation((AnnLMG,AnnLMsG), AnnG, AnnNewG), 4493 % like inherit_annotation(LMsG, AnnG, AnnLMsG) but no setting 4494 % of type for AnnLMsG, as LMsG not constructed yet 4495 (nonvar(AnnG) -> 4496 AnnG = annotated_term(_,_,File,Line,From,To), 4497 AnnLMsG = annotated_term(_,_,File,Line,From,To) 4498 ; 4499 true 4500 ), 4501 tr_colon(G, AnnG, LMsG, AnnLMsG, M, LMs, D) 4502 ). 4503 tr_colon(G, AnnG, NewG, AnnNewG, M, LM, D) :- 4504 ( try_tr_goal(G, AnnG, LMG, AnnLMG, LM, M, D, D1) -> 4505 tr_goals_annotated(LMG, AnnLMG, NewG, AnnNewG, D1, M) 4506 ; 4507 NewG = LM:G, 4508 inherit_annotation(AnnLM:AnnG, AnnG, AnnNewG), 4509 transformed_annotate(LM, AnnG, AnnLM) 4510 ). 4511 4512 4513% Inline transformation of a standard goal 4514 4515try_tr_goal(Goal, AnnGoal, NewGoal, AnnNewGoal, LM, CM, Depth, Depth1) :- 4516 visible_goal_macro(Goal, TransPred, TLM, LM), 4517 ( succ(Depth1, Depth) -> 4518 transform(Goal, AnnGoal, NewGoal, AnnNewGoal, TransPred, TLM, CM) 4519 ; 4520 functor(Goal, F, N), 4521 printf(warning_output, 4522 "WARNING: inlining terminated at depth limit: %Kw%n",[LM:F/N]), 4523 fail 4524 ). 4525 4526 % In C: 4527 % visible_goal_macro(Goal, TransPred, TLM, LM) :- 4528 % callable(Goal), 4529 % functor(Goal, N, A), 4530 % get_flag(N/A, inline, TransPred)@LM, 4531 % get_flag(N/A, definition_module, TLM)@LM, 4532 % set referenced-flag for the procedure descriptor. 4533 4534 4535% 4536% This is called just after parsing (if the term contains read-macros). 4537% Transformations are done bottom-up. 4538% A transformation that fails leaves the corresponding subterm untransformed. 4539% A transformation that delays makes an error and leaves the subterm untransformed. 4540% A transformation that aborts aborts the whole read-predicate. 4541% 4542 4543expand_macros_(Term, Expanded, ContextModule) :- 4544 expand_macros_term(Term, Expanded, ContextModule, none). 4545 4546 expand_macros_term(Term, Expanded, _ContextModule, _Exclude) :- 4547 var(Term), 4548 Expanded = Term. 4549 expand_macros_term(Term, Expanded, ContextModule, Exclude) :- 4550 nonvar(Term), 4551 functor(Term, N, A), 4552 ( 4553 visible_term_macro(Term, TransPred, Options, TLM, ContextModule, 12 /*TRANS_PROP*/), 4554 nonmember(Exclude, Options) 4555 -> 4556 ( memberchk(protect_arg, Options) -> 4557 ArgsExpanded = Term 4558 ; 4559 % transform arguments 4560 functor(ArgsExpanded, N, A), 4561 expand_macros_args(1, A, Term, ArgsExpanded, ContextModule) 4562 ), 4563 ( transform(ArgsExpanded, _AnnArgsExpanded, Expanded, _AnnExpanded, TransPred, TLM, ContextModule) -> 4564 true 4565 ; 4566 Expanded = ArgsExpanded 4567 ) 4568 ; 4569 functor(Expanded, N, A), 4570 expand_macros_args(1, A, Term, Expanded, ContextModule) 4571 ). 4572 4573 expand_macros_args(I, A, Term, ArgsExpanded, ContextModule) :- 4574 ( I > A -> 4575 true 4576 ; 4577 I1 is I+1, 4578 arg(I, Term, Arg), 4579 arg(I, ArgsExpanded, ExpandedArg), 4580 expand_macros_term(Arg, ExpandedArg, ContextModule, top_only), 4581 expand_macros_args(I1, A, Term, ArgsExpanded, ContextModule) 4582 ). 4583 4584 4585% And the same with annotated terms, called form read_annotated/2,3 4586% Keep this in sycnc with expand_macros_/3! 4587 4588expand_macros_annotated_(Term, AnnTerm, Expanded, AnnExpanded, ContextModule) :- 4589 nonvar(AnnTerm), 4590 expand_macros_term(Term, AnnTerm, Expanded, AnnExpanded, ContextModule, none). 4591 4592 expand_macros_term(Term, Ann, Expanded, AnnExpanded, _ContextModule, _Exclude) :- 4593 var(Term), 4594 Ann = AnnExpanded, 4595 Expanded = Term. 4596 expand_macros_term(Term, Ann, Expanded, AnnExpanded, ContextModule, Exclude) :- 4597 nonvar(Term), 4598 ( good_annotation(Term, Ann) -> 4599 functor(Term, N, A), 4600 ( 4601 visible_term_macro(Term, TransPred, Options, TLM, ContextModule, 12 /*TRANS_PROP*/), 4602 nonmember(Exclude, Options) 4603 -> 4604 ( memberchk(protect_arg, Options) -> 4605 ArgsExpanded = Term, 4606 AnnArgsExpanded = Ann 4607 ; 4608 % transform arguments 4609 functor(ArgsExpanded, N, A), 4610 functor(ArgsExpandedAnn, N, A), 4611 same_annotation(TermAnn, Ann, ArgsExpandedAnn, AnnArgsExpanded), 4612 expand_macros_args(1, A, Term, TermAnn, ArgsExpanded, ArgsExpandedAnn, ContextModule) 4613 ), 4614 ( transform(ArgsExpanded, AnnArgsExpanded, Expanded, AnnExpanded, TransPred, TLM, ContextModule) -> 4615 true 4616 ; 4617 Expanded = ArgsExpanded, 4618 AnnExpanded = AnnArgsExpanded 4619 ) 4620 ; 4621 functor(Expanded, N, A), 4622 functor(ExpandedAnn, N, A), 4623 same_annotation(TermAnn, Ann, ExpandedAnn, AnnExpanded), 4624 expand_macros_args(1, A, Term, TermAnn, Expanded, ExpandedAnn, ContextModule) 4625 ) 4626 ; 4627 % mismatch between Term and Ann, don't transform 4628 Expanded = Term, 4629 AnnExpanded = Ann 4630 ). 4631 4632 expand_macros_args(I, A, Term, TermAnn, ArgsExpanded, ArgsExpandedAnn, ContextModule) :- 4633 ( I > A -> 4634 true 4635 ; 4636 I1 is I+1, 4637 arg(I, Term, Arg), 4638 arg(I, ArgsExpanded, ExpandedArg), 4639 arg(I, TermAnn, AnnArg), 4640 arg(I, ArgsExpandedAnn, AnnExpandedArg), 4641 expand_macros_term(Arg, AnnArg, ExpandedArg, AnnExpandedArg, ContextModule, top_only), 4642 expand_macros_args(I1, A, Term, TermAnn, ArgsExpanded, ArgsExpandedAnn, ContextModule) 4643 ). 4644 4645 4646 4647% var(Ann) => var(AnnExpanded) 4648transform(Term, Ann, Expanded, AnnExpanded, TN/TA, TLM0, ContextModule) :- 4649 % construct goal <trans>(<in>, <out>[, <module>]) or 4650 % <trans>(<in>, <out>, <inann>, <outann>[, <module>]) 4651 functor(TransGoal, TN, TA), 4652 arg(1, TransGoal, Term), 4653 arg(2, TransGoal, Expanded), 4654 ( TA =< 2 -> 4655 TLM = TLM0 4656 ; TA =< 3 -> 4657 arg(3, TransGoal, ContextModule), 4658 TLM = TLM0 4659 ; 4660 /* with annotated goal, arity 4 or 5 */ 4661 arg(3, TransGoal, Ann), 4662 arg(4, TransGoal, AnnExpanded), 4663 ( TA =< 4 -> 4664 TLM = TLM0 4665 ; 4666 arg(5, TransGoal, ContextModule), 4667 ( TA =< 5 -> 4668 TLM = TLM0 4669 ; 4670 % Sorry, hack: this only happens for unfold/6, which 4671 % has a known lookup module, and gets an extra argument 4672 arg(6, TransGoal, TLM0), 4673 TLM = sepia_kernel 4674 ) 4675 ) 4676 ), 4677 % call toplevel transformation 4678 % TLM:TransGoal@ContextModule 4679 module_tag(TLM, MarkedTLM), 4680 subcall(MarkedTLM:TransGoal@ContextModule, Delayed), 4681 !, 4682 ( Delayed = [] -> 4683 (var(AnnExpanded) -> 4684 % TransGoal did not annotate AnnExpanded 4685 transformed_annotate(Expanded, Ann, AnnExpanded) 4686 ; 4687 good_annotation(Expanded, AnnExpanded) 4688 ) 4689 ; 4690 error(129, TLM:TransGoal, ContextModule) 4691 ). 4692 4693% Deeply annotate Term, inheriting all source positions from Template 4694transformed_annotate(_Term, Template, _Ann) :- 4695 transformed_annotate(_Term, Template, _Ann, true). 4696 4697% The same, but do not try to add variable names. This is useful to suppress 4698% singleton warnings when the annotated term gets compiled. 4699transformed_annotate_anon(_Term, Template, _Ann) :- 4700 transformed_annotate(_Term, Template, _Ann, false). 4701 4702transformed_annotate(_Term, Template, _Ann, _UseVarNames) :- 4703 var(Template), !. 4704transformed_annotate(Term, Template, Ann, UseVarNames) :- 4705 ( compound(Term) -> 4706 functor(Term, F, A), 4707 functor(TermAnn, F, A), 4708 inherit_annotation(TermAnn, Template, Ann, UseVarNames), 4709 transformed_annotate_args(1, A, Template, Term, TermAnn, UseVarNames) 4710 ; 4711 inherit_annotation(Term, Template, Ann, UseVarNames) 4712 ). 4713 4714 transformed_annotate_args(N, A, Template, Term, TermAnn, UseVarNames) :- 4715 ( N > A -> 4716 true 4717 ; 4718 arg(N, Term, Arg), 4719 arg(N, TermAnn, AnnArg), 4720 transformed_annotate(Arg, Template, AnnArg, UseVarNames), 4721 N1 is N + 1, 4722 transformed_annotate_args(N1, A, Template, Term, TermAnn, UseVarNames) 4723 ). 4724 4725 4726 4727expand_clause_(Clause, ClauseExpanded, ContextModule) :- 4728 expand_clause_annotated_(Clause, _, ClauseExpanded, _, ContextModule). 4729 4730 4731expand_clause_annotated_(Clause, AnnClause, ClauseExpanded, 4732 AnnClauseExpanded, ContextModule) :- 4733 clause_head(Clause, Head), 4734 ( 4735 nonvar(Head), 4736 visible_term_macro(Head, TransPred, _Options, TLM, ContextModule, 16 /*CLAUSE_TRANS_PROP*/), 4737 transform(Clause, AnnClause, ClauseExpanded, AnnClauseExpanded, 4738 TransPred, TLM, ContextModule) 4739 -> 4740 true 4741 ; 4742 ClauseExpanded = Clause, 4743 AnnClauseExpanded = AnnClause 4744 ). 4745 4746 4747% Expand clauses and their body goals 4748 4749expand_clauses(Clause, Clause, _Module) :- 4750 var(Clause), !. 4751expand_clauses([], [], _Module) :- !. 4752expand_clauses([Clause|Clauses], ExpClauses, Module) :- !, 4753 expand_clause_(Clause, StandardClauses, Module), 4754 expand_clause_bodies(StandardClauses, ExpClauses, ExpClauses0, Module), 4755 expand_clauses(Clauses, ExpClauses0, Module). 4756expand_clauses(Clause, ExpClauses, Module) :- 4757 expand_clause_(Clause, StandardClauses, Module), 4758 expand_clause_bodies(StandardClauses, ExpClauses, [], Module). 4759 4760 expand_clause_bodies(Clause, [Clause|ExpClauses0], ExpClauses0, _Module) :- 4761 var(Clause), !. 4762 expand_clause_bodies([], ExpClauses, ExpClauses, _Module) :- !. 4763 expand_clause_bodies([Clause|Clauses], [ExpClause|ExpClauses1], ExpClauses0, Module) :- !, 4764 expand_clause_body(Clause, ExpClause, Module), 4765 expand_clause_bodies(Clauses, ExpClauses1, ExpClauses0, Module). 4766 expand_clause_bodies(Clause, [ExpClause|ExpClauses0], ExpClauses0, Module) :- 4767 expand_clause_body(Clause, ExpClause, Module). 4768 4769 expand_clause_body((Head:-Body), Expanded, Module) ?- !, 4770 Expanded = (Head:-ExpandedBody), 4771 expand_goal(Body, ExpandedBody, Module). 4772 expand_clause_body(Clause, Clause, _Module). 4773 4774 4775:- export 4776 register_compiled_stream/1, 4777 register_compiler/1, 4778 deregister_compiler/0, 4779 nested_compile_term/1, 4780 nested_compile_term_annotated/2. 4781 4782register_compiler(NestedCompileSpec) :- 4783 getval(compile_stack, Stack), 4784 setval(compile_stack, [NestedCompileSpec|Stack]). 4785 4786deregister_compiler :- 4787 getval(compile_stack, Stack), 4788 ( Stack = [_Old|Rest] -> 4789 setval(compile_stack, Rest), 4790 % If all compilations finished, do checks 4791 ( Rest == [] -> declaration_checks ; true ) 4792 ; 4793 true 4794 ). 4795 4796nested_compile_term_(Clauses, Module) :- 4797 nested_compile_term_annotated_(Clauses, _, Module). 4798 4799nested_compile_term_annotated_(Clauses, AnnClauses, Module) :- 4800 getval(compile_stack, Stack), 4801 ( Stack = [Top|_] -> 4802 copy_term(Top, Args-Goal), 4803 arg(1, Args, Clauses), 4804 arg(2, Args, AnnClauses), 4805 call(Goal)@Module 4806 ; 4807 ecl_compiler:compile_term_(Clauses, Module) 4808 ). 4809 4810nested_compile_load_flag(Loading) :- 4811 getval(compile_stack, Stack), 4812 ( Stack = [Args-_Goal|_], arity(Args) >= 3 -> 4813 arg(3, Args, Loading) 4814 ; 4815 Loading = all 4816 ). 4817 4818register_compiled_stream(Stream) :- 4819 setval(compiled_stream, Stream). 4820 4821/* 4822register_compiled_stream(Stream) :- 4823 getval(compiled_stream_stack, Stack), 4824 setval(compiled_stream_stack, [Stream|Stack]). 4825 4826:- export deregister_compiled_stream/0. 4827deregister_compiled_stream :- 4828 getval(compiled_stream_stack, Stack), 4829 ( Stack = [_Old|Rest] -> 4830 setval(compiled_stream_stack, Rest) 4831 ; 4832 true 4833 ). 4834*/ 4835 4836 4837:- define_macro('with attributes'/2, tr_with_attributes/3, [global]). 4838:- export tr_with_attributes/3. 4839 4840tr_with_attributes(no_macro_expansion('with attributes'(X,Attrs)), X, Module) :- 4841 ( meta(X) -> 4842 error(122, X, Module) 4843% error(122, no_macro_expansion('with attributes'(X,Attrs)), Module) 4844 ; 4845 add_attributes(X, Attrs, Module) 4846 ). 4847 4848 add_attributes(_, [], _) ?- true. 4849 add_attributes(X, [Attr|Attrs], Module) ?- 4850 add_qualified_attribute(X, Attr, Module), 4851 add_attributes(X, Attrs, Module). 4852 4853 add_qualified_attribute(X, Module:Attr, _Module) ?- !, 4854 add_attribute(X, Attr, Module). 4855 add_qualified_attribute(X, Attr, Module) :- 4856 add_attribute(X, Attr, Module). 4857 4858 4859 4860clause_head((Head0 :- _), Head) ?- !, Head = Head0. 4861clause_head(Fact, Fact). 4862 4863 4864tr_clause(C, TC, _M) :- var(C), !, 4865 TC = C. 4866tr_clause(H :- B, H :- BC, M) :- 4867 !, 4868 tr_goals(B, BC, M). 4869tr_clause([H|T], [HC|TC], M) :- 4870 !, 4871 tr_clause(H, HC, M), 4872 tr_clause(T, TC, M). 4873tr_clause(C, C, _). 4874 4875 4876 4877%---------------------------------------------------------------- 4878% Goal portray transformations for builtin predicates 4879%---------------------------------------------------------------- 4880 4881:- export portray_control/3. 4882:- define_macro((',')/2, portray_control/3, [global,write,goal]). 4883:- define_macro((:)/2, portray_control/3, [global,write,goal]). 4884:- define_macro((@)/2, portray_control/3, [global,write,goal]). 4885:- define_macro('[]:@'/3, portray_control/3, [global,write,goal]). 4886 4887portray_control((Goal1,Goal2), PortrayedGoal, CM) :- -?-> !, 4888 PortrayedGoal = (PGoal1,PGoal2), 4889 portray_goal(Goal1, PGoal1, CM), 4890 portray_goal(Goal2, PGoal2, CM). 4891portray_control(Goal@CM, PortrayedGoal, LM) :- -?-> !, 4892 PortrayedGoal = PortrayedGoal0@CM, 4893 portray_goal(Goal, PortrayedGoal0, CM, LM). 4894portray_control('[]:@'(LM,Goal,CM), PortrayedGoalAtCM, _) :- -?-> !, 4895 atom(LM), LM \= [], 4896 portray_goal(Goal, PortrayedGoal, CM, LM), 4897 PortrayedGoalAtCM = PortrayedGoal@CM. 4898portray_control(LM:Goal, PortrayedGoal, CM) :- -?-> 4899 atom(LM), is_a_module(LM), 4900 portray_goal(Goal, PortrayedGoal0, CM, LM), 4901 ( Goal == PortrayedGoal0 -> 4902 % don't lose qualification if there was no change 4903 PortrayedGoal = LM:PortrayedGoal0 4904 ; 4905 % re-qualify the expansion if necessary 4906 qualify_goal_if_needed(PortrayedGoal0, CM, LM, PortrayedGoal, _) 4907 ). 4908 4909 % qualify_goal_if_needed(+Goal, +CM, +LM, -QGoal, -UsedLM) 4910 qualify_goal_if_needed(Goal, CM, _, QualGoal, M) :- var(Goal), !, 4911 QualGoal = Goal, M = CM. 4912 qualify_goal_if_needed(Goal, _, _, QualGoal, M) :- Goal = LM:_, !, 4913 QualGoal = Goal, M = LM. 4914 qualify_goal_if_needed(Goal, CM, LM, QualGoal, M) :- 4915 functor(Goal, N, A), 4916 ( is_a_module(LM) -> 4917 ( get_flag_body(N/A, definition_module, DM, LM) -> 4918 ( atom(CM), is_a_module(CM), get_flag_body(N/A, definition_module, DM, CM) -> 4919 % the correct N/A is visible anyway, no need to qualify 4920 QualGoal = Goal, M = CM 4921 ; 4922 QualGoal = LM:Goal, M = LM 4923 ) 4924 ; 4925 % not visible in LM, no point qualifying 4926 QualGoal = Goal, M = CM 4927 ) 4928 ; 4929 QualGoal = LM:Goal, M = LM 4930 ). 4931 4932 4933 4934%---------------------------------------------------------------- 4935% Interface to portray functionality 4936%---------------------------------------------------------------- 4937 4938:- export portray_goal/2. 4939:- tool(portray_goal/2, portray_goal/3). 4940portray_goal(Goal, PortrayedGoal, CM) :- 4941 portray_goal(Goal, PortrayedGoal, CM, CM). 4942 4943 portray_goal(Goal, PortrayedGoal, CM, LM) :- 4944 callable(Goal), 4945 % if we can't lookup in LM, use at least CM 4946 ( authorized_module(LM) -> MLM=LM ; MLM=CM ), 4947 visible_term_macro(Goal, TransPred, _Options, TLM, MLM, 15 /*WRITE_GOAL_TRANS_PROP*/), 4948 transform(Goal, _, PortrayedGoal, _, TransPred, TLM, CM), 4949 !. 4950 portray_goal(Goal, Goal, _, _). 4951 4952 4953 4954:- export portray_term/3. 4955:- tool(portray_term/3, portray_term_/4). 4956 4957portray_term_(Term, Portrayed, term, Module) ?- !, 4958 portray_term_term(Term, Portrayed, Module, no). 4959portray_term_(Term, Portrayed, top_term, Module) ?- !, 4960 portray_term_term(Term, Portrayed, Module, yes). 4961portray_term_(Term, Portrayed, goal, Module) ?- !, 4962 portray_goal(Term, Portrayed, Module, Module). 4963portray_term_(Term, Portrayed, clause, Module) ?- !, 4964 error(141, portray_term(Term, Portrayed, clause), Module). 4965portray_term_(Term, Portrayed, What, Module) :- 4966 error(6, portray_term(Term, Portrayed, What), Module). 4967 4968 % this transformation is top-down, i.e. whole term before its arguments 4969 portray_term_term(Term, Portrayed, _ContextModule, _TopOnly) :- 4970 var(Term), 4971 Portrayed = Term. 4972 portray_term_term(Term, Portrayed, ContextModule, TopOnly) :- 4973 nonvar(Term), 4974 ( 4975 visible_term_macro(Term, TransPred, Options, TLM, ContextModule, 13), % WRITE_TRANS_PROP 4976 transform(Term, _, TopPortrayed, _, TransPred, TLM, ContextModule) 4977 -> 4978 true 4979 ; 4980 Options = [], 4981 TopPortrayed = Term 4982 ), 4983 ( memberchk(protect_arg, Options) -> 4984 Portrayed = TopPortrayed 4985 ; TopOnly == yes -> 4986 Portrayed = TopPortrayed 4987 ; 4988 functor(TopPortrayed, PN, PA), 4989 functor(Portrayed, PN, PA), 4990 portray_term_args(1, PA, TopPortrayed, Portrayed, ContextModule) 4991 ). 4992 4993 portray_term_args(I, A, TopPortrayed, Portrayed, ContextModule) :- 4994 ( I > A -> 4995 true 4996 ; 4997 I1 is I+1, 4998 arg(I, TopPortrayed, Arg), 4999 arg(I, Portrayed, PortrayedArg), 5000 portray_term_term(Arg, PortrayedArg, ContextModule, no), 5001 portray_term_args(I1, A, TopPortrayed, Portrayed, ContextModule) 5002 ). 5003 5004 5005:- pragma(expand). % we can do it from now on! 5006 5007 5008% for the event handler 5009clause_spec(Clause, Name, Arity, Module) :- 5010 clause_head(Clause, OldHead), 5011 visible_term_macro(OldHead, TransPred, _Options, TLM, Module, 16 /*CLAUSE_TRANS_PROP*/), 5012 transform(Clause, _, TrClause, _, TransPred, TLM, Module), 5013 clause_head(TrClause, Head), 5014 functor(Head, Name, Arity). 5015clause_spec(Clause, Name, Arity, _) :- 5016 clause_head(Clause, Head), 5017 functor(Head, Name, Arity). 5018 5019/*** 5020 5021:- inline((@)/2, tr_at/3). 5022 5023tr_at(LookupModule:Goal@CallerModule, NewGoal, ContextModule) ?- !, 5024 nonvar(Goal), nonvar(LookupModule), 5025 functor(Goal, GoalN, GoalA), 5026 ( get_flag(GoalN/GoalA, tool, on)@LookupModule -> 5027 tool_body(GoalN/GoalA, ToolN/ToolA, ToolModule)@LookupModule, 5028 Goal =.. [GoalN|Args], 5029 append(Args, [CallerModule], BodyArgs), 5030 BodyGoal =.. [ToolN|BodyArgs], 5031 ( get_flag(ToolN/ToolA, definition_module, ToolModule)@ContextModule -> 5032% ( ToolModule = ContextModule -> 5033 tr_goals(BodyGoal, NewGoal, ContextModule) % it's visible/defined here 5034 ; 5035 tr_goals(call_explicit(BodyGoal, ToolModule), NewGoal, ContextModule) 5036 ) 5037 ; 5038 ( LookupModule = ContextModule -> 5039 tr_goals(Goal, NewGoal, ContextModule) 5040 ; 5041 tr_goals(call_explicit(Goal, LookupModule), NewGoal, CallerModule) 5042 ) 5043 ). 5044tr_at(Goal@ContextModule, NewGoal, ContextModule) ?- !, 5045 tr_goals(Goal, NewGoal, ContextModule). 5046tr_at(Goal@CallerModule, NewGoal, ContextModule) ?- !, 5047 tr_at(ContextModule:Goal@CallerModule, NewGoal, ContextModule). 5048 5049***/ 5050 5051 5052% Portray tool bodies as their interfaces 5053 5054:- define_macro((=:=)/3, portray_builtin/2, [global,write,goal]). 5055:- define_macro((=\=)/3, portray_builtin/2, [global,write,goal]). 5056:- define_macro((>=)/3, portray_builtin/2, [global,write,goal]). 5057:- define_macro((=<)/3, portray_builtin/2, [global,write,goal]). 5058:- define_macro((>)/3, portray_builtin/2, [global,write,goal]). 5059:- define_macro((<)/3, portray_builtin/2, [global,write,goal]). 5060 5061portray_builtin(=:=(X,Y,_M), X=:=Y). 5062portray_builtin(=\=(X,Y,_M), X=\=Y). 5063portray_builtin(>=(X,Y,_M), X>=Y). 5064portray_builtin(=<(X,Y,_M), X=<Y). 5065portray_builtin(>(X,Y,_M), X>Y). 5066portray_builtin(<(X,Y,_M), X<Y). 5067 5068 5069%---------------------------------------------------------------------- 5070% Support for storing definitions and managing the visibility of 5071% module-aware named 'items' such as struct- and domain-definitions. 5072% 5073% Each type of item has two hash tables (stores) associated: 5074% 5075% DefStore holds the item definition (which can be local or exported) 5076% key DefModule:Name 5077% value Scope:Definition 5078% 5079% ImpStore holds the import information 5080% key ImpModule:Name 5081% value DefModule 5082% 5083% where 5084% Name the name of the item (atom) 5085% Definition the item definition (a ground term) 5086% DefModule definition module (atom), always \= ImpModule 5087% Scope 'local' or 'export' 5088% ImpModule importing module (atom) 5089%---------------------------------------------------------------------- 5090 5091% Define a new item, Scope is 'local' or 'export'. 5092% Allow duplicate, identical definitions. 5093% Set bip_error on error. 5094:- mode define_item(+,++,+,+,+,+,-). 5095define_item(Name, Definition, DefModule, Scope, DefStore, ImpStore, New) :- 5096 check_atom(Name), 5097 check_atom(DefModule), 5098 check_atom(Scope), 5099 ( visible_item(Name, OldDef, DefModule, OldScope, DefStore, ImpStore) -> 5100 ( OldDef == Definition, Scope == OldScope -> 5101 New = false 5102 ; 5103 redef_error(OldScope) 5104 ) 5105 ; 5106 New = true, 5107 % make a canonical, persistent copy of the term, so it can be 5108 % shared and we don't need to make a copy on every retrieval 5109 canonical_copy(Scope:Definition, StoredDefinition), 5110 store_set(DefStore, DefModule:Name, StoredDefinition) 5111 ). 5112 5113 5114% Import an item from ExpOrReexpModule into ImpModule. 5115% Allow duplicate, identical definitions. 5116% Set bip_error on error. 5117:- mode import_item(+,+,+,+,+). 5118import_item(Template, ExpOrReexpModule, ImpModule, DefStore, ImpStore) :- 5119 ( compound(Template) -> true ; set_bip_error(5) ), 5120 functor(Template, Key, _), 5121 % first find the actual definition module 5122 ( store_get(ImpStore, ExpOrReexpModule:Key, DefModule) -> 5123 true 5124 ; 5125 DefModule = ExpOrReexpModule 5126 ), 5127 % catch duplicate imports 5128 ( visible_item(Key, _OldDef, ImpModule, OldScope, DefStore, ImpStore) -> 5129 ( OldScope == from(DefModule) -> 5130 true % identical, ignore 5131 ; 5132 redef_error(OldScope) % ambiguous, keep first one 5133 ) 5134 ; ImpModule == DefModule -> 5135 true % ignore if local 5136 ; 5137 store_set(ImpStore, ImpModule:Key, DefModule) 5138 ). 5139 5140 redef_error(local) :- 5141 set_bip_error(87). 5142 redef_error(export) :- 5143 set_bip_error(88). 5144 redef_error(from(_)) :- 5145 set_bip_error(89). 5146 5147 5148% Lookup or enumerate visible items in LookupModule 5149% Scope is 'local', 'export' or from(DefModule). 5150% :- mode visible_item(+,-,+,-,+,+) is semidet 5151% :- mode visible_item(-,-,+,-,+,+) is nondet 5152visible_item(Key, Definition, LookupModule, Scope, DefStore, ImpStore) :- 5153 nonvar(Key), 5154 ( 5155 % first look for locally defined structs 5156 store_get(DefStore, LookupModule:Key, Scope:Definition) 5157 -> 5158 true 5159 ; 5160 % then look for imported structs 5161 store_get(ImpStore, LookupModule:Key, DefModule), % may fail 5162 store_get(DefStore, DefModule:Key, (export):Definition), % may fail 5163 Scope = from(DefModule) 5164 ). 5165visible_item(Key, Definition, LookupModule, Scope, DefStore, ImpStore) :- 5166 var(Key), 5167 ( 5168 % first look for locally defined structs 5169 stored_keys(DefStore, DefModsKeys), 5170 member(DefModKey, DefModsKeys), 5171 DefModKey = LookupModule:Key, % may fail 5172 store_get(DefStore, DefModKey, Scope:Definition) 5173 ; 5174 % then look for imported structs 5175 stored_keys(ImpStore, ImpModsKeys), 5176 member(ImpModKey, ImpModsKeys), 5177 ImpModKey = LookupModule:Key, % may fail 5178 store_get(ImpStore, ImpModKey, DefModule), 5179 store_get(DefStore, DefModule:Key, (export):Definition), 5180 Scope = from(DefModule) 5181 ). 5182 5183 5184% Erase all information about Module's definitions and imports of an item. 5185% Keep information about imports _from_ Module. 5186:- mode erase_module_item(+,+,+). 5187erase_module_item(Module, DefStore, ImpStore) :- 5188 store_erase_qualified(ImpStore, Module), 5189 store_erase_qualified(DefStore, Module). 5190 5191 5192%---------------------------------------------------------------------- 5193% Structure declarations 5194% 5195% Information about struct declarations is stored in two hash tables: 5196% 5197% Table 'struct_def' holds the structure definitions (local or exported) 5198% key DefModule:Name 5199% value Scope:Prototype 5200% 5201% Table 'imported_struct' holds the import information 5202% key ImpModule:Name 5203% value DefModule 5204% 5205% where 5206% Name the name of the structure (atom) 5207% Prototype the struct definition (a ground structure) 5208% DefModule definition module (atom), always \= ImpModule 5209% Scope 'local' or 'export' 5210% ImpModule importing module (atom) 5211%---------------------------------------------------------------------- 5212 5213:- export tr_with/5, tr_of/3. 5214 5215:- define_macro((with)/2, tr_with/5, [global]), 5216 define_macro((of)/2, tr_of/3, [global]). 5217 5218:- store_create_named(struct_def). 5219:- store_create_named(imported_struct). 5220 5221 5222% Define a new structure, Scope is 'local' or 'export'. 5223% Set bip_error on error. 5224define_struct(Definition, DefModule, Scope) :- 5225 check_struct_def(Definition), 5226 functor(Definition, Name, _), 5227 define_item(Name, Definition, DefModule, Scope, struct_def, imported_struct, _New). 5228 5229 check_struct_def(X) :- var(X), !, set_bip_error(4). 5230 check_struct_def(X) :- compound(X), !, 5231 arity(X, N), 5232 check_struct_def_arg(N, X, FieldNames), 5233 sort(0, <, FieldNames, FieldNamesNoDuplicates), 5234 ( length(FieldNamesNoDuplicates, N) -> true ; set_bip_error(6) ). 5235 check_struct_def(_) :- set_bip_error(5). 5236 5237 :- mode check_struct_def_arg(+,+,-). 5238 check_struct_def_arg(0, _, []) :- !. 5239 check_struct_def_arg(I, X, [N|Ns]) :- 5240 arg(I, X, A), 5241 check_field_def(A, N), 5242 I1 is I-1, 5243 check_struct_def_arg(I1, X, Ns). 5244 5245 :- mode check_field_def(?,-). 5246 check_field_def(X, _) :- var(X), !, set_bip_error(4). 5247 check_field_def(N, N) :- atom(N), !. 5248 check_field_def(N:S, N) :- atom(N), atom(S), !. 5249 check_field_def(_, _) :- set_bip_error(5). 5250 5251 5252% Import a structure from an exporting or reexporting module. 5253% Set bip_error on error. 5254import_struct(Template, ExpOrReexpModule, ImpModule) :- 5255 import_item(Template, ExpOrReexpModule, ImpModule, struct_def, imported_struct). 5256 5257 5258% Lookup or enumerate visible structures in LookupModule 5259% Scope is 'local', 'export' or from(DefModule). 5260% :- mode visible_struct(+,-,+,-) is semidet 5261% :- mode visible_struct(-,-,+,-) is nondet 5262visible_struct(Key, Definition, LookupModule, Scope) :- 5263 visible_item(Key, Definition, LookupModule, Scope, struct_def, imported_struct). 5264 5265 5266% Erase all information about Module's definitions and imports. 5267% Keep information about imports from Module. 5268erase_module_structs(Module) :- 5269 erase_module_item(Module, struct_def, imported_struct). 5270 5271 5272% the current_struct/1 builtin (obsolete) 5273:- export current_struct/1. 5274:- tool(current_struct/1, current_struct_/2). 5275current_struct_(ProtoStruct, M) :- var(ProtoStruct), 5276 current_struct_(_Name, ProtoStruct, M). 5277current_struct_(ProtoStruct, M) :- nonvar(ProtoStruct), 5278 functor(ProtoStruct, Name, _), 5279 current_struct_(Name, ProtoStruct, M). 5280 5281 5282% the current_struct/2 builtin 5283:- export current_struct/2. 5284:- tool(current_struct/2, current_struct_/3). 5285current_struct_(Name, ProtoStruct, M) :- var(Name), !, 5286 visible_struct(Name, ProtoStruct, M, _Scope). 5287current_struct_(Name, ProtoStruct, M) :- atom(Name), !, 5288 visible_struct(Name, ProtoStruct, M, _Scope). 5289current_struct_(Name, ProtoStruct, M) :- 5290 error(5, current_struct(Name, ProtoStruct), M). 5291 5292 5293 5294% the macro transformation for with/2 5295 5296tr_with(Term, Struct, AnnTerm, AnnStruct, M) :- 5297 Term = no_macro_expansion(Functor with Args), 5298 atom(Functor), 5299 visible_struct(Functor, ProtoStruct, M, _Scope), !, 5300 annotated_match(AnnTerm, TermAnn), 5301 TermAnn = no_macro_expansion(AnnFunctor with _AnnArgs), 5302 functor(ProtoStruct, Functor, Arity), 5303 functor(Struct, Functor, Arity), 5304 (tr_and(Args, ProtoStruct, Struct, M) -> 5305 ( no_duplicates(Args) -> 5306 transformed_annotate(Struct, AnnFunctor, AnnStruct) 5307 ; 5308 printf(warning_output, 5309 "WARNING: Duplicate struct field name in module %w in%n %w%n", [M,Term]), 5310 fail 5311 ) 5312 ; 5313 printf(warning_output, 5314 "WARNING: Unrecognised or missing struct field name in module %w in%n %w%n", [M,Term]), 5315 fail 5316 ). 5317tr_with(Term, _Struct, _AnnTerm, _AnnStruct, M) :- 5318 printf(warning_output, 5319 "WARNING: Unrecognized structure name in module %w in%n %w%n", [M,Term]), 5320 fail. 5321 5322 no_duplicates(Args) :- Args = [_|_], !, 5323 sort(1, <, Args, Unique), 5324 same_length(Args, Unique). 5325 no_duplicates(_). 5326 5327tr_and([], _ProtoStruct, _Struct, _M) ?- !. 5328tr_and([Arg|Args], ProtoStruct, Struct, M) ?- !, 5329 tr_field(Arg, ProtoStruct, Struct, M), 5330 tr_and(Args, ProtoStruct, Struct, M). 5331tr_and(Arg, ProtoStruct, Struct, M) :- 5332 tr_field(Arg, ProtoStruct, Struct, M). 5333 5334tr_field(FieldName:FieldValue, ProtoStruct, Struct, M) ?- 5335 atom(FieldName), 5336 struct_insert_field(ProtoStruct, FieldName, FieldValue, Struct, M). 5337 5338 5339% the macro transformation for of/2 5340 5341tr_of(no_macro_expansion(Field of Functor), N, M) :- 5342 atom(Functor), 5343 visible_struct(Functor, ProtoStruct, M, _Scope), 5344 !, 5345 ( struct_lookup_field(ProtoStruct, Field, N, M) -> 5346 true 5347 ; 5348 printf(warning_output, 5349 "WARNING: Unrecognized field name in '%w of %w' in module %w.%n%b", [Field,Functor,M]), 5350 fail 5351 ). 5352tr_of(Term, _N, M) :- 5353 printf(warning_output, 5354 "WARNING: Unrecognized structure name in '%w' in module %w.%n%b", [Term,M]), 5355 fail. 5356 5357 struct_lookup_field(ProtoStruct, Field, N, M) :- 5358 atom(Field), 5359 struct_lookup_index(ProtoStruct, Field, N, M). 5360 struct_lookup_field(ProtoStruct, property(Prop), N, _M) :- -?-> 5361 struct_lookup_property(ProtoStruct, Prop, N). 5362 5363 5364struct_lookup_index(ProtoStruct, FieldName, Index, M) :- 5365 arity(ProtoStruct, Arity), 5366 ( proto_lookup_index(ProtoStruct, FieldName, Index, Arity) -> true 5367 ; substruct_lookup_index(ProtoStruct, FieldName, Index, Arity, M) 5368 ). 5369 5370 struct_lookup_property(ProtoStruct, arity, Arity) :- -?-> 5371 arity(ProtoStruct, Arity). 5372 struct_lookup_property(ProtoStruct, functor, Functor) :- -?-> 5373 Functor = Name/Arity, 5374 functor(ProtoStruct, Name, Arity). 5375 5376 5377 proto_lookup_index(_ProtoStruct, _FieldName, _, 0) :- !, fail. 5378 proto_lookup_index(ProtoStruct, FieldName, Index, I) :- 5379 arg(I, ProtoStruct, FieldSpec), 5380 ( FieldSpec = FieldName -> 5381 Index = I 5382 ; FieldSpec = FieldName:_SubStruct -> 5383 Index = I 5384 ; 5385 I1 is I-1, 5386 proto_lookup_index(ProtoStruct, FieldName, Index, I1) 5387 ). 5388 5389 substruct_lookup_index(_ProtoStruct, _FieldName, _, 0, _M) :- !, fail. 5390 substruct_lookup_index(ProtoStruct, FieldName, Index, I, M) :- 5391 arg(I, ProtoStruct, FieldSpec), 5392 ( 5393 FieldSpec = _SubFieldName:SubStructFunctor, 5394 visible_struct(SubStructFunctor, ProtoSubStruct, M, _), 5395 struct_lookup_index(ProtoSubStruct, FieldName, SubIndex, M) 5396 -> 5397 ( integer(SubIndex) -> Index = [I,SubIndex] ; Index = [I|SubIndex] ) 5398 ; 5399 I1 is I-1, 5400 substruct_lookup_index(ProtoStruct, FieldName, Index, I1, M) 5401 ). 5402 5403 5404struct_insert_field(ProtoStruct, FieldName, FieldValue, Struct, M) :- 5405 arity(ProtoStruct, Arity), 5406 ( proto_insert_field(ProtoStruct, FieldName, FieldValue, Struct, Arity) -> true 5407 ; substruct_insert_field(ProtoStruct, FieldName, FieldValue, Struct, Arity, M) 5408 ). 5409 5410 proto_insert_field(_ProtoStruct, _FieldName, _FieldValue, _, 0) :- !, fail. 5411 proto_insert_field(ProtoStruct, FieldName, FieldValue, Struct, I) :- 5412 arg(I, ProtoStruct, FieldSpec), 5413 ( FieldSpec = FieldName -> 5414 arg(I, Struct, FieldValue) 5415 ; FieldSpec = FieldName:_SubStruct -> 5416 arg(I, Struct, FieldValue) 5417 ; 5418 I1 is I-1, 5419 proto_insert_field(ProtoStruct, FieldName, FieldValue, Struct, I1) 5420 ). 5421 5422 substruct_insert_field(_ProtoStruct, _FieldName, _FieldValue, _Struct, 0, _M) :- !, fail. 5423 substruct_insert_field(ProtoStruct, FieldName, FieldValue, Struct, I, M) :- 5424 arg(I, ProtoStruct, FieldSpec), 5425 ( 5426 FieldSpec = _SubFieldName:SubStructFunctor, 5427 visible_struct(SubStructFunctor, SubProtoStruct, M, _Scope), 5428 functor(SubProtoStruct, SubStructFunctor, SubArity), 5429 functor(SubStruct, SubStructFunctor, SubArity), 5430 arg(I, Struct, SubStruct), 5431 struct_insert_field(SubProtoStruct, FieldName, FieldValue, SubStruct, M) 5432 -> 5433 true 5434 ; 5435 I1 is I-1, 5436 substruct_insert_field(ProtoStruct, FieldName, FieldValue, Struct, I1, M) 5437 ). 5438 5439 5440:- tool(update_struct/4, update_struct/5). 5441:- inline(update_struct/4, tr_update_struct/3). 5442:- export update_struct/4. 5443 5444update_struct(Name, Fields, OldStruct, MergeStruct, Module) :- 5445 tr_update_struct1(Name, Fields, OldStruct, MergeStruct, Goal, Module), 5446 !, 5447 Goal@Module. 5448update_struct(Name, Fields, OldStruct, MergeStruct, Module) :- 5449 bip_error(update_struct(Name, Fields, OldStruct, MergeStruct), Module). 5450 5451 5452tr_update_struct(update_struct(Name, Fields, OldStruct, MergeStruct), GoalOut, Module) :- 5453 tr_update_struct1(Name, Fields, OldStruct, MergeStruct, GoalOut, Module), 5454 !. 5455tr_update_struct(Goal, _, Module) :- 5456 get_bip_error(Err), 5457 ( Err = 4 -> 5458 % might work at runtime, no error 5459 printf(warning_output, "WARNING: could not expand %w in module %w%n", [Goal,Module]), 5460 fail 5461 ; 5462 error(Err, Goal, Module) 5463 ). 5464 5465 5466tr_update_struct1(F, Fields, OldStruct, MergeStruct, 5467 ( OldStruct=OldTemplate, MergeStruct=NewTemplate), Module) :- 5468 check_atom(F), 5469 check_nonvar(Fields), 5470 ( Fields = [_|_] -> FieldList = Fields 5471 ; Fields = [] -> FieldList = Fields 5472 ; FieldList = [Fields] ), 5473 make_templates(F, FieldList, FieldList3, OldTemplate, NewTemplate, Module), 5474 ( FieldList3 == [] -> 5475 true 5476 ; 5477 check_fieldspecs(FieldList3), 5478 printf(warning_output, "WARNING: Unrecognised field name(s) %w in struct '%w'%n", 5479 [FieldList3,F]), 5480 set_bip_error(6) 5481 ). 5482 5483 % make the two templates for F (OldTemplate and NewTemplate) with the 5484 % fields from FieldList filled in accordingly and all the other fields 5485 % unified. The unrecognised remainder of FieldList is returned. 5486 make_templates(F, FieldList0, FieldList, OldTemplate, NewTemplate, Module) :- 5487 ( current_struct(Declaration)@Module, functor(Declaration, F, N) -> 5488 true 5489 ; 5490 printf(warning_output, "WARNING: Unrecognised structure name '%w'%n", [F]), 5491 set_bip_error(6) 5492 ), 5493 functor(OldTemplate, F, N), 5494 functor(NewTemplate, F, N), 5495 fillin_fields(1, N, FieldList0, FieldList1, OldTemplate, Declaration, NewTemplate, SubStructs), 5496 fillin_sub_fields(SubStructs, FieldList1, FieldList, OldTemplate, NewTemplate, Module). 5497 5498 5499 % Treat all the fields which are not in substructures and return 5500 % a list of substructures for subsequent processing of leftover fields. 5501 % This is breadth-first so that field names hide names in substructures. 5502 fillin_fields(I, N, FieldList1, FieldList, OldTemplate, Declaration, NewTemplate, SubStructs) :- 5503 ( I > N -> 5504 FieldList = FieldList1, 5505 SubStructs = [] 5506 ; 5507 arg(I, Declaration, FieldDecl), 5508 ( FieldDecl = FieldName:SubStruct -> 5509 ( find_field(FieldName, FieldList1, Arg, FieldList2) -> 5510 SubStructs = SubStructs0 5511 ; 5512 SubStructs = [I-SubStruct|SubStructs0], 5513 FieldList2 = FieldList1 5514 ) 5515 ; 5516 ( find_field(FieldDecl, FieldList1, Arg, FieldList2) -> 5517 SubStructs = SubStructs0 5518 ; 5519 SubStructs = SubStructs0, 5520 FieldList2 = FieldList1, 5521 arg(I, OldTemplate, Arg) 5522 ) 5523 ), 5524 arg(I, NewTemplate, Arg), 5525 I1 is I+1, 5526 fillin_fields(I1, N, FieldList2, FieldList, OldTemplate, Declaration, NewTemplate, SubStructs0) 5527 ). 5528 5529 5530 % try to find any fields in the list of substructures 5531 fillin_sub_fields([], FieldList, FieldList, _OldTemplate, _NewTemplate, _Module). 5532 fillin_sub_fields([I-SubF|SubStructs], FieldList0, FieldList, OldTemplate, NewTemplate, Module) :- 5533 make_templates(SubF, FieldList0, FieldList1, OldSubTemplate, NewSubTemplate, Module), 5534 ( FieldList0 == FieldList1 -> 5535 arg(I, OldTemplate, Arg), % optimization: no field in this substruct 5536 arg(I, NewTemplate, Arg) 5537 ; 5538 arg(I, OldTemplate, OldSubTemplate), 5539 arg(I, NewTemplate, NewSubTemplate) 5540 ), 5541 fillin_sub_fields(SubStructs, FieldList1, FieldList, OldTemplate, NewTemplate, Module). 5542 5543 5544 find_field(FieldName, [FieldName:Arg0|Rem0], Arg, Rem) ?- 5545 Arg = Arg0, 5546 Rem = Rem0. 5547 find_field(FieldName, [Field|Fields], Arg, Rem) ?- 5548 Rem = [Field|Rem0], 5549 find_field(FieldName, Fields, Arg, Rem0). 5550 5551 5552 5553%---------------------------------------------------------------------- 5554% Enums 5555% 5556% Enum declarations are stored in three hash tables: 5557% 5558% The two standard tables for items: 5559% 5560% domain_def: DefModule:Name -> Scope:Definition 5561% imported_domain: ImpModule:Name -> DefModule 5562% 5563% and an additional, redundant table to quickly map symbols to integers: 5564% 5565% domain_symbols: LookupMod:Value -> (DefMod:Name)-Index 5566% 5567% Within every module, all domain symbols must be unique, i.e. it must 5568% be possible to determine the symbol's type from looking at the value. 5569% We therefore need additional checks on definition and importation. 5570%---------------------------------------------------------------------- 5571 5572:- local store(domain_def). 5573:- local store(imported_domain). 5574:- local store(domain_symbols). 5575 5576% Define a new domain, Scope is 'local' or 'export'. 5577% Allow duplicate, identical definitions. 5578% Make sure no symbol is already defined in this module 5579% Set bip_error on error. 5580define_domain(Definition, DefModule, Scope) :- 5581 check_domain_def(Definition, DefModule, DefModule), 5582 functor(Definition, Name, N), 5583 define_item(Name, Definition, DefModule, Scope, domain_def, imported_domain, New), 5584 ( New = true -> 5585 store_symbols(N, Definition, DefModule:Name, DefModule) 5586 ; 5587 true 5588 ). 5589 5590 check_domain_def(ValueArray, _DefModule, _Module) :- var(ValueArray), !, 5591 set_bip_error(4). 5592 check_domain_def(ValueArray, DefModule, Module) :- compound(ValueArray), !, 5593 ValueArray =.. [Name|Symbols], 5594 check_domain_def_args(Symbols, DefModule:Name, Module), 5595 sort(0, <, Symbols, SymbolsNoDuplicates), 5596 arity(ValueArray, N), 5597 ( length(SymbolsNoDuplicates, N) -> true ; set_bip_error(6) ). 5598 check_domain_def(_ValueArray, _DefModule, _Module) :- 5599 set_bip_error(5). 5600 5601 :- mode check_domain_def_args(+,+,+). 5602 check_domain_def_args([], _, _). 5603 check_domain_def_args([X|Xs], QualName, Module) :- 5604 check_domain_symbol(X, QualName, Module), 5605 check_domain_def_args(Xs, QualName, Module). 5606 5607 :- mode check_domain_symbol(?,+,+). 5608 check_domain_symbol(X, _, _) :- var(X), !, 5609 set_bip_error(4). 5610 check_domain_symbol(Symbol, QualName, Module) :- atomic(Symbol), !, 5611 ( store_get(domain_symbols, Module:Symbol, OtherQualName-_) -> 5612 ( QualName == OtherQualName -> 5613 true 5614 ; 5615 printf(error, "Domain value %w not unique in module %w%n", 5616 [Symbol,Module]), 5617 set_bip_error(6) % should have own number 5618 ) 5619 ; 5620 true). 5621 check_domain_symbol(_, _, _) :- 5622 set_bip_error(5). 5623 5624 :- mode store_symbols(+,+,+,+). 5625 store_symbols(0, _Definition, _QualName, _Module) :- !. 5626 store_symbols(N, Definition, QualName, Module) :- 5627 arg(N, Definition, Symbol), 5628 store_set(domain_symbols, Module:Symbol, QualName-N), 5629 N1 is N-1, 5630 store_symbols(N1, Definition, QualName, Module). 5631 5632 5633% Import a domain 5634% Make sure no symbol is already defined in this module 5635% Allow duplicate, identical definitions. 5636% Set bip_error on error. 5637import_domain(Template, ExpOrReexpModule, ImpModule) :- 5638 functor(Template, Name, N), 5639 % get the definition we are going to import and check for clashing symbols 5640 visible_item(Name, Definition, ExpOrReexpModule, Scope, domain_def, imported_domain), 5641 ( Scope = from(DefModule) -> true ; DefModule = ExpOrReexpModule ), 5642 check_domain_def(Definition, DefModule, ImpModule), 5643 import_item(Template, ExpOrReexpModule, ImpModule, domain_def, imported_domain), 5644 store_symbols(N, Definition, DefModule:Name, ImpModule). 5645 5646 5647% Erase all information about Module's domains 5648erase_module_domains(Module) :- 5649 erase_module_item(Module, domain_def, imported_domain), 5650 store_erase_qualified(domain_symbols, Module). 5651 5652 5653:- export domain_index/3. 5654:- tool(domain_index/3, domain_index_/4). 5655domain_index_(Symbol, QualName, Index, Module) :- var(Symbol), !, 5656 error(4, domain_index(Symbol, QualName, Index), Module). 5657domain_index_(Symbol, QualName, Index, Module) :- atomic(Symbol), !, 5658 store_get(domain_symbols, Module:Symbol, QualNameIndex), 5659 QualNameIndex = QualName-Index. 5660domain_index_(Symbol, QualName, Index, Module) :- 5661 error(5, domain_index(Symbol, QualName, Index), Module). 5662 5663 5664:- export current_domain/3. 5665:- tool(current_domain/3, current_domain_/4). 5666current_domain_(Name, DefModule, Definition, Module) :- var(Name), !, 5667 visible_item(Name, Definition, Module, Scope, domain_def, imported_domain), 5668 ( Scope = from(DefModule) -> true ; DefModule = Module ). 5669current_domain_(Name, DefModule, Definition, Module) :- atomic(Name), !, 5670 visible_item(Name, Definition, Module, Scope, domain_def, imported_domain), 5671 ( Scope = from(DefModule) -> true ; DefModule = Module ). 5672current_domain_(Name, DefModule, Definition, Module) :- 5673 error(5, current_domain(Name, DefModule, Definition), Module). 5674 5675 5676%------------------------------- 5677% coroutining 5678%------------------------------- 5679 5680% NOTE: The positions of the suspend-arguments are hardcoded elsewhere 5681% in the kernel (and ic)! _suspension_attribute() relies on bound being the 5682% last list, the inst list is a difference list, the bound list is normal. 5683 5684:- export struct(suspend(inst,constrained,bound)). 5685 5686 5687coroutine :- % backward compatibility 5688 global_flags(0,16'00000100,_). 5689 5690coroutining :- % local 5691 global_flags(0,0) /\ 16'00000100 =\= 0. 5692 5693kill_suspension(S) :- 5694 kill_suspension(S, 1). 5695 5696current_suspension(S) :- 5697 current_suspension(S, []). 5698 5699 5700% the sound negation 5701 5702:- export (~)/1. 5703:- tool((~)/1, tilde_body/2). 5704:- set_flag(tilde_body/2, trace_meta, on). 5705 5706tilde_body(Goal, Module) :- 5707 nonground(Goal, Var), 5708 !, 5709 make_suspension(~(Goal), 0, Susp, Module), 5710 insert_suspension([Var], Susp, 1, suspend). 5711tilde_body(Goal, Module) :- 5712 untraced_call(Goal,Module), 5713 !, fail. 5714tilde_body(_,_). 5715 5716 5717%---------------------------------------------------------------- 5718% explicit suspension - suspend/2,3 5719%---------------------------------------------------------------- 5720 5721/* 5722One thing we can definitely do is a static mapping from symbolic names 5723to numeric priorities (which only gets changed when someone comes up with 5724a convincing use case for introducing a new level). For propagators, 5725we could use Gecode's scheme, where the priorities are called 5726{unary, binary, ternary, linear, quadratic, cubic, veryslow} 5727i.e. they initially distinguish constraint arity, then complexity. 5728For ECLiPSe, where delayed goals can be used for things other than 5729propagators, I would extend this on both ends as follows: 5730 57311-debug (goals that always succeed and do not affect program semantics) 57322-check (tests that succeed or fail or abort) 57333-unary 57344-binary 57355-ternary 57366-linear 57377-quadratic 57388-cubic 57399-subsolver (e.g. the eplex demon) 574010-mopup (bookkeeping to be done after all propagation, e.g. lib(changeset)) 574111-search (nondeterministic goals) 574212-main program 5743 5744This gives us the 12 levels we currently have. Since we use 4 bits to store 5745priorities, it would be natural to extend to 15 (giving some flexibility 5746that can be used e.g. for the case of the ternary propagators in lib(ic) 5747which schedule themselves up/down one level depending on whether they 5748achieved some useful propagation or not. This kind of dynamic adjustment 5749may well be more important than a fine grained static classification). 5750*/ 5751 5752:- export 5753 suspend/3, 5754 suspend/4. 5755:- export 5756 tr_suspend/3. 5757 5758 5759:- inline(suspend/3, tr_suspend/3). 5760:- inline(suspend/4, tr_suspend/3). 5761 5762% If tr_suspend should fail at compile time, we just 5763% don't expand and leave the error to runtime. 5764tr_suspend(no_macro_expansion(suspend(Goal, Prio, List)), Goals, Module) :- 5765 tr_suspend(no_macro_expansion(suspend(Goal, Prio, List, _Susp)), Goals, Module). 5766tr_suspend(no_macro_expansion(suspend(Goal, Prio, List, Susp)), Goals, Module) :- 5767 Goals = (make_suspension(Goal, Prio, Susp, Module), G1), 5768 tr_suspend1(Susp, List, Module, G1). 5769 5770tr_suspend1(_Susp, [], _Module, Goals) ?- !, 5771 Goals = true. 5772tr_suspend1(Susp, [Spec|Specs], Module, Goals) ?- !, 5773 tr_suspend2(Susp, Spec, Module, Goals, Goals1), 5774 tr_suspend1(Susp, Specs, Module, Goals1). 5775tr_suspend1(Susp, Spec, Module, Goals) :- 5776 tr_suspend2(Susp, Spec, Module, Goals, true). 5777 5778tr_suspend2(Susp, Vars->Select, Module, Goals, Goals0) ?- 5779 %find_susp_list(Select, Index, M, Module), 5780 %Goal = insert_suspension(Vars, Susp, Index, M). 5781 make_inserts_top(Select, Vars, Susp, Module, Goals, Goals0). 5782tr_suspend2(Susp, trigger(Event), _Module, Goals, Goals0) ?- 5783 Goals = (attach_suspensions(Event, Susp),Goals0). 5784 5785 % make_inserts(+Spec, ?Vars, +Susp, +Module, -Goals, ?MoreGoals) 5786 % 5787 % Generate insert_suspension/4 goals. Allowed forms of Spec: 5788 % ->min 5789 % ->fd:min 5790 % ->fd:3 could have been fd:(max of fd) 5791 % ->fd:[min,3] 5792 % ->[min,fd:max,fd:4,fd:[min,3]] 5793 % 5794 % Names are taken from meta_attribute-suspension_lists-declarations 5795 % (if present), or from a struct that has the same name as the attribute. 5796 % In any case, an attribute-named structure must be visible (we use the 5797 % struct-visibility as a proxy for the (global) attribute's visibility)! 5798 % Support for unqualified names, e.g. X->min works in the same way, 5799 % but requires a unique match for a specific attribute. 5800 % Ambiguity leads to a warning, and failure. 5801 5802 make_inserts_top([], _Vars, _Susp, _Module, Gs, Gs0) ?- !, 5803 Gs = Gs0. 5804 make_inserts_top([Spec|Specs], Vars, Susp, Module, Gs, Gs0) ?- !, 5805 make_inserts(Spec, Vars, Susp, Module, Gs, Gs1), 5806 make_inserts_top(Specs, Vars, Susp, Module, Gs1, Gs0). 5807 make_inserts_top(Spec, Vars, Susp, Module, Gs, Gs0) :- 5808 make_inserts(Spec, Vars, Susp, Module, Gs, Gs0). 5809 5810 % accept unqualified atom, or qualified something 5811 make_inserts(SuspName, Vars, Susp, Module, Gs, Gs0) :- atom(SuspName), !, 5812 lookup_suspension_list(AttrName, SuspName, Slots, Module), 5813 make_inserts_slots(AttrName, Slots, Vars, Susp, Gs, Gs0). 5814 make_inserts(AttrName:Spec, Vars, Susp, Module, Gs, Gs0) ?- atom(AttrName), 5815 make_inserts_quals(AttrName, Spec, Vars, Susp, Module, Gs, Gs0). 5816 5817 % attribute known: accept suspension name or integer, or list thereof 5818 make_inserts_quals(_, [], _, _, _, Gs, Gs0) ?- !, 5819 Gs=Gs0. 5820 make_inserts_quals(AttrName, [Spec|Specs], Vars, Susp, Module, Gs, Gs0) ?- !, 5821 make_inserts_qual(AttrName, Spec, Vars, Susp, Module, Gs, Gs1), 5822 make_inserts_quals(AttrName, Specs, Vars, Susp, Module, Gs1, Gs0). 5823 make_inserts_quals(AttrName, Spec, Vars, Susp, Module, Gs, Gs0) :- 5824 make_inserts_qual(AttrName, Spec, Vars, Susp, Module, Gs, Gs0). 5825 5826 % attribute known: accept suspension name or integer 5827 make_inserts_qual(AttrName, Slot, Vars, Susp, _Module, Gs, Gs0) :- integer(Slot), 5828 Gs = (insert_suspension(Vars, Susp, Slot, AttrName),Gs0). 5829 make_inserts_qual(AttrName, SuspName, Vars, Susp, Module, Gs, Gs0) :- atom(SuspName), 5830 lookup_suspension_list(AttrName, SuspName, Slots, Module), 5831 make_inserts_slots(AttrName, Slots, Vars, Susp, Gs, Gs0). 5832 5833 % attribute known: accept integer list (no check) 5834 make_inserts_slots(_AttrName, [], _Vars, _Susp, Gs, Gs). 5835 make_inserts_slots(AttrName, [Slot|Slots], Vars, Susp, Gs, Gs0) :- 5836 Gs = (insert_suspension(Vars, Susp, Slot, AttrName),Gs1), 5837 make_inserts_slots(AttrName, Slots, Vars, Susp, Gs1, Gs0). 5838 5839 5840% Non-expanded version 5841:- tool(suspend/3, suspend_body/4). 5842suspend_body(Goal, Prio, List, Module) :- 5843 suspend_body(Goal, Prio, List, _Susp, Module). 5844 5845:- tool(suspend/4, suspend_body/5). 5846suspend_body(Goal, Prio, List, Susp, Module) :- 5847 make_suspension(Goal, Prio, Susp, Module), 5848 ( tr_suspend1(Susp, List, Module, Goals) -> 5849 call(Goals)@Module 5850 ; 5851 error(6, suspend(Goal, Prio, List, Susp), Module) 5852 ). 5853 5854 5855%---------------------------------------------------------------- 5856% Arithmetic preprocessing 5857%---------------------------------------------------------------- 5858 5859% transform a standalone is/2 or eval/2: 5860% - fail (do not transform) for variables 5861% - generate a simple unification for numbers 5862 5863:- inline((is)/2, trans_is/2). 5864 5865trans_is(Res is Expr, Code) :- 5866 trans_is(Expr, Res, Code). 5867 5868 trans_is(Expr, Res, Code) :- 5869 number(Expr), 5870 Code = (Res = Expr). 5871 trans_is(Expr, Res, Code) :- 5872 callable(Expr), 5873 trans_function(Expr, Res, Call, Code, Call). 5874 5875 5876% transform a comparison 5877% fails if nothing to transform (otherwise we'll loop) 5878 5879:- inline((>=)/2, trans_compare/2). 5880:- inline((>)/2, trans_compare/2). 5881:- inline((=<)/2, trans_compare/2). 5882:- inline((<)/2, trans_compare/2). 5883:- inline((=:=)/2, trans_compare/2). 5884:- inline((=\=)/2, trans_compare/2). 5885 5886trans_compare(In, Code) :- 5887 functor(In, F, N), 5888 arg(1, In, X), 5889 arg(2, In, Y), 5890 functor(Out, F, N), 5891 arg(1, Out, RX), 5892 arg(2, Out, RY), 5893 trans_expr(X, RX, Code, Code1), 5894 trans_expr(Y, RY, Code1, sepia_kernel:Out), 5895 Out \== In. % fail when nothing changed 5896 5897 5898% transform a sub-expression: 5899% The result variable Res is assumed to be "fresh" and may be unified! 5900 5901trans_expr(M:Func, Res, Code, NextCode) ?- 5902 var(Func), % special case, similar to eval 5903 !, 5904 Code = (eval(M:Func,Res),NextCode). 5905trans_expr(Expr, Res, Code, NextCode) :- 5906 callable(Expr), 5907 !, 5908 trans_function(Expr, Res, Call, Code, (Call,NextCode)). 5909trans_expr(Expr, Res, Code, NextCode) :- 5910 % var(Expr) ; number(Expr) ; and error cases 5911 Res = Expr, % bind at transformation time 5912 Code = NextCode. % no code 5913 5914 5915trans_function(M:Expr, Res, Call, Code0, Code) :- !, 5916 Call = M:Pred, 5917 Code = Code0, 5918 nonvar(Expr), % may fail 5919 functor(Expr, Op, Ar), 5920 +(Ar, 1, Ar1), 5921 functor(Pred, Op, Ar1), 5922 arg(Ar1, Pred, Res), 5923 unify_args(Ar, Expr, Pred). 5924trans_function(Expr, Res, Call, Code0, Code) :- 5925 functor(Expr, Op, Ar), 5926 +(Ar, 1, Ar1), 5927 functor(Pred, Op, Ar1), 5928 arg(Ar1, Pred, Res), 5929 ( arith_builtin(Expr) -> 5930 Call = sepia_kernel:Pred, 5931 trans_args(1, Ar, Expr, Pred, Code0, Code) 5932 ; inlined_arith_builtin(Expr) -> 5933 Call = sepia_kernel:Pred, 5934 Code = Code0, 5935 unify_args(Ar, Expr, Pred) 5936 ; 5937 Call = Pred, 5938 Code = Code0, 5939 unify_args(Ar, Expr, Pred) 5940 ). 5941 5942 trans_args(N, Ar, Expr, Pred, Code0, Code) :- 5943 ( N > Ar -> 5944 Code = Code0 5945 ; 5946 arg(N, Expr, E1), 5947 arg(N, Pred, R1), 5948 trans_expr(E1, R1, Code0, Code1), 5949 +(N, 1, N1), 5950 trans_args(N1, Ar, Expr, Pred, Code1, Code) 5951 ). 5952 5953 5954:- inline(sum/2, trans_list_op/2). 5955:- inline(min/2, trans_list_op/2). 5956:- inline(max/2, trans_list_op/2). 5957trans_list_op(Goal, Code) :- 5958 Goal =.. [Op, ExprList |Other], 5959 trans_expr_list(ExprList, EvalExprList, Code, Code0), 5960 Code \== Code0, % prevent looping 5961 Code0 = sepia_kernel:NewGoal, 5962 NewGoal =.. [Op, EvalExprList |Other]. 5963 5964 trans_expr_list([E|Es], RRs, Code0, Code) ?- !, 5965 RRs = [R|Rs], 5966 trans_expr(E, R, Code0, Code1), 5967 trans_expr_list(Es, Rs, Code1, Code). 5968 trans_expr_list(VarNilJunk, VarNilJunk, Code, Code). 5969 5970 5971 5972% The following is the list of "builtin" arithmetic functions. 5973% - their arguments get recursively evaluated 5974% - they are currently always qualified with sepia_kernel:... 5975% because that's the semantics when the expression is interpreted in is/2 5976 5977:- export arith_builtin/1. 5978arith_builtin(eval(_)). 5979arith_builtin(+_). 5980arith_builtin(-_). 5981arith_builtin(abs(_)). 5982arith_builtin(sgn(_)). 5983arith_builtin(fix(_)). 5984arith_builtin(integer(_)). 5985arith_builtin(rational(_)). 5986arith_builtin(rationalize(_)). 5987arith_builtin(numerator(_)). 5988arith_builtin(denominator(_)). 5989arith_builtin(float(_)). 5990arith_builtin(breal(_)). 5991arith_builtin(breal_from_bounds(_,_)). 5992arith_builtin(breal_min(_)). 5993arith_builtin(breal_max(_)). 5994arith_builtin(floor(_)). 5995arith_builtin(ceiling(_)). 5996arith_builtin(round(_)). 5997arith_builtin(truncate(_)). 5998arith_builtin(\_). 5999arith_builtin(_ + _). 6000arith_builtin(_ - _). 6001arith_builtin(_ * _). 6002arith_builtin(_ / _). 6003arith_builtin(_ // _). 6004arith_builtin(_ rem _). 6005arith_builtin(_ div _). 6006arith_builtin(_ mod _). 6007arith_builtin(_ ^ _). 6008arith_builtin(min(_,_)). 6009arith_builtin(max(_,_)). 6010arith_builtin(gcd(_,_)). 6011arith_builtin(lcm(_,_)). 6012arith_builtin(_ /\ _). 6013arith_builtin(_ \/ _). 6014arith_builtin(xor(_,_)). 6015arith_builtin(_ >> _). 6016arith_builtin(_ << _). 6017arith_builtin(setbit(_,_)). 6018arith_builtin(getbit(_,_)). 6019arith_builtin(clrbit(_,_)). 6020arith_builtin(sin(_)). 6021arith_builtin(cos(_)). 6022arith_builtin(tan(_)). 6023arith_builtin(atan(_,_)). 6024arith_builtin(asin(_)). 6025arith_builtin(acos(_)). 6026arith_builtin(atan(_)). 6027arith_builtin(exp(_)). 6028arith_builtin(ln(_)). 6029arith_builtin(sqrt(_)). 6030arith_builtin(pi). 6031arith_builtin(e). 6032 6033% These are also "builtin" arithmetic functions. 6034% - they have their own inlining transformation 6035% - they are always qualified with sepia_kernel:... 6036inlined_arith_builtin(sum(_)). 6037inlined_arith_builtin(min(_)). 6038inlined_arith_builtin(max(_)). 6039 6040 6041:- export peval/4. 6042peval(R, X, Code, NextCode) :- 6043 trans_expr(X, R, Code, NextCode). 6044 6045 6046% 6047% subscript(+Matrix, +IndexList, ?Element) 6048% 6049subscript(Mat, Index, X, M) :- 6050 var(Index), !, 6051 ( get_flag(coroutine,on) -> 6052 suspend(subscript(Mat, Index, X, M), 2, Index->inst) 6053 ; 6054 error(4, subscript(Mat,Index,X), M) 6055 ). 6056subscript(Mat, [], X, _M) :- !, X = Mat. 6057subscript(Mat, [IExpr|IExprs], X, M) :- !, 6058 subscript3(Mat, IExpr, X, M, IExprs). 6059subscript(Mat, Index, X, M) :- 6060 error(5, subscript(Mat,Index,X), M). 6061 6062 subscript3(Mat, IExpr, X, M, IExprs) :- 6063 var(Mat), !, 6064 ( get_flag(coroutine,on) -> 6065 suspend(subscript(Mat,[IExpr|IExprs],X,M), 2, Mat->inst) 6066 ; 6067 error(4, subscript(Mat,[IExpr|IExprs],X), M) 6068 ). 6069 subscript3(Mat, IExpr, X, M, IExprs) :- 6070 compound(Mat), !, 6071 subscript1(Mat, IExpr, X, M, IExprs). 6072 subscript3(Mat, IExpr, X, M, IExprs) :- 6073 is_handle(Mat), !, 6074 ( IExprs = [] -> 6075 eval(IExpr, I, M), 6076 xget(Mat, I, X) 6077 ; 6078 error(6, subscript(Mat,[IExpr|IExprs],X), M) 6079 ). 6080 subscript3(Mat, IExpr, X, M, IExprs) :- 6081 string(Mat), !, 6082 ( IExprs = [] -> 6083 eval(IExpr, I, M), 6084 string_code(Mat, I, X) 6085 ; 6086 error(6, subscript(Mat,[IExpr|IExprs],X), M) 6087 ). 6088 subscript3(Mat, IExpr, X, M, IExprs) :- 6089 error(5, subscript(Mat,[IExpr|IExprs],X), M). 6090 6091 subscript1(Mat, IExpr, X, M, IExprs) :- integer(IExpr), !, 6092 arg(IExpr, Mat, Row), 6093 subscript(Row, IExprs, X, M). 6094 subscript1(Mat, Min..Max, Xs, M, IExprs) :- -?-> !, 6095 eval(Min, Imin, M), 6096 eval(Max, Imax, M), 6097 subscript2(Imin, Imax, Mat, IExprs, Xs, M). 6098% code for returning sub-arrays 6099% Offset is Imin-1, 6100% N is Imax-Offset, 6101% ( N >= 0 -> 6102% functor(Xs, [], N), 6103% ( foreacharg(X,Xs,J), param(Offset,Mat,IExprs,M) do 6104% I is J+Offset, 6105% arg(I, Mat, Row), 6106% subscript(Row, IExprs, X, M) 6107% ) 6108% ; 6109% error(6, subscript(Mat,[Min..Max|IExprs],Xs), M) 6110% ). 6111 subscript1(Mat, IExpr, X, M, IExprs) :- 6112 eval(IExpr, I, M), 6113 arg(I, Mat, Row), 6114 subscript(Row, IExprs, X, M). 6115 6116 subscript2(Imin, Imax, Mat, IExprs, Xs, M) :- 6117 ( Imin =< Imax -> 6118 Xs = [X|Xs0], 6119 +(Imin, 1, Imin1), 6120 arg(Imin, Mat, Row), 6121 subscript(Row, IExprs, X, M), 6122 subscript2(Imin1, Imax, Mat, IExprs, Xs0, M) 6123 ; 6124 Xs = [] 6125 ). 6126 6127 6128% Inlining for subscript/3: try to flatten 6129% arithmetic expressions within the index list 6130 6131:- inline(subscript/3, t_subscript/2). 6132t_subscript(subscript(Mat, IndexList, Res), Code) :- 6133 trans_index_list(IndexList, EvalIndexList, Code, Code0), 6134 Code \== Code0, % prevent looping 6135 Code0 = sepia_kernel:subscript(Mat, EvalIndexList, Res). 6136 6137 trans_index_list([E|Es], RRs, Code0, Code) ?- !, 6138 RRs = [R|Rs], 6139 trans_index(E, R, Code0, Code1), 6140 trans_index_list(Es, Rs, Code1, Code). 6141 trans_index_list(VarNilJunk, VarNilJunk, Code, Code). 6142 6143 trans_index(From..To, R, Code0, Code) ?- !, 6144 R = EvalFrom..EvalTo, 6145 trans_expr(From, EvalFrom, Code0, Code1), 6146 trans_expr(To, EvalTo, Code1, Code). 6147 trans_index(E, R, Code0, Code) :- 6148 trans_expr(E, R, Code0, Code). 6149 6150 6151flatten_array(Array, List) :- 6152 var(Array), 6153 !, 6154 error(4, flatten_array(Array, List)). 6155flatten_array(Array, List) :- 6156 compound(Array), 6157 functor(Array, [], N), 6158 !, 6159 flatten_array(Array, N, List, []). 6160flatten_array(Array, List) :- 6161 error(5, flatten_array(Array, List)). 6162 6163 flatten_array(_Array, 0, List, List0) :- !, 6164 List = List0. 6165 flatten_array(Array, I, List, List0) :- 6166 succ(I0, I), 6167 arg(I, Array, X), 6168 flatten_array(X, List1, List0), 6169 flatten_array(Array, I0, List, List1). 6170 6171 flatten_array(Array, List, List0) :- 6172 compound(Array), 6173 functor(Array, [], N), 6174 !, 6175 flatten_array(Array, N, List, List0). 6176 flatten_array(X, [X|List0], List0). 6177 6178 6179 6180%---------------------------------------------------------------- 6181% Other inlining optimisations 6182%---------------------------------------------------------------- 6183 6184t_bips(T =.. [F|Args], Goal, _) :- -?-> % =.. /2 6185 atom(F), proper_list(Args), !, 6186 Term =.. [F|Args], 6187 Goal = (T=Term). 6188t_bips(setarg(Path,T,X), Goal, _) :- -?-> % setarg/3 6189 Path = [_|_], 6190 proper_path(Path,AB,C), !, 6191 ( AB=[] -> Goal = setarg(C,T,X) 6192 ; Goal = (arg(AB,T,S),setarg(C,S,X)) 6193 ). 6194 6195 6196 % Auxiliaries 6197 6198 proper_list([]) :- -?-> true. 6199 proper_list([_|L]) :- -?-> proper_list(L). 6200 6201 proper_path([A],AB,C) :- -?-> !, 6202 AB=[], C=A. 6203 proper_path([A|BC], AB, C) :- -?-> 6204 AB=[A|B], 6205 proper_path(BC,B,C). 6206 6207 6208% The inline declarations should be after the definition of t_bips/3 6209% to avoid attempted inlining of the calls inside t_bips/3 6210 6211:- inline((=..)/2, t_bips/3). 6212:- inline(setarg/3, t_bips/3). 6213:- inline(call_priority/2, inline_calls/3). 6214:- inline(subcall/2, inline_calls/3). 6215%:- inline((not)/1, inline_calls/3). 6216%:- inline((\+)/1, inline_calls/3). 6217:- inline(call_explicit/2, inline_calls/3). 6218:- inline((:)/2, inline_calls/3). % never used, just set the flag 6219 6220%---------------------------------------------------------------- 6221% Loop constructs 6222%---------------------------------------------------------------- 6223 6224:- export (do)/2. 6225:- export (do)/3. 6226:- export t_do/5. 6227:- export foreachelem_next/7. 6228:- export foreachelem_next/8. 6229:- export multifor_next/7. 6230:- export multifor_init/8. 6231:- tool((do)/2, (do)/3). 6232:- inline((do)/2, t_do/5). 6233:- set_flag(do/3, trace_meta, on). 6234 6235:- local store(name_ctr). 6236 6237%---------------------------------------------------------------------- 6238% Definition for metacall 6239%---------------------------------------------------------------------- 6240 6241do(Specs, LoopBody, M) :- 6242 get_specs(Specs, Firsts, BaseHead, PreGoals, RecHead, AuxGoals, RecCall, _Locals, _Name, M), 6243 !, 6244 ( AuxGoals = true -> BodyGoals = LoopBody 6245 ; BodyGoals = (AuxGoals,LoopBody) ), 6246 call(PreGoals)@M, 6247 forallc(Firsts, body(RecHead,BodyGoals,RecCall), BaseHead, M). 6248do(Specs, LoopBody, M) :- 6249 error(123, do(Specs, LoopBody), M). 6250 6251 forallc(Args, _BodyTemplate, BaseHead, _M) :- 6252 copy_term(BaseHead, Copy, _), 6253 Copy = Args, true, !. 6254 forallc(Args, BodyTemplate, BaseHead, M) :- 6255 copy_term(BodyTemplate, Copy, _), 6256 Copy = body(Args, Goal, RecArgs), 6257 call(Goal)@M, 6258 forallc(RecArgs, BodyTemplate, BaseHead, M). 6259 6260 6261%---------------------------------------------------------------------- 6262% Compilation 6263%---------------------------------------------------------------------- 6264 6265/**** REMEMBER TO UPDATE annotated_term used in raw form by expand_macros 6266 **** and friends when changing the definition here 6267 ****/ 6268:- export struct(annotated_term( 6269 term, % var, atomic or compound 6270 type, % atom 6271 file, % atom 6272 line, % integer 6273 from, % integer 6274 to % integer 6275 % may be extended in future 6276 )). 6277 6278 6279t_do((Specs do LoopBody), NewGoal, AnnDoLoop, AnnNewGoal, M) :- 6280 annotated_arg(2, AnnDoLoop, AnnLoopBody), 6281 get_specs(Specs, Firsts, Lasts, PreGoals, RecHeadArgs, AuxGoals, RecCallArgs, LocalVars, Name, M), 6282 !, 6283 % expand body recursively 6284 tr_goals_annotated(LoopBody, AnnLoopBody, LoopBody1, AnnLoopBody1, M), 6285% printf("Local vars: %w / %vw%n", [LocalVars, LocalVars]), 6286% printf("Loop body: %Vw%n", [LoopBody1]), 6287 check_singletons(LoopBody1, LocalVars), 6288 length(Lasts, Arity), 6289 aux_pred_name(M, Arity, Name), 6290 FirstCall =.. [Name|Firsts], % make replacement goal 6291 transformed_annotate(FirstCall, AnnDoLoop, AnnFirstCall), 6292 transformed_annotate(PreGoals, AnnDoLoop, AnnPreGoals), 6293 flatten_and_clean(PreGoals, FirstCall, AnnPreGoals, AnnFirstCall, 6294 NewGoal, AnnNewGoal), 6295 BaseHead =.. [Name|Lasts], % make auxiliary predicate 6296 RecHead =.. [Name|RecHeadArgs], 6297 RecCall =.. [Name|RecCallArgs], 6298 transformed_annotate(AuxGoals, AnnDoLoop, AnnAuxGoals), 6299 transformed_annotate(RecCall, AnnDoLoop, AnnRecCall), 6300 transformed_annotate(RecHead, AnnDoLoop, AnnRecHead), 6301 tr_goals_annotated(AuxGoals, AnnAuxGoals, AuxGoals1, AnnAuxGoals1, M), 6302 inherit_annotation((AnnAuxGoals1,AnnLoopBody1), AnnDoLoop, AnnRecCall0), 6303 flatten_and_clean((AuxGoals1,LoopBody1), RecCall, AnnRecCall0, 6304 AnnRecCall, BodyGoals, AnnBodyGoals), 6305 BHClause = (BaseHead :- true, !), 6306 RHClause = (RecHead :- BodyGoals), 6307 Directive = (?- set_flag(Name/Arity, auxiliary, on)), 6308 Code = [ 6309 BHClause, 6310 RHClause, 6311 Directive 6312 ], 6313 6314 (nonvar(AnnDoLoop) -> 6315 % Use anonymous variables in the base clause to avoid singleton warnings 6316 transformed_annotate_anon(BHClause, AnnDoLoop, AnnBHClause), 6317 transformed_annotate(Directive, AnnDoLoop, AnnDirective), 6318 inherit_annotation((AnnRecHead :- AnnBodyGoals), AnnDoLoop, AnnRHClause), 6319 /* create a annotated list of Code [ 6320 AnnBHClause, 6321 AnnRHClause, 6322 AnnDirective 6323 ], */ 6324 inherit_annotation([AnnBHClause|AnnCode1], AnnDoLoop, AnnCode), 6325 inherit_annotation([AnnRHClause|AnnCode2], AnnDoLoop, AnnCode1), 6326 inherit_annotation([AnnDirective|AnnCode3], AnnDoLoop, AnnCode2), 6327 inherit_annotation([], AnnDoLoop, AnnCode3) 6328 ; 6329 true 6330 ), 6331% printf("Creating auxiliary predicate %w\n", Name/Arity), 6332% write_clauses(Code), 6333% writeclause(?- NewGoal), 6334 copy_term((Code,AnnCode), (CodeCopy,AnnCodeCopy), _),% strip attributes 6335 nested_compile_term_annotated(CodeCopy,AnnCodeCopy)@M. 6336t_do(Illformed, _, _, _, M) :- 6337 error(123, Illformed, M). 6338 6339 aux_pred_name(_Module, _Arity, Name) :- nonvar(Name). 6340 aux_pred_name(Module, Arity, Name) :- var(Name), 6341 store_inc(name_ctr, Module), 6342 store_get(name_ctr, Module, I), 6343 concat_atom([do__,I], Name0), 6344 ( nested_compile_load_flag(all), is_predicate(Name0/Arity)@Module -> 6345 % Avoid name clashes (should only happen when a .eco file 6346 % has been loaded into this module earlier) 6347 aux_pred_name(Module, Arity, Name) 6348 ; 6349 % No name clash: ok. 6350 % Name clash, but not loading: use same name to get reproducible 6351 % .eco files when using compile(..., [output:eco,load:none]) 6352 Name = Name0 6353 ). 6354 6355 6356 write_clauses([]). 6357 write_clauses([C|Cs]) :- 6358 writeclause(C), 6359 write_clauses(Cs). 6360 6361 :- mode flatten_and_clean(?, ?, ?, ?, -, -). 6362 flatten_and_clean(G, Gs, AG, AGs, (G,Gs), AFG) :- var(G), !, 6363 inherit_annotation((AG,AGs), AG, AFG). 6364 flatten_and_clean(true, Gs, _AG, AGs, Gs, AGs) :- !. 6365 flatten_and_clean((G1,G2), Gs0, AG, AGs0, Gs, AGs) :- 6366 !, 6367 annotated_match(AG, (AG1,AG2)), 6368 flatten_and_clean(G1, Gs1, AG1, AGs1, Gs, AGs), 6369 flatten_and_clean(G2, Gs0, AG2, AGs0, Gs1, AGs1). 6370 flatten_and_clean(G, Gs, AG, AGs, (G,Gs), AFG) :- 6371 inherit_annotation((AG,AGs), AG, AFG). 6372 6373reset_name_ctr(Module) :- 6374 store_set(name_ctr, Module, 0). 6375 6376%---------------------------------------------------------------------- 6377% get_spec defines the meaning of each specifier 6378%---------------------------------------------------------------------- 6379 6380:- mode get_specs(?,-,-,-,-,-,-,-,-,+). 6381get_specs(Specs, Firsts, Lasts, Pregoals, RecHead, AuxGoals, RecCall, Locals, Name, M) :- 6382 nonvar(Specs), 6383 get_specs(Specs, Firsts, [], Lasts, [], Pregoals, true, RecHead, [], AuxGoals, true, RecCall, [], Locals, [], Name, M). 6384 6385:- mode get_specs(+,-,+,-,+,-,+,-,+,-,+,-,+,-,+,?,+). 6386get_specs((Specs1,Specs2), Firsts, Firsts0, Lasts, Lasts0, Pregoals, Pregoals0, RecHead, RecHead0, AuxGoals, AuxGoals0, RecCall, RecCall0, Locals, Locals0, Name, M) :- !, 6387 get_specs(Specs1, Firsts, Firsts1, Lasts, Lasts1, Pregoals, Pregoals1, RecHead, RecHead1, AuxGoals, AuxGoals1, RecCall, RecCall1, Locals, Locals1, Name, M), 6388 get_specs(Specs2, Firsts1, Firsts0, Lasts1, Lasts0, Pregoals1, Pregoals0, RecHead1, RecHead0, AuxGoals1, AuxGoals0, RecCall1, RecCall0, Locals1, Locals0, Name, M). 6389get_specs(Spec, Firsts, Firsts0, Lasts, Lasts0, Pregoals, Pregoals0, RecHead, RecHead0, AuxGoals, AuxGoals0, RecCall, RecCall0, Locals, Locals0, Name, M) :- 6390 get_spec(Spec, Firsts, Firsts0, Lasts, Lasts0, Pregoals, Pregoals0, RecHead, RecHead0, AuxGoals, AuxGoals0, RecCall, RecCall0, Locals, Locals0, Name, M). 6391 6392:- mode get_spec(+,-,+,-,+,-,+,-,+,-,+,-,+,-,+,?,+). 6393get_spec(loop_name(Name), 6394 Firsts, Firsts, 6395 Lasts, Lasts, 6396 Pregoals, Pregoals, 6397 RecHeads, RecHeads, 6398 Goals, Goals, 6399 RecCalls, RecCalls, 6400 Locals, Locals, 6401 Name, _Module 6402 ) :- atom(Name), !. 6403get_spec(foreach(E,List), 6404 [List|Firsts], Firsts, 6405 [[]|Lasts], Lasts, 6406 Pregoals, Pregoals, 6407 [[E|T]|RecHeads], RecHeads, 6408 Goals, Goals, 6409 [T|RecCalls], RecCalls, 6410 [E|Locals], Locals, 6411 _Name, _Module 6412 ) :- !. 6413get_spec(foreacharg(A,Struct), 6414 [Struct,1,N1|Firsts], Firsts, 6415 [_,I0,I0|Lasts], Lasts, 6416 (arity(Struct,N),+(N,1,N1),Pregoals), Pregoals, 6417 [S,I0,I2|RecHeads], RecHeads, 6418 (+(I0,1,I1),arg(I0,S,A),Goals), Goals, 6419 [S,I1,I2|RecCalls], RecCalls, 6420 [A|Locals], Locals, 6421 _Name, _Module 6422 ) :- !. 6423get_spec(foreacharg(A,Struct,I), 6424 [Struct,1,N1|Firsts], Firsts, 6425 [_,I,I|Lasts], Lasts, 6426 (arity(Struct,N),+(N,1,N1),Pregoals), Pregoals, 6427 [S,I,I2|RecHeads], RecHeads, 6428 (+(I,1,I1),arg(I,S,A),Goals), Goals, 6429 [S,I1,I2|RecCalls], RecCalls, 6430 [A,I|Locals], Locals, 6431 _Name, _Module 6432 ) :- !. 6433get_spec(foreachelem(Elem,Array), 6434 [1,Array,[]|Firsts], Firsts, 6435 [_,[],_|Lasts], Lasts, 6436 (is_array(Array),Pregoals), Pregoals, 6437 [I,Arr,Stack|RecHeads], RecHeads, 6438 (sepia_kernel:foreachelem_next(I,Arr,Stack,I1,Arr1,Stack1,Elem),Goals), Goals, 6439 [I1,Arr1,Stack1|RecCalls], RecCalls, 6440 [Elem|Locals], Locals, 6441 _Name, _Module 6442 ) :- !. 6443get_spec(foreachelem(Elem,Array,Idx), 6444 [1,Array,[]|Firsts], Firsts, 6445 [_,[],_|Lasts], Lasts, 6446 (is_array(Array),Pregoals), Pregoals, 6447 [I,Arr,Stack|RecHeads], RecHeads, 6448 (sepia_kernel:foreachelem_next(I,Arr,Stack,I1,Arr1,Stack1,Elem,Idx),Goals), Goals, 6449 [I1,Arr1,Stack1|RecCalls], RecCalls, 6450 [Elem,Idx|Locals], Locals, 6451 _Name, _Module 6452 ) :- !. 6453get_spec(foreachindex(Idx,Array), 6454 [1,Array,[]|Firsts], Firsts, 6455 [_,[],_|Lasts], Lasts, 6456 (is_array(Array),Pregoals), Pregoals, 6457 [I,Arr,Stack|RecHeads], RecHeads, 6458 (sepia_kernel:foreachelem_next(I,Arr,Stack,I1,Arr1,Stack1,_,Idx),Goals), Goals, 6459 [I1,Arr1,Stack1|RecCalls], RecCalls, 6460 [Idx|Locals], Locals, 6461 _Name, _Module 6462 ) :- !. 6463get_spec(fromto(From,I0,I1,To), % accumulator pair needed 6464 [From,To|Firsts], Firsts, 6465 [L0,L0|Lasts], Lasts, 6466 Pregoals, Pregoals, 6467 [I0,L1|RecHeads], RecHeads, 6468 Goals, Goals, 6469 [I1,L1|RecCalls], RecCalls, 6470 [I0,I1|Locals], Locals, 6471 _Name, _Module 6472 ) :- nonground(To), !. 6473get_spec(fromto(From,I0,I1,To), % ground(To), only one arg 6474 [From|Firsts], Firsts, 6475 [To|Lasts], Lasts, 6476 Pregoals, Pregoals, 6477 [I0|RecHeads], RecHeads, 6478 Goals, Goals, 6479 [I1|RecCalls], RecCalls, 6480 [I0,I1|Locals], Locals, 6481 _Name, _Module 6482 ) :- !. 6483get_spec(count(I,FromExpr,To), % accumulator pair needed 6484 [From,To|Firsts], Firsts, 6485 [L0,L0|Lasts], Lasts, 6486 Pregoals, Pregoals0, 6487 [I0,L1|RecHeads], RecHeads, 6488 (+(I0,1,I),Goals), Goals, 6489 [I,L1|RecCalls], RecCalls, 6490 [I|Locals], Locals, 6491 _Name, _Module 6492 ) :- var(I), nonground(To), !, 6493 ( number(FromExpr) -> Pregoals = Pregoals0, From is FromExpr-1 6494 ; Pregoals = (From is FromExpr-1, Pregoals0) ). 6495get_spec(count(I,FromExpr,To), 6496 [From|Firsts], Firsts, 6497 [To|Lasts], Lasts, 6498 Pregoals, Pregoals0, 6499 [I0|RecHeads], RecHeads, 6500 (+(I0,1,I),Goals), Goals, 6501 [I|RecCalls], RecCalls, 6502 [I|Locals], Locals, 6503 _Name, _Module 6504 ) :- var(I), integer(To), !, 6505 ( number(FromExpr) -> Pregoals = Pregoals0, From is FromExpr-1 6506 ; Pregoals = (From is FromExpr-1, Pregoals0) ). 6507get_spec(for(I,From,To), 6508 Firsts, Firsts0, Lasts, Lasts0, Pregoals, Pregoals0, RecHead, RecHead0, 6509 AuxGoals, AuxGoals0, RecCall, RecCall0, Locals, Locals0, Name, Module 6510 ) :- !, 6511 get_spec(for(I,From,To,1), Firsts, Firsts0, Lasts, Lasts0, Pregoals, Pregoals0, 6512 RecHead, RecHead0, AuxGoals, AuxGoals0, RecCall, RecCall0, Locals, Locals0, Name, Module). 6513get_spec(for(I,FromExpr,To,Step), % Special cases, only 1 arg needed 6514 [From|Firsts], Firsts, 6515 [Stop|Lasts], Lasts, 6516 Pregoals, Pregoals0, 6517 [I|RecHeads], RecHeads, 6518 (+(I,Step,I1),Goals), Goals, 6519 [I1|RecCalls], RecCalls, 6520 [I|Locals], Locals, 6521 _Name, _Module 6522 ) :- var(I), 6523 integer(Step), 6524 number(To), 6525 ( number(FromExpr) -> 6526 From = FromExpr, 6527 Pregoals = Pregoals0, 6528 compute_stop(From,To,Step,Stop) % compute Stop at compile time 6529 ; Step == 1 -> 6530 Stop is To+1, 6531 Pregoals = (From is min(FromExpr,Stop), Pregoals0) 6532 ; Step == -1 -> 6533 Stop is To-1, 6534 Pregoals = (From is max(FromExpr,Stop), Pregoals0) 6535 ; 6536 fail % general case 6537 ), 6538 !. 6539get_spec(for(I,FromExpr,ToExpr,Step), % Step constant: 2 args needed 6540 [From,Stop|Firsts], Firsts, 6541 [L0,L0|Lasts], Lasts, 6542 Pregoals, Pregoals0, 6543 [I,L1|RecHeads], RecHeads, 6544 (+(I,Step,I1),Goals), Goals, 6545 [I1,L1|RecCalls], RecCalls, 6546 [I|Locals], Locals, 6547 _Name, _Module 6548 ) :- var(I), integer(Step), !, 6549 % We require for FromExpr and ToExpr that they are only bound to 6550 % numbers at runtime. If not, use: for(I,eval(F),eval(T)) do ... 6551 % We assume that ToExpr is always embedded in an expression 6552 % within StopGoal (otherwise explicit To is ToExpr needed!) 6553 compute_stop(From,ToExpr,Step,_,Stop,StopGoal), 6554 Pregoals1 = (StopGoal,Pregoals0), 6555 ( number(FromExpr) -> Pregoals = Pregoals1, From = FromExpr 6556 ; var(FromExpr) -> Pregoals = Pregoals1, From = FromExpr 6557 ; Pregoals = (From is FromExpr, Pregoals1) ). 6558get_spec(for(I,FromExpr,ToExpr,StepExpr), % Step variable: 3 args needed 6559 [From,Stop,Step|Firsts], Firsts, 6560 [L0,L0,_|Lasts], Lasts, 6561 Pregoals, Pregoals0, 6562 [I,L1,Step|RecHeads], RecHeads, 6563 (+(I,Step,I1),Goals), Goals, 6564 [I1,L1,Step|RecCalls], RecCalls, 6565 [I|Locals], Locals, 6566 _Name, _Module 6567 ) :- var(I), 6568 compute_stop(From,ToExpr,StepExpr,Step,Stop,StopGoal), 6569 !, 6570 Pregoals1 = (StopGoal,Pregoals0), 6571 ( number(FromExpr) -> Pregoals = Pregoals1, From = FromExpr 6572 ; var(FromExpr) -> Pregoals = Pregoals1, From = FromExpr 6573 ; Pregoals = (From is FromExpr, Pregoals1) ). 6574get_spec(multifor(Idx,From,To), 6575 Firsts, Firsts0, Lasts, Lasts0, Pregoals, Pregoals0, 6576 RecHead, RecHead0, AuxGoals, AuxGoals0, RecCall, RecCall0, Locals, Locals0, Name, Module 6577 ) :- !, 6578 get_spec(multifor(Idx,From,To,1), Firsts, Firsts0, Lasts, Lasts0, Pregoals, Pregoals0, 6579 RecHead, RecHead0, AuxGoals, AuxGoals0, RecCall, RecCall0, Locals, Locals0, Name, Module). 6580get_spec(multifor(Idx,From,To,Step), 6581 [RevFrom,RevTo,RevStep,RevStop|Firsts], Firsts, 6582 [RevStop,_,_,RevStop|Lasts], Lasts, 6583 Pregoals, Pregoals0, 6584 [RevIdx,RevTo,RevStep,RevStop|RecHeads], RecHeads, 6585 Goals, Goals0, 6586 [RevIdx1,RevTo,RevStep,RevStop|RecCalls], RecCalls, 6587 [Idx|Locals], Locals, 6588 _Name, _Module 6589 ) :- 6590 !, 6591 ( var(Idx) -> 6592 true 6593 ; 6594 list_length(Idx, N) 6595 ), 6596 Pregoals = ( 6597 % Check that the specifiers are valid. 6598 sepia_kernel:multifor_init(N, From, To, Step, RevFrom, RevTo, RevStep, RevStop), 6599 Pregoals0 6600 ), 6601 Goals = ( 6602 sepia_kernel:multifor_next(RevIdx, RevStop, RevTo, RevStep, RevIdx1, [], Idx), 6603 Goals0 6604 ). 6605get_spec('*'(Specs1, Specs2), 6606 Firsts, FirstsTail, 6607 Lasts, LastsTail, 6608 Pregoals, PregoalsTail, 6609 RecHeads, RecHeadsTail, 6610 Goals, GoalsTail, 6611 RecCalls, RecCallsTail, 6612 Locals, LocalsTail, 6613 _Name, Module 6614 ) :- 6615 !, 6616 get_specs(Specs1, 6617 Firsts1, [], 6618 Lasts1, [], 6619 Pregoals, Pregoals2, 6620 RecHeads1, [], 6621 Goals1, Goals2, 6622 RecCalls1, [], 6623 Locals, Locals2, 6624 _Name1, Module), 6625 get_specs(Specs2, 6626 Firsts2, [], 6627 Lasts2, [], 6628 Pregoals2, PregoalsTail1, 6629 RecHeads2, RecHeadsTail, 6630 Goals2, GoalsTail2, 6631 RecCalls2, [], 6632 Locals2, LocalsTail, 6633 _Name2, Module), 6634 length(Firsts1, N1), 6635 length(Firsts2, N2), 6636 % Firsts: Firsts1 | Firsts2 | Firsts2 6637 length(DummyFirsts1, N1), 6638 append(Firsts2, FirstsTail, FirstsTail2), 6639 append(Firsts2, FirstsTail2, FirstsTail1), 6640 append(DummyFirsts1, FirstsTail1, Firsts), 6641 % Lasts: Lasts1 | _ | Firsts2 6642 length(DummyLasts, N2), 6643 append(Firsts2, LastsTail, LastsTail2), 6644 append(DummyLasts, LastsTail2, LastsTail1), 6645 append(Lasts1, LastsTail1, Lasts), 6646 % Pregoals: Pregoals1, Pregoals2, Spec2 short-circuit check 6647 PregoalsTail1 = ( 6648 ( Firsts2 = Lasts2 -> 6649 DummyFirsts1 = Lasts1 6650 ; 6651 DummyFirsts1 = Firsts1 6652 ), 6653 PregoalsTail 6654 ), 6655 % RecHeads: RecHeads11 | Resets2 | RecHeads2 6656 length(Resets2, N2), 6657 length(RecHeads11, N1), 6658 append(Resets2, RecHeads2, RecHeadsTail1), 6659 append(RecHeads11, RecHeadsTail1, RecHeads), 6660 % Goals: ... 6661 length(RecCalls11, N1), 6662 length(RecCalls21, N2), 6663 % Lasts2 usually only in base head; need to rename... 6664 copy_term(Lasts2, Lasts21), 6665 Goals = ( RecHeads11 = RecHeads1, Goals1 ), 6666 GoalsTail2 = ( 6667 ( RecCalls2 = Lasts21 -> 6668 RecCalls11 = RecCalls1, 6669 RecCalls21 = Resets2 6670 ; 6671 RecCalls11 = RecHeads11, 6672 RecCalls21 = RecCalls2 6673 ), 6674 GoalsTail 6675 ), 6676 % RecCalls: RecCalls11 | Resets2 | RecCalls21 6677 append(RecCalls21, RecCallsTail, RecCallsTail2), 6678 append(Resets2, RecCallsTail2, RecCallsTail1), 6679 append(RecCalls11, RecCallsTail1, RecCalls), 6680 % Locals: Locals1 | Locals2 6681 true. 6682get_spec('>>'(Specs1, Specs2), 6683 Firsts, FirstsTail, 6684 Lasts, LastsTail, 6685 Pregoals, PregoalsTail, 6686 RecHeads, RecHeadsTail, 6687 Goals, GoalsTail, 6688 RecCalls, RecCallsTail, 6689 Locals, LocalsTail, 6690 _Name, Module 6691 ) :- 6692 !, 6693 get_specs(Specs1, 6694 Firsts1, FirstsTail1, 6695 Lasts1, [], 6696 Pregoals, PregoalsTail1, 6697 RecHeads1, RecHeadsTail1, 6698 Goals1, true, 6699 RecCalls1, [], 6700 Locals1, [], 6701 _Name1, Module), 6702 get_specs(Specs2, 6703 Firsts2, [], 6704 Lasts2, [], 6705 Pregoals2, true, 6706 RecHeads2, RecHeadsTail, 6707 Goals, GoalsTail2, 6708 RecCalls2, [], 6709 Locals, LocalsTail, 6710 _Name2, Module), 6711 length(RecCalls1, N1), 6712 length(Firsts2, N2), 6713 Arity is 2*N1 + N2, 6714 6715 % Set up the auxiliary predicate for iterating Spec1 6716 aux_pred_name(Module, Arity, NextPredName), 6717 append(Lasts1, Lasts2, LastsTail1), 6718 append(Lasts1, LastsTail1, Lasts11), 6719 NextBaseHead =.. [NextPredName | Lasts11], 6720 length(RecCalls11, N1), 6721 length(Firsts21, N2), 6722 append(RecCalls11, Firsts21, RecHeadsTail1), 6723 NextRecHead =.. [NextPredName | RecHeads1], 6724 append(RecCalls1, RecHeadsTail1, NextRecCalls1), 6725 NextRecCall =.. [NextPredName | NextRecCalls1], 6726 % Don't expand goals if goal_expansion is off 6727 global_flags(0,0,F), 6728 ( F /\ 16'00000800 =:= 0 -> 6729 Goals11 = Goals1, 6730 Pregoals21 = Pregoals2 6731 ; 6732 tr_goals(Goals1, Goals11, Module), 6733 tr_goals(Pregoals2, Pregoals21, Module) 6734 ), 6735 check_singletons(Firsts2 - Pregoals2, Locals1), 6736 NextExtraGoal = 6737 ( Firsts2 = Lasts2 -> 6738 NextRecCall 6739 ; 6740 RecCalls11 = RecCalls1, 6741 Firsts21 = Firsts2 6742 ), 6743 flatten_and_clean((Goals11, Pregoals21), NextExtraGoal, _, _, NextGoals, _), 6744 NextCode = [ 6745 (NextBaseHead :- !, true), 6746 (NextRecHead :- NextGoals), 6747 (?- set_flag(NextPredName/Arity, auxiliary, on)) 6748 ], 6749 %printf("Creating auxiliary predicate %w\n", NextPredName/Arity), 6750 %write_clauses(NextCode), 6751 copy_term(NextCode, NextCodeCopy, _), % strip attributes 6752 nested_compile_term(NextCodeCopy)@Module, 6753 6754 % Use a different copy of Firsts2 in PreGoals and Firsts from what 6755 % is used in RecHead and AuxGoals (for when goal expansion not 6756 % used). 6757 copy_term(Firsts2, Firsts22), 6758 % Firsts: Firsts11 | Firsts22 6759 length(Firsts11, N1), 6760 append(Firsts22, FirstsTail, FirstsTail2), 6761 append(Firsts11, FirstsTail2, Firsts), 6762 % Lasts: _ | Lasts2 6763 length(DummyLasts1, N1), 6764 append(Lasts2, LastsTail, LastsTail2), 6765 append(DummyLasts1, LastsTail2, Lasts), 6766 % Pregoals: Pregoals1, set up first iteration 6767 append(Firsts11, Firsts22, FirstsTail1), 6768 NextPreCall =.. [NextPredName | Firsts1], 6769 PregoalsTail1 = (NextPreCall, PregoalsTail), 6770 % RecHeads: RecHeads11 | RecHeads2 6771 length(RecHeads11, N1), 6772 append(RecHeads11, RecHeads2, RecHeads), 6773 % Goals: ... 6774 length(RecCalls21, N2), 6775 append(RecCalls11, RecCalls21, RecHeadsTail2), 6776 append(RecHeads11, RecHeadsTail2, NextGoalCalls1), 6777 NextGoalCall =.. [NextPredName | NextGoalCalls1], 6778 % Lasts2 usually only in base head; need to rename 6779 copy_term(Lasts2, Lasts21), 6780 GoalsTail2 = ( 6781 ( 6782 RecCalls2 = Lasts21 6783 -> 6784 NextGoalCall 6785 ; 6786 RecCalls11 = RecHeads11, 6787 RecCalls21 = RecCalls2 6788 ), 6789 GoalsTail 6790 ), 6791 % RecCalls: RecCalls11 | RecCalls21 6792 append(RecCalls21, RecCallsTail, RecCallsTail1), 6793 append(RecCalls11, RecCallsTail1, RecCalls), 6794 % Locals: Locals2 6795 true. 6796get_spec(Param, 6797 GlobsFirsts, Firsts, 6798 GlobsLasts, Lasts, 6799 Pregoals, Pregoals, 6800 GlobsRecHeads, RecHeads, 6801 Goals, Goals, 6802 GlobsRecCalls, RecCalls, 6803 GlobsLocals, Locals, 6804 _Name, _Module 6805 ) :- Param =.. [param|Globs], Globs = [_|_], !, 6806 append(Globs, Firsts, GlobsFirsts), 6807 append(Globs, Lasts, GlobsLasts), 6808 append(Globs, Locals, GlobsLocals), 6809 append(Globs, RecHeads, GlobsRecHeads), 6810 append(Globs, RecCalls, GlobsRecCalls). 6811 6812%:- mode compute_stop(?,?,?,-,-,-). % commented out because of compiler bug 6813compute_stop(From, To, Step, Step, Stop, Goal) :- var(Step), !, 6814 Goal = (Dist is max(sgn(Step)*(To-From+Step),0), 6815 Stop is From + sgn(Step)*(Dist - (Dist rem Step))). 6816compute_stop(From, To, 1, 1, Stop, Goal) :- !, 6817 Goal = (Stop is max(From, To+1)). 6818compute_stop(From, To, -1, -1, Stop, Goal) :- !, 6819 Goal = (Stop is min(From,To-1)). 6820compute_stop(From, To, Step, Step, Stop, Goal) :- integer(Step), Step > 1, !, 6821 Goal = (Dist is max(To-From+Step,0), 6822 Stop is From + Dist - (Dist rem Step)). 6823compute_stop(From, To, Step, Step, Stop, Goal) :- integer(Step), Step < 1, !, 6824 Goal = (Dist is max(From-To-Step,0), 6825 Stop is From - Dist + (Dist rem Step)). 6826compute_stop(From, To, StepExpr, Step, Stop, Goal) :- 6827 Goal = (Step is StepExpr, 6828 Dist is max(sgn(Step)*(To-From+Step),0), 6829 Stop is From + sgn(Step)*(Dist - (Dist rem Step))). 6830 6831 6832% Make a compute_stop/4 predicate, which computes the stop value on the 6833% spot in the general case, by using the code generated by compute_stop/6. 6834 6835:- inline(compute_stop/4, tr_compute_stop/2). 6836tr_compute_stop(compute_stop(From, To, Step, Stop), Goal) :- 6837 compute_stop(From, To, Step, _, Stop, Goal0), 6838 expand_goal(Goal0, Goal). 6839 6840:- pragma(expand). % required for the following clause! 6841compute_stop(From, To, Step, Stop) :- 6842 compute_stop(From, To, Step, Stop). 6843 6844 6845% 6846% For the foreachelem specifiers, the iteration is controlled by three 6847% arguments: The currently considered sub-array and its current index, 6848% and a stack of the pieces of the surrounding arrays (that are yet to 6849% be processed) in reverse order (i.e. outermost at the bottom). 6850% 6851% This scheme returns the elements in the correct order and gracefully 6852% handles "arrays" with "unorthodox" shape (e.g. different rows containing 6853% different numbers of columns, different parts of the "array" having 6854% different numbers of dimensions, etc.). 6855% 6856% The term [] is treated as an ordinary array element when encountered 6857% inside the arrays (consistent with dim/2), since empty dimensions are 6858% pretty useless in multi-dimensional arrays. Only a top-level [] is 6859% treated as the empty array. 6860% 6861 6862% foreachelem_next(+I,+SubArr,+Stack, -I1,-SubArr,-Stack1, -Elem[,-Index]) 6863% I and Arr refer to the current sub-array being traversed. 6864% ArrsIs is a stack of "continuations", i.e. array+index to go to 6865% once the current sub-array is exhausted. 6866 6867foreachelem_next(I, Arr, Stack, I1, Arr1, Stack1, Elem) :- 6868 arg(I, Arr, ArrOrElem), 6869 ( compound(ArrOrElem), functor(ArrOrElem, [], _) -> 6870 % nested array 6871 ( arity(Arr, I) -> 6872 foreachelem_next(1, ArrOrElem, Stack, I1, Arr1, Stack1, Elem) 6873 ; 6874 I2 is I+1, 6875 foreachelem_next(1, ArrOrElem, [[I2|Arr]|Stack], I1, Arr1, Stack1, Elem) 6876 ) 6877 ; 6878 ( arity(Arr, I) -> 6879 ( Stack = [[I1|Arr1]|Stack1] % pop, one level up 6880 ; Stack == [], Arr1 = [] % very last element 6881 ) 6882 ; 6883 I1 is I+1, Arr1 = Arr, Stack1 = Stack 6884 ), 6885 Elem = ArrOrElem 6886 ). 6887 6888% This variant returns the element index as well 6889% It doesn't do TRO on the stack in order to be able to construct the index. 6890foreachelem_next(I, Arr, Stack, I1, Arr1, Stack1, Elem, Index) :- 6891 arg(I, Arr, ArrOrElem), 6892 ( compound(ArrOrElem), functor(ArrOrElem, [], _) -> % nested array 6893 I2 is I+1, 6894 foreachelem_next(1, ArrOrElem, [[I2|Arr]|Stack], I1, Arr1, Stack1, Elem, Index) 6895 ; 6896 ( arity(Arr, I) -> % last in this leaf array 6897 pop(Stack, Stack1, I1, Arr1) 6898 ; 6899 I1 is I+1, Arr1 = Arr, Stack1 = Stack 6900 ), 6901 Elem = ArrOrElem, 6902 this_index(Stack, Index, [I]) 6903 ). 6904 6905 pop([], [], _, []). 6906 pop([[I0|Arr0]|Stack1], Stack, I, Arr) :- 6907 ( I0 > arity(Arr0) -> 6908 pop(Stack1, Stack, I, Arr) 6909 ; 6910 I=I0, Arr=Arr0, Stack=Stack1 6911 ). 6912 6913 this_index([], Index, Index). 6914 this_index([[NextI|_]|Stack], Is, Is0) :- 6915 I is NextI-1, 6916 this_index(Stack, Is, [I|Is0]). 6917 6918 6919% 6920% Auxiliaries for the multifor-specifier 6921% 6922 6923multifor_init(N, From, To, Step, RevFrom, RevTo, RevStep, RevStop) :- 6924 ( validate_multifor_args(N, From, To, Step, From1, To1, Step1) -> 6925 compute_multifor_stop_list(From1, To1, Step1, RevFrom, RevTo, RevStep, RevStop) 6926 ; 6927 length(Idx, N), 6928 error(123, multifor(Idx, From, To, Step)) 6929 ). 6930 6931 6932 % Checks the iteration specifier arguments for multifor, and expands 6933 % any shorthand integer specifiers into corresponding lists of the 6934 % appropriate length. Fails if anything is wrong. 6935validate_multifor_args(N, FromList0, ToList0, StepList0, 6936 FromList, ToList, StepList) :- 6937 % First check the inputs are valid, and try to determine the number 6938 % of iterators. 6939 ( integer(FromList0) -> 6940 FromList1 = FromList0 6941 ; is_list(FromList0) -> 6942 is_integer_expr_list_with_length(FromList0, FromList1, 0, N) 6943 ; 6944 nonvar(FromList0), 6945 FromList1 is FromList0, 6946 integer(FromList1) 6947 ), 6948 ( integer(ToList0) -> 6949 ToList1 = ToList0 6950 ; is_list(ToList0) -> 6951 is_integer_expr_list_with_length(ToList0, ToList1, 0, N) 6952 ; 6953 nonvar(ToList0), 6954 ToList1 is ToList0, 6955 integer(ToList1) 6956 ), 6957 ( integer(StepList0) -> 6958 StepList1 = StepList0, 6959 StepList0 =\= 0 6960 ; is_list(StepList0) -> 6961 is_nonzero_integer_expr_list_with_length(StepList0, StepList1, 0, N) 6962 ; 6963 nonvar(StepList0), 6964 StepList1 is StepList0, 6965 integer(StepList1) 6966 ), 6967 6968 % Fail if we still don't know how many iterators we have. 6969 nonvar(N), 6970 6971 % Must have at least one iterator. 6972 N > 0, 6973 6974 ( integer(FromList1) -> 6975 dupl(FromList1, N, FromList) 6976 ; 6977 FromList = FromList1 6978 ), 6979 ( integer(ToList1) -> 6980 dupl(ToList1, N, ToList) 6981 ; 6982 ToList = ToList1 6983 ), 6984 ( integer(StepList1) -> 6985 dupl(StepList1, N, StepList) 6986 ; 6987 StepList = StepList1 6988 ). 6989 6990is_integer_expr_list_with_length([], Xs, N, Length) :- -?-> 6991 Xs = [], 6992 Length = N. 6993is_integer_expr_list_with_length([X0 | Xs0], Xs, N, Length) :- -?-> 6994 Xs = [X1 | Xs1], 6995 ( integer(X0) -> 6996 X1 = X0 6997 ; 6998 nonvar(X0), 6999 X1 is X0, 7000 integer(X1) 7001 ), 7002 N1 is N + 1, 7003 is_integer_expr_list_with_length(Xs0, Xs1, N1, Length). 7004 7005is_nonzero_integer_expr_list_with_length([], Xs, N, Length) :- -?-> 7006 Xs = [], 7007 Length = N. 7008is_nonzero_integer_expr_list_with_length([X0 | Xs0], Xs, N, Length) :- -?-> 7009 Xs = [X1 | Xs1], 7010 ( integer(X0) -> 7011 X1 = X0 7012 ; 7013 nonvar(X0), 7014 X1 is X0, 7015 integer(X1) 7016 ), 7017 X1 =\= 0, 7018 N1 is N + 1, 7019 is_nonzero_integer_expr_list_with_length(Xs0, Xs1, N1, Length). 7020 7021 % Version of the length/2 predicate which only measures the length of an 7022 % existing list: it will not construct anything, and will fail if the 7023 % list is not of fixed length. 7024list_length(Xs, N) :- 7025 list_length(Xs, 0, N). 7026 7027list_length([], N0, N) :- -?-> 7028 N = N0. 7029list_length([_ | Xs], N0, N) :- -?-> 7030 N1 is N0 + 1, 7031 list_length(Xs, N1, N). 7032 7033 % Create a list by duplicating the given element the given number of 7034 % times. 7035dupl(X, N, List) :- 7036 ( N =< 0 -> 7037 List = [] 7038 ; 7039 List = [X | List1], 7040 N1 is N - 1, 7041 dupl(X, N1, List1) 7042 ). 7043 7044 7045 % compute_multifor_stop_list(FromList, ToList, StepList, 7046 % RevFromList, RevToList, RevStepList, RevStopList) 7047 % Computes the Stop list for the multifor iterator. 7048 % Given lists for From, To and Step, create reversed lists for From, 7049 % To, Step and Stop. Note that the To values in the reversed list are 7050 % adjusted based on the corresponding From and Step values, a la 7051 % compute_stop. The Stop values for the list as a whole are the Stop 7052 % value for the first element and the From values for the rest of the 7053 % elements. This corresponds to a value list one more than the 7054 % largest value list we want, which will be reached if we allow the 7055 % first value to be incremented beyond the corresponding To value. We 7056 % achieve this by dropping the first element of the To list (the last 7057 % one when reversed), and multifor_next/7 will do what we 7058 % want. Note that this also means that multifor_next/7 will 7059 % not look at the first value in the From list it is given, which 7060 % means the Stop list will work just as well, which means we don't 7061 % have to pass both the From and Stop list from one iteration of the 7062 % do loop to the next. 7063 % Note also that if compute_stop returns Stop the same as From for 7064 % any element of the lists, then we don't want to execute any 7065 % iterations of the do loop, so we return RevStopList the same as 7066 % RevFromList. 7067 % Example: 7068 % From = [1,1,1], To = [2,5,8] -> RevTo = [9,6], RevStop = [1,1,3] 7069compute_multifor_stop_list(FromList, ToList, StepList, 7070 RevFromList, RevToList, RevStepList, RevStopList) :- 7071 % Since the first element is treated specially, do that first. 7072 FromList = [From1 | FromTail], 7073 ToList = [To1 | ToTail], 7074 StepList = [Step1 | StepTail], 7075 compute_stop(From1, To1, Step1, Stop1), 7076 ( 7077 Stop1 \== From1, 7078/* No do loops in kernel.pl... 7079 ( 7080 foreach(From, FromTail), 7081 fromto([From1], RevFromTail, [From | RevFromTail], RevFromList), 7082 fromto([Stop1], RevStopTail, [From | RevStopTail], RevStopList), 7083 foreach(To, ToTail), 7084 fromto([], RevToTail, [Stop | RevToTail], RevToList), 7085 foreach(Step, StepTail), 7086 fromto([Step1], RevStepTail, [Step | RevStepTail], RevStepList) 7087 do 7088 compute_stop(From, To, Step, Stop), 7089 Stop \== From 7090 ) 7091*/ 7092 compute_stop_tail(FromTail, ToTail, StepTail, 7093 [From1], RevFromList, [Stop1], RevStopList, 7094 [], RevToList, [Step1], RevStepList) 7095 -> 7096 true 7097 ; 7098 % Don't want any iteration to occur. 7099 reverse(FromList, RevFromList), 7100 RevStopList = RevFromList, 7101 % Don't bother setting the rest? 7102 reverse(ToList, RevToList), 7103 reverse(StepList, RevStepList) 7104 ). 7105 7106compute_stop_tail([], [], [], 7107 RevFromList, RevFromList, RevStopList, RevStopList, 7108 RevToList, RevToList, RevStepList, RevStepList). 7109compute_stop_tail([From | FromTail], [To | ToTail], [Step | StepTail], 7110 RevFromList0, RevFromList, RevStopList0, RevStopList, 7111 RevToList0, RevToList, RevStepList0, RevStepList) :- 7112 compute_stop(From, To, Step, Stop), 7113 Stop \== From, 7114 compute_stop_tail(FromTail, ToTail, StepTail, 7115 [From | RevFromList0], RevFromList, 7116 [From | RevStopList0], RevStopList, 7117 [Stop | RevToList0], RevToList, 7118 [Step | RevStepList0], RevStepList). 7119 7120 7121 % Computes the next value to use for a multifor iterator. 7122 % Works with Step of either sign; assumes the "To" values have been 7123 % computed using compute_stop so that they match the "From" and "Step" 7124 % values properly. Allows the "From" or "To" lists to be one shorter 7125 % than the "Idx" list, which means the most significant value will be 7126 % allowed to increment indefinitely. 7127 % Actually, we call it with RevStop instead of RevFrom, which is 7128 % identical up to the (ignored) most significant value... 7129 % The accumulator pair FwdIdx0, FwdIdx and the final call to reverse/3 7130 % is independent of all this and represents just a folded-in reverse/3. 7131multifor_next([Idx0 | RevIdx0], RevFrom, RevTo, [Step | RevStep], RevIdx, 7132 FwdIdx0, FwdIdx) :- 7133 Idx is Idx0 + Step, 7134 ( RevTo = [Idx | RevTo1], RevFrom = [From | RevFrom1] -> 7135 RevIdx = [From | RevIdx1], 7136 multifor_next(RevIdx0, RevFrom1, RevTo1, RevStep, RevIdx1, [Idx0|FwdIdx0], FwdIdx) 7137 ; 7138 RevIdx = [Idx | RevIdx0], 7139 reverse(RevIdx0, FwdIdx, [Idx0|FwdIdx0]) 7140 ). 7141 7142 7143%---------------------------------------------------------------------- 7144% Definite clause grammars (DCG) 7145%---------------------------------------------------------------------- 7146 7147 7148:- inline('C'/3, tr_C/2). 7149tr_C('C'(XXs,X,Xs), XXs=[X|Xs]). 7150 7151'C'([Token|Rest], Token, Rest). 7152 7153 7154trdcg((Head --> Body), Clause, AnnDCG, AnnClause, Module) :- 7155 check_head(Head), 7156 same_annotation((AnnHead --> AnnBody), AnnDCG, 7157 (AnnNewHead :- AnnNewBody), AnnClause), 7158 head(Head, NewHead, AnnHead, AnnNewHead, Pushback, AnnPushback, S0, _, S1, Module), 7159 body(Body, NewBody, AnnBody, AnnNewBody0, S0, S1, Module), 7160 (Pushback = true 7161 -> 7162 Clause = (NewHead :- NewBody), 7163 AnnNewBody = AnnNewBody0 7164 ; 7165 Clause = (NewHead :- NewBody, Pushback), 7166 inherit_annotation((AnnNewBody0,AnnPushback), AnnNewBody0, AnnNewBody) 7167 7168 ). 7169 7170check_head(H) :- 7171 non_terminal(H, -126), 7172 (H = (A, P) 7173 -> 7174 non_terminal(A, -126), 7175 error_if_not_list(P, -126) 7176 ; 7177 true 7178 ). 7179 7180non_terminal(V, Where) :- 7181 (var(V) ; number(V) ; string(V)), 7182 !, 7183 throw(Where). 7184non_terminal(_, _). 7185 7186error_if_not_list(.(_,_), _) :- 7187 !. 7188error_if_not_list(_, Where) :- 7189 throw(Where). 7190 7191:- mode head(+, -, ?, -, -, -, -, -, -, ++). 7192head((Head , Pushbacklist), NewHead, AnnPHead, AnnNewHead, 7193 Pushback, AnnPushback, S0, S, S1, Module) :- 7194 !, 7195 goal(Head, NewHead, AnnHead, AnnNewHead, S0, S, _, Module), 7196 annotated_match(AnnPHead, (AnnHead,AnnPushbacklist)), 7197 body(Pushbacklist, Pushback, AnnPushbacklist, AnnPushback, S, S1, Module). 7198head(Head, NewHead, AnnHead, AnnNewHead, true, AnnTrue, S0, S, S, Module) :- 7199 inherit_annotation(true, AnnHead, AnnTrue), 7200 goal(Head, NewHead, AnnHead, AnnNewHead, S0, S, _, Module). 7201 7202body(X, Y, AnnX, AnnY, S0, S, Module) :- 7203 body(X, Y0, AnnX, AnnY0, S0, S, Last, Module), 7204 (Last == S0 -> % nothing was added 7205 app_eq(X, Y0, S0 = S, AnnY0, Y, AnnY) % take care of -> (for ;) 7206 ; 7207 S = Last, 7208 Y = Y0, 7209 AnnY = AnnY0 7210 ). 7211 7212body(X, Y, AnnX, AnnY, S0, S, Last, Module) :- 7213 var(X), 7214 !, 7215 goal(X, Y, AnnX, AnnY, S0, S, Last, Module). 7216body(( -?-> B), (-?-> NewB), AnnX, AnnY, S0, S1, Last, Module) :- 7217 !, 7218 same_annotation((-?-> AnnB), AnnX, (-?-> AnnNewB), AnnY), 7219 body(B, NewB, AnnB, AnnNewB, S0, S1, Last, Module). 7220body((B -> R), (NewB -> NewR), AnnX, AnnY, S0, S2, Last, Module) :- 7221 !, 7222 same_annotation((AnnB->AnnR), AnnX, (AnnNewB->AnnNewR), AnnY), 7223 body(B, NewB, AnnB, AnnNewB, S0, S1, S1, Module), 7224 body(R, NewR, AnnR, AnnNewR, S1, S2, Last, Module). 7225body((B ; R), (NewB ; NewR), AnnX, AnnY, S0, S, S, Module) :- 7226 !, 7227 same_annotation((AnnB ; AnnR), AnnX, (AnnNewB ; AnnNewR), AnnY), 7228 body(B, NewB, AnnB, AnnNewB, S0, S, Module), 7229 body(R, NewR, AnnR, AnnNewR, S0, S, Module). 7230body((B | R), (NewB ; NewR), AnnX, AnnY, S0, S, S, Module) :- 7231 !, 7232 same_annotation((AnnB | AnnR), AnnX, (AnnNewB ; AnnNewR), AnnY), 7233 body(B, NewB, AnnB, AnnNewB, S0, S, Module), 7234 body(R, NewR, AnnR, AnnNewR, S0, S, Module). 7235body((B , R), Goal, AnnX, AnnGoal, S0, S, Last, Module) :- 7236 !, 7237 annotated_match(AnnX, (AnnB, AnnR)), 7238 body(B, NewB, AnnB, AnnNewB, S0, S1, S1, Module), 7239 body(R, NewR, AnnR, AnnNewR, S1, S, Last, Module), 7240 app_goal(NewB, NewR, AnnNewB, AnnNewR, Goal, AnnGoal). 7241body((Iter do Body), Goal, AnnDo, AnnGoal, S0, S, Last, Module) :- 7242 !, 7243 S = Last, 7244 Goal = (fromto(S0, S1, S2, S),Iter do NewBody), 7245 same_annotation((AnnIter do AnnBody), AnnDo, (AnnNewIter do AnnNewBody), AnnGoal), 7246 transformed_annotate(fromto(S0,S1,S2,S), AnnDo, AnnFromTo), 7247 same_annotation(_IterAnn, AnnIter, (AnnFromTo,AnnIter), AnnNewIter), 7248 body(Body, NewBody, AnnBody, AnnNewBody, S1, S2, Module). 7249body(B, NewB, AnnB, AnnNewB, S0, S, Last, Module) :- 7250 goal(B, NewB, AnnB, AnnNewB, S0, S, Last, Module). 7251 7252:- mode goal(?, -, ?, -, ?, ?, ?, ++). % could be more precise? 7253goal(X, phrase(X,S0,S), AnnX, AnnPhraseX, S0, S, S, _) :- 7254 var(X), 7255 !, 7256 transformed_annotate(phrase(X,S0,S), AnnX, AnnPhraseX). 7257goal({Goal}, Goal, AnnGoal, GoalAnn, S0, _, S0, _) :- 7258 !, 7259 annotated_match(AnnGoal, {GoalAnn}). 7260goal(!, (S0=S,!), AnnCut, AnnCutGoal, S0, S, S, _) :- 7261 !, 7262 transformed_annotate(S0=S, AnnCut, AnnEq), 7263 inherit_annotation((AnnEq,AnnCut), AnnCut, AnnCutGoal). 7264goal([], true, AnnNil, AnnTrue, S0, _, S0, _) :- 7265 !, 7266 transformed_annotate(true, AnnNil, AnnTrue). 7267goal([H|T], Goal, AnnX, AnnGoal, S0, S, Last, Module) :- 7268 !, 7269 annotated_match(AnnX, [AnnH|AnnT]), 7270 goal(T, IGoal, AnnT, AnnIGoal, S1, S, Last, Module), 7271 ( IGoal = (S1 = X) -> % can be done at transformation time 7272 Goal = 'C'(S0,H,X), 7273 transformed_annotate(Goal, AnnH, AnnGoal) 7274 ; 7275 transformed_annotate('C'(S0,H,S1), AnnH, AnnC), 7276 app_goal('C'(S0,H,S1), IGoal, AnnC, AnnIGoal, Goal, AnnGoal) 7277 ). 7278goal(G, NewG, AnnG, AnnNewG, S0, S, S, _) :- 7279 non_terminal(G, -127), 7280 G =.. [F | L], 7281 append(L, [S0, S], NL), 7282 NewG =.. [F | NL], 7283 transformed_annotate(NewG, AnnG, AnnNewG). 7284 7285app_goal(true, G, _, AnnG, Goal, AnnGoal) :- -?-> !, Goal = G, AnnGoal = AnnG. 7286app_goal(G, true, AnnG, _, Goal, AnnGoal) :- -?-> !, Goal = G, AnnGoal = AnnG. 7287app_goal(A, B, AnnA, AnnB, (A, B), AnnGoal) :- 7288 inherit_annotation((AnnA,AnnB), AnnA, AnnGoal). 7289 7290%app_eq(Input, SoFar, Eq, AnnSoFar, Output, AnnOutput) 7291app_eq((_->_), (A -> B), Eq, AnnSoFar, (A -> B1), AnnOut) :- 7292 !, 7293 annotated_match(AnnSoFar, (AnnA -> AnnB)), 7294 transformed_annotate(Eq, AnnSoFar, AnnEq), 7295 app_goal(B, Eq, AnnB, AnnEq, B1, AnnB1), 7296 inherit_annotation((AnnA -> AnnB1), AnnSoFar, AnnOut). 7297app_eq(_, (A -> B), Eq, AnnSoFar, ((A -> B), Eq), AnnOut) :- !, 7298 transformed_annotate(Eq, AnnSoFar, AnnEq), 7299 inherit_annotation((AnnSoFar,AnnEq), AnnSoFar, AnnOut). 7300app_eq(_, Y, Eq, AnnY, Y1, AnnY1) :- 7301 transformed_annotate(Eq, AnnY, AnnEq), 7302 app_goal(Y, Eq, AnnY, AnnEq, Y1, AnnY1). 7303:- define_macro((-->)/2, trdcg/5, [clause,global]). 7304 7305%---------------------------------------------------------------------- 7306% Singleton warnings 7307%---------------------------------------------------------------------- 7308 7309check_singletons(Term, QuantifiedVars) :- 7310 get_flag(variable_names, check_singletons), 7311 collect_variables(QuantifiedVars^Term, [], Vars), 7312 sort(0, =<, Vars, SortedVars), 7313 SortedVars = [_X|Xs], 7314 check(_X, Xs, QuantifiedVars), 7315 fail. 7316check_singletons(_, _). 7317 7318:- mode collect_variables(?,?,-). 7319collect_variables(_X, Xs, [_X|Xs]) :- 7320 var(_X), !. 7321collect_variables(T, Xs, Xs) :- 7322 atomic(T), !. 7323collect_variables([T|Ts], Xs0, Xs) :- !, 7324 collect_variables(T, Xs0, Xs1), 7325 collect_variables(Ts, Xs1, Xs). 7326collect_variables(T, Xs0, Xs) :- 7327 T =.. [_|L], 7328 collect_variables(L, Xs0, Xs). 7329 7330check(_X, [], QV) :- 7331 warn(_X, QV). 7332check(_X, [_Y|Ys], QV) :- 7333 ( _X == _Y -> 7334 skip(_Y, Ys, QV) 7335 ; 7336 warn(_X, QV), 7337 check(_Y,Ys, QV) 7338 ). 7339 7340skip(_, [], _). 7341skip(_X, [_Y|Ys], QV) :- 7342 ( _X == _Y -> 7343 skip(_Y, Ys, QV) 7344 ; 7345 check(_Y,Ys, QV) 7346 ). 7347 7348warn(_X, QuantifiedVars) :- 7349 get_var_info(_X, name, Name), 7350 atom_string(Name, S), 7351 not substring(S, "_", 1), 7352 !, 7353 ( occurs(_X, QuantifiedVars) -> 7354 error(138, quantified(Name)) 7355 ; 7356 error(138, unquantified(Name)) 7357 ). 7358warn(_, _). 7359 7360 7361%----------------------------------------------------------------------- 7362% Include other files that contain parts of the kernel 7363%----------------------------------------------------------------------- 7364 7365:- include("events.pl"). 7366:- include("meta.pl"). 7367:- include("array.pl"). 7368:- include("pdb.pl"). 7369:- include("debug.pl"). 7370:- include("dynamic.pl"). 7371:- include("environment.pl"). 7372:- include("io.pl"). 7373:- include("setof.pl"). 7374:- include("tconv.pl"). 7375:- include("kernel_bips.pl"). 7376:- include("tracer.pl"). 7377 7378 7379%-------------------------------------------- 7380% List of deprecated builtins 7381%-------------------------------------------- 7382 7383:- export select/3. 7384select(Streams, Timeout, Ready) :- stream_select(Streams, Timeout, Ready). 7385 7386:- deprecated(abolish_op/2, "Use :- local op(0,...,...) to hide definition"). 7387:- deprecated(abolish_record/1, "Use erase_all/1"). 7388:- deprecated(alarm/1, "Use event_after/2"). 7389:- deprecated(autoload/2, ""). % no proper replacement yet 7390:- deprecated(autoload_tool/2, ""). % no proper replacement yet 7391%:- deprecated(b_external/1, "Write backtracking wrapper in ECLiPSe"). 7392%:- deprecated(b_external/2, "Write backtracking wrapper in ECLiPSe"). 7393:- deprecated(call_c/2, "Write an external predicate (see Embedding Manual)"). 7394:- deprecated(call_explicit/2, "Use Module:Goal"). 7395:- deprecated(char_int/2, "Use char_code/2"). 7396:- deprecated(cancel_after_event/1, "Use cancel_after_event/2"). 7397%:- deprecated(coroutine/0, ""). 7398:- deprecated(current_after_event/1, "Use current_after_events/1"). 7399:- deprecated(current_stream/3, "Use current_stream/1 and get_stream_info/3"). 7400:- deprecated(current_struct/1, "Use current_struct/2"). 7401:- deprecated(dbgcomp/0, ""). 7402:- deprecated(date/1, "Use local_time_string/3"). 7403:- deprecated(pause/0, "Use current_interrupt/2 and kill/2 (UNIX only)"). 7404:- deprecated(define_error/2, "Use atomic event names"). 7405:- deprecated(define_macro/3, "Use :- local macro(...) or :- export macro(...) or :- inline(...)"). 7406:- deprecated(delay/2, "Use suspend/3"). 7407:- deprecated(erase_macro/2, "Use :- local macro(...) to hide definition"). 7408:- deprecated(errno_id/2, "Use errno_id/1"). 7409:- deprecated(event_create/2, "Use event_create/3"). 7410:- deprecated(event_retrieve/2, "Use event_retrieve/3"). 7411:- deprecated(fail_if/1, "Use \\+ /1"). 7412%:- deprecated(flatten_array/2, "Use array_flat/3"). 7413:- deprecated(get_char/1, "Use iso:get_char/1 which returns an atom"). 7414:- deprecated(get_char/2, "Use iso:get_char/2 which returns an atom"). 7415:- deprecated(get_error_handler/3, "Use get_event_handler/3"). 7416:- deprecated(get_prompt/3, "Use get_stream_info/3"). 7417:- deprecated(get_timer/2, "Use after events"). 7418:- deprecated((global)/1, "Use export/1"). 7419:- deprecated(global_op/3, "Use :- export op(...)"). 7420:- deprecated(is_built_in/1, "Use current_built_in/1 or get_flag/3"). 7421:- deprecated(is_locked/1, "Use get_module_info/3"). 7422:- deprecated(lib/2, "Use lib/1"). 7423:- deprecated(local_record/1, "Use :- local record(...)"). 7424:- deprecated(lock/1, "Use lock for current module, or lock@Module"). 7425:- deprecated(lock/2, "Use lock_pass(Pass) for current module, or lock_pass(Pass)@Module"). 7426:- deprecated(make_array/1, "Use :- local variable(...) or :- local array(...)"). 7427:- deprecated(make_array/2, "Use :- local array(...)"). 7428:- deprecated(make_local_array/1, "Use :- local variable(...) or :- local array(...)"). 7429:- deprecated(make_local_array/2, "Use :- local array(...)"). 7430%:- deprecated(meta_bind/2, ""). % needed??? 7431:- deprecated(name/2, "Use string_list/2 with atom_string/2 or number_string/2"). 7432:- deprecated(nodbgcomp/0, ""). 7433:- deprecated(pathname/2, "Use pathname/3,4"). 7434:- deprecated(portray_goal/2, "Use portray_term/3"). 7435:- deprecated(reset_error_handler/1, "Use reset_event_handler/1"). 7436:- deprecated(retract_all/1, "Use retractall/1"). 7437%:- deprecated(schedule_woken/1, ""). 7438:- deprecated(select/3, "Use stream_select/3 or lists:select/3"). 7439:- deprecated(set_chtab/2, "Use local chtab declaration"). 7440:- deprecated(set_error_handler/2, "Use set_event_handler/2"). 7441:- deprecated(set_prompt/3, "Use set_stream_property/3"). 7442:- deprecated(set_suspension_priority/2,"Use set_suspension_data/3"). 7443:- deprecated(set_timer/2, "Use after events"). 7444:- deprecated(substring/4, "Use substring/5"). 7445:- deprecated(suffix/2, "Use pathname/4"). 7446:- deprecated(suspension_to_goal/3, "Use get_suspension_data/3"). 7447 7448 7449:- meta_predicate(( 7450 -?->(0), 7451 @(0,*), 7452 :(*,0), 7453 ','(0,0), 7454 ;(0,0), 7455 ->(0,0), 7456 *->(0,0), 7457 \+(0), 7458 ~(0), 7459 block(0,*,0), 7460 call(0), 7461 call(0,*), 7462 call_priority(0,*), 7463 catch(0,*,0), 7464 do(*,0), 7465 is(*,1), 7466 make_suspension(:,*,*), 7467 mutex(*,0), 7468 not(0), 7469 once(0), 7470 phrase(2,*), 7471 phrase(2,*,*), 7472 subcall(0,*), 7473 suspend(:,*,*), 7474 suspend(:,*,*,*), 7475 set_event_handler(*,/), % use 7476 set_interrupt_handler(*,/), % use 7477 tool(*,/) % use 7478 )). 7479 7480 7481%-------------------------------------------- 7482% optional extension dependent initialisation 7483%-------------------------------------------- 7484 7485:- 7486 set_error_handler(139, true/0), % suppress compiled messages 7487 set_flag(variable_names, check_singletons), 7488 7489 (extension(mps) -> 7490 ensure_loaded(library(mps)), 7491 lib(mps) 7492 ; 7493 true 7494 ), 7495 reset_error_handler(139). 7496 7497present_libraries(_, [], []). 7498present_libraries(Sys, [Lib|L], [SysLib|T]) :- 7499 substring(Lib, "lib_", 1), 7500 concat_string([Sys, "/", Lib], SysLib), 7501 exists(SysLib), 7502 !, 7503 present_libraries(Sys, L, T). 7504present_libraries(Sys, [_|L], T) :- 7505 present_libraries(Sys, L, T). 7506 7507 7508% set the eclipse temporary directory 7509?- make_array_(eclipse_tmp_dir, prolog, local, sepia_kernel), 7510 ( 7511 getenv("ECLIPSETMP",OsTDir), 7512 os_file_name(TDir, OsTDir) 7513 ; 7514 get_sys_flag(8, Arch), 7515 ( (Arch == "i386_nt" ; Arch == "x86_64_nt") -> 7516 ( 7517 getenv("TMP", OsTDir) 7518 ; 7519 getenv("TEMP", OsTDir) 7520 ; 7521 OsTDir = "C:\\WINDOWS\\Temp" 7522 ), 7523 os_file_name(TDir, OsTDir) 7524 ; 7525 TDir = "/tmp" 7526 ) 7527 ; 7528 getcwd(TDir) % last resort! 7529 ), 7530 existing_path(TDir, dir), % must be a directory 7531 !, % assume we have write permission! 7532 canonical_path_name(TDir, CanonicalTDir), 7533 setval(eclipse_tmp_dir, CanonicalTDir). 7534 7535% Now set the default library path 7536 7537?- getval(sepiadir, Sepiadir), 7538 read_directory(Sepiadir, "", Files, _), 7539 present_libraries(Sepiadir, Files, Path), 7540 concat_strings(Sepiadir, "/lib", Runlib), 7541 setval(library_path, [Runlib|Path]), 7542 setval(library, Runlib). % needed for load/2 7543 7544?- 7545 (extension(development) -> 7546 true 7547 ; 7548 lock_pass("Sepia") 7549 ). 7550