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: quintus.pl,v 1.16 2013/06/16 02:21:27 jschimpf Exp $ 27% ---------------------------------------------------------------------- 28 29/* 30 * SEPIA PROLOG SOURCE MODULE 31 */ 32 33/* 34 * IDENTIFICATION: quintus.pl 35 * 36 * DESCRIPTION: Quintus prolog compatibility package 37 * 38 * 39 * CONTENTS: 40 * 41 */ 42 43:- module(quintus). 44 45:- comment(categories, ["Compatibility"]). 46:- comment(summary, 'Quintus prolog compatibility package'). 47:- comment(author, 'Micha Meier, ECRC Munich'). 48:- comment(copyright, 'Cisco Systems, Inc'). 49:- comment(date, '$Date: 2013/06/16 02:21:27 $'). 50:- comment(desc, html(' 51 ECLiPSe includes a Quintus Prolog compatibility package to ease the 52 task of porting Quintus Prolog applications to ECLiPSe Prolog. This 53 package does not provide the user with a system completely compatible 54 to Quintus Prolog, however it provides most of the Quintus built-in 55 predicates, moreover some of the Quintus library predicates are 56 available in the ECLiPSe library. This package includes the C-Prolog 57 compatibility package (see Appendix A.6). 58 <P> 59 Please note that this appendix does not detail the functionality of 60 Quintus Prolog, refer to the Quintus Prolog documentation for this 61 information. 62 <P> 63 The effect of the compatibility library is local to the module where 64 it is loaded. For maximum compatibility, a Quintus program should 65 be wrapped in a separate module starting with a directive like 66 <PRE> 67 :- module(mymodule, [], quintus). 68 </PRE> 69 In this case, Eclipse-specific language constructs will not be available. 70 <P> 71 If the compatibility package is loaded into a standard module, e.g. like 72 <PRE> 73 :- module(mymixedmdule). 74 :- use_module(library(quintus)). 75 </PRE> 76 then Quintus and Eclipse language features can be used together. 77 However, ambiguities must be resolved explicitly and confusion may 78 arise from the different meaning of quotes in Eclipse vs Quintus-Prolog. 79 <P> 80 The following differences remain even with the compatibility package: 81 <DL> 82 <DT>expand_term/2 83 <DD>This predicate is dummy, since the ECLiPSe macro facility 84 works on every input term, provided that the flag 85 macro_expansion is set to on. 86 <DT>get0/2 87 <DD>This predicate is identical to get/2 in ECLiPSe. 88 <DT>help/1 89 <DD>This is the normal ECLiPSe help/1 predicate. 90 <DT>meta_predicate/1 91 <DD>This declaration does not cause passing of module information 92 in Quintus-style, as ECLiPSe\'s concept of meta predicates 93 differs substantially. The meta-predicates very likely have 94 to be modified manually to use ECLiPSe tools (see User Manual). 95 <DT>multifile/1 96 <DD>This is implemented by declaring the predicates as dynamic, so 97 to obtain more efficient programs it is better to put all 98 clauses of the same procedure into one file (or to concatenate 99 all files where multifile predicates occur). 100 <DT>predicate_property/2 101 <DD>The property interpreted is not provided. The property 102 exported is returned if the predicate is exported or global. 103 Use of get_flag/3 should be preferred. 104 <DT>prolog_flag/2, 3 105 <DD>There are some differences in the flags, as they are mostly 106 simulated with the ECLiPSe flags: 107 <UL> 108 <LI>not all the character escapes used in the Quintus Prolog 109 are available. 110 <LI>gc_margin is taken as the ECLiPSe flag gc_interval 111 (see Section 19.2) 112 <LI>setting gc_trace to on sets also gc to on 113 </UL> 114 <DT>public/1 115 <DD>synonym for export/1 116 <DT>statistics/0, 2 117 <DD>these predicates are slightly different than in Quintus, in 118 particular the meaning of the memory statistics is approximate, 119 and the output format is different. 120 <DT>ttyflush/0, ttyget/1, ttyget0/1, ttynl/0, ttyput/1, ttyskip/1, ttytab/1 121 <DD>these predicates work with the stdout stream 122 <DT>line_position/2 123 <DD>Not implemented. To perform sophisticated output formatting, 124 printf/2,3 or string streams can be used. 125 </DL> 126 The list below describes the syntax differences between 127 ECLiPSe and Quintus Prolog. The following properties of Quintus 128 Prolog are simulated by the compatibility package: 129 <UL> 130 <LI>single (resp. double) quote must be doubled between 131 single (resp. double) quote. 132 <LI>The symbol | (bar) is recognised as an alternative sign 133 for a disjunction and it acts as an infix operator. 134 <LI>the symbol | is not an atom 135 </UL> 136 The following Quintus properties are not simulated: 137 <UL> 138 <LI>a clause can not be ended by end of file. 139 <LI>signed numbers: explicitly positive numbers are structures. 140 <LI>a real with an exponent must have a floating point. 141 <LI>a space is allowed before the decimal point and the exponent sign. 142 <LI>the definition of the escape sequence is more extended 143 than in ECLiPSe. 144 <LI>spy/1 and nospy/1 accept as arguments lists, rather than 145 comma-separated terms like in ECLiPSe. 146 </UL> 147 ')). 148:- comment(see_also, [library(cio),library(cprolog),library(sicstus),library(swi), 149 library(multifile)]). 150 151:- reexport cio. 152:- reexport foreign. 153:- reexport multifile. 154 155% suppress deprecation warnings for reexported builtins 156:- pragma(deprecated_warnings(not_reexports)). 157 158:- reexport eclipse_language except 159 160 (\=)/2, % hide (e.g. for Press) 161% append/3, % in QP 3.6 162 delete/3, 163 gcd/3, 164% ground/1, % in QP 3.6 165 select/3, 166 memberchk/2, 167 maplist/3, 168 member/2, 169 (not)/1, 170 union/3, 171 eval/2, 172 pathname/2, 173 174 get/1, % redefined predicates 175 put/1, 176 put/2, 177 instance/2, 178 (abolish)/1, 179 arg/3, 180 (dynamic)/1, 181 display/1, 182 ensure_loaded/1, 183 erase/1, 184 name/2, 185 op/3, 186 recorda/3, 187 recordz/3, 188 recorded/3, 189 statistics/0, 190 statistics/2, 191 use_module/1, 192 use_module_body/2. 193 194 /* 195 op(_, xfx, (of)), % don't provide these 196 op(_, xfx, (with)), 197 op(_, xfy, (do)), 198 op(_, xfx, (@)), 199 op(_, fx, (-?->)), 200 op(_, fy, (not)), 201 op(_, fy, (spied)), 202 op(_, fx, (delay)), 203 macro((with)/2, _, _), 204 macro((of)/2, _, _). 205 */ 206 207:- export % temporary, while op/macros still global 208 op(0, xfx, (of)), 209 op(0, xfx, (with)), 210 op(0, xfy, (do)), 211 op(0, xfx, (@)), 212 op(0, fx, (-?->)), 213 op(0, fy, (not)), 214 op(0, fy, (spied)), 215 op(0, fx, (delay)), 216 macro((with)/2, (=)/2, []), 217 macro((of)/2, (=)/2, []). 218 219:- local 220 op(650, xfx, (@)). 221 222:- export 223 syntax_option(nl_in_quotes), 224 syntax_option(no_array_subscripts), 225 syntax_option(limit_arg_precedence), 226 syntax_option(doubled_quote_is_quote), 227 syntax_option(bar_is_no_atom), 228 syntax_option(bar_is_semicolon), 229 syntax_option(no_attributes), 230 syntax_option(no_curly_arguments), 231 syntax_option(blanks_after_sign), 232 syntax_option(float_needs_point), 233 234 chtab(0'\, symbol), % disable escape sequences 235 chtab(128, string_quote), % there must be some string_quote 236 chtab(0'", list_quote), 237 238 op(1150, fx, [(meta_predicate), (multifile), (discontiguous), (public), 239 (mode), 240 (dynamic), (initialization), (volatile)]). 241 242:- set_flag(macro_expansion, on). 243 244:- reexport 245 (.)/3, % to evaluate lists in arithmetic expressions 246 consult/1, 247 current_functor/2, 248 current_predicate/2, 249 db_reference/1, 250 erased/1, 251 fileerrors/0, 252 get/1, 253 get0/1, 254 heapused/1, 255 leash/1, 256 log10/2, 257 log/2, 258 nofileerrors/0, 259 primitive/1, 260 prompt/2, 261 put/1, 262 reconsult/1, 263 sh/0 264 from cprolog. 265 266:- reexport 267 op(_,_,_) 268 from cprolog. 269 270:- reexport numbervars. 271:- reexport format. 272 273:- export 274 (abolish)/1, 275 (abolish)/2, 276 absolute_file_name/2, 277 arg/3, 278 atom_chars/2, 279 break/0, 280 character_count/2, 281 current_input/1, 282 current_output/1, 283 current_key/2, 284 current_module/2, 285 display/1, 286 (dynamic)/1, 287 ensure_loaded/1, 288 erase/1, 289 expand_term/2, 290 flush_output/1, 291 gc/0, 292 get0/2, 293 incore/1, 294 instance/2, 295 is_digit/1, 296 is_lower/1, 297 is_upper/1, 298 line_count/2, 299 manual/0, 300 name/2, 301 no_style_check/1, 302 nogc/0, 303 nospyall/0, 304 number_chars/2, 305 op/3, 306 open_null_stream/1, 307 otherwise/0, 308 portray_clause/1, 309 predicate_property/2, 310 prolog_flag/2, 311 prolog_flag/3, 312 (public)/1, 313 put/2, 314 put_line/1, 315 recorda/3, 316 recorded/3, 317 recordz/3, 318 save/1, 319 set_input/1, 320 set_output/1, 321 source_file/1, 322 source_file/2, 323 statistics/0, 324 statistics/2, 325 stream_code/2, 326 stream_position/2, 327 stream_position/3, 328 style_check/1, 329 term_expansion/2, 330 trace/0, 331 ttyflush/0, 332 ttyget/1, 333 ttyget0/1, 334 ttynl/0, 335 ttyput/1, 336 ttyskip/1, 337 ttytab/1, 338 unix/1, 339 unknown/2, 340 use_module/1, 341 use_module/2, 342 version/0, 343 version/1. 344 345 346:- export 347 tr_lib/2. 348 349:- export 350 macro(library_directory/1, tr_lib/2, [clause]). 351 352tr_lib(L, L) :- 353 L = no_macro_expansion(library_directory(Path)), 354 atom_string(Path, PathS), 355 get_flag(library_path, P), 356 (member(PathS, P) -> 357 true 358 ; 359 append(P, [PathS], New), 360 set_flag(library_path, New) 361 ). 362 363%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 364 365:- system. % compiler directive to add the SYSTEM flag 366 367:- import 368 abolish_body/2, 369 abolish_op_body/3, 370 current_built_in_body/2, 371 current_op_body/4, 372 current_predicate_body/2, 373 dynamic_body/2, 374 ensure_loaded/2, 375 export_body/2, 376 get_bip_error/1, 377 get_flag_body/4, 378 get_pager/1, 379 global_body/2, 380 global_op_body/4, 381 import_body/2, 382 nospy_body/2, 383 printf_/8, 384 retract_all_body/2, 385 set_flag_body/4, 386 tool_/2, 387 untraced_call/2 388 from sepia_kernel. 389 390:- 391 tool((abolish)/1, q_abolish_body/2), 392 tool(incore/1, untraced_call/2), 393 tool(nospyall/0, nospyall_body/1), 394 tool(predicate_property/2, predicate_property_body/3), 395 tool(prolog_flag/2, prolog_flag_body/3), 396 tool(prolog_flag/3, prolog_flag_body/4), 397 tool((public)/1, public_body/2), 398 tool(op/3, op_body/4). 399 400 401%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 402% *** Loading Programs *** 403 404no_style_check(X) :- var(X), !, fail. 405no_style_check(single_var) :- 406 get_flag(variable_names, check_singletons) -> 407 set_flag(variable_names, on) 408 ; 409 true. 410no_style_check(discontiguous). 411no_style_check(multiple). 412no_style_check(all) :- 413 no_style_check(single_var). 414 415style_check(X) :- var(X), !, fail. 416style_check(single_var) :- set_flag(variable_names, check_singletons). 417style_check(discontiguous). 418style_check(multiple). 419style_check(all) :- 420 style_check(single_var). 421 422save(File) :- 423 printf(error, 'Saved states not supported: %w%n', [save(File)]). 424 425trace :- 426 printf(error, 'trace/0 only allowed as a toplevel command%n', []). 427 428break :- 429 toplevel:break. 430 431%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 432% *** Online help *** 433 434manual :- 435 get_flag(installation_directory, Sepiadir), 436 printf('To read the documentation, please open%n%s/doc/index.html%n', 437 [Sepiadir]). 438 439%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 440% *** Control *** 441 442otherwise. 443 444%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 445% *** I/O *** 446 447display(Term) :- 448 eclipse_language:display(stdout, Term). 449 450open_null_stream(null). 451flush_output(X) :- flush(X). 452set_input(Stream) :- set_stream(input, Stream). 453set_output(Stream) :- set_stream(output, Stream). 454current_input(Stream) :- get_stream(input, Stream). 455current_output(Stream) :- get_stream(output, Stream). 456 457source_file(File) :- 458 setof(X, P^(current_predicate(P), get_flag(P, source_file, X)), L), 459 member(File, L). 460 461source_file(Pred, File) :- 462 (var(Pred) -> 463 current_predicate(F/A) 464 ; 465 true 466 ), 467 functor(Pred, F, A), 468 get_flag(F/A, source_file, File). 469 470get0(S, T) :- get(S, T). 471 472put(S, T) :- 473 X is T, 474 eclipse_language:put(S, X). 475 476character_count(Stream, N) :- 477 at(Stream, N). 478 479stream_position(S, N) :- 480 at(S, N). 481 482stream_position(Stream, Old, New) :- 483 at(Stream, Old), 484 seek(Stream, New). 485 486ttyget0(X) :- get0(stdin, X). 487ttyget(X) :- get(stdin, X). 488ttyskip(X) :- skip(stdin, X). 489ttyput(X) :- put(stdout, X). 490ttynl :- nl(stdout). 491ttytab(N) :- tab(stdout, N). 492ttyflush :- 493 current_stream(S), 494 get_stream_info(S, device, tty), 495 get_stream_info(S, mode, write), 496 flush(S), 497 fail;true. 498 499portray_clause(Clause) :- 500 writeclause(Clause). 501 502line_count(Stream, Line1) :- 503 get_stream_info(Stream, line, Line), 504 Line1 is Line + 1. 505 506op_body(_, _, [], _) :- !. 507op_body(P, A, [O|L], M) :- 508 !, 509 op_body(P, A, O, M), 510 op_body(P, A, L, M). 511op_body(P, A, O, M) :- 512 global_op_body(P, A, O, M), 513 ( current_op_body(P, A, O, M) -> 514 true 515 ; 516 abolish_op_body(O, A, M) % remove the hiding local definition 517 ). 518 519%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 520% *** Arithmetic *** 521 522arith_exception_handler(_, integer(X,Y), _) :- !, 523 Y is integer(truncate(X)). 524arith_exception_handler(N, Culprit, Module) :- 525 error(default(N), Culprit, Module). 526 527:- set_event_handler(20, arith_exception_handler/3). 528 529 530%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 531% *** Term Conversion *** 532 533atom_chars(Atom, List) :- 534 var(Atom), 535 !, 536 string_list(String, List), 537 atom_string(Atom, String). 538atom_chars(Atom, List) :- 539 atom(Atom), 540 atom_string(Atom, String), 541 string_list(String, List). 542 543number_chars(Number, List) :- 544 var(Number), 545 !, 546 remove_leading_whtspaces(List, List0), 547 string_list(String, List0), 548 number_string(Number, String). 549number_chars(Number, List) :- 550 number_string(Number, String), 551 (var(List) -> 552 List0 = List 553 ; remove_leading_whtspaces(List, List0) 554 ), 555 string_list(String, List0). 556 557remove_leading_whtspaces([C|Cs], List) ?- 558 ((nonvar(C), is_white_space(C)) -> 559 remove_leading_whtspaces(Cs, List) 560 ; List = [C|Cs] 561 ). 562 563is_white_space(C) :- 564 % concat_string(['\t','\n','\r',' '], SWhtSpaces), 565 % string_list(SWhtSpaces, WhtSpaces), 566 % this assumes ASCII as character escapes are off by default 567 WhtSpaces = [9,10,13,32], 568 memberchk(C, WhtSpaces). 569 570 571name(Name, Codes) :- 572 var(Codes), 573 ( number(Name) -> 574 number_string(Name, String), 575 string_list(String, Codes) 576 ; atom(Name) -> 577 atom_string(Name, String), 578 string_list(String, Codes) 579 ; string(Name) -> % convenience extension 580 string_list(Name, Codes) 581 ; 582 error(5, name(Name, Codes)) 583 ). 584name(Name, Codes) :- 585 nonvar(Codes), 586 string_list(String, Codes), 587 ( number_string(Number, String) -> 588 Name = Number 589 ; 590 atom_string(Name, String) 591 ). 592 593 594arg(N, S, X) :- 595 integer(N), 596 1 =< N, N =< arity(S), 597 eclipse_language:arg(N, S, X). 598 599 600%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 601% *** Term Comparison *** 602 603%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 604% *** Environment *** 605 606predicate_property_body(Pred, Property, M) :- 607 var(Pred), 608 !, 609 (current_predicate_body(F/A, M); current_built_in_body(F/A, M)), 610 functor(Pred, F, A), 611 sepia_property(F/A, M, Property). 612predicate_property_body(Pred, Property, M) :- 613 functor(Pred, F, A), 614 A < 256, 615 sepia_property(F/A, M, Property). 616 617sepia_property(P, M, compiled) :- 618 get_flag_body(P, stability, static, M). 619sepia_property(P, M, dynamic) :- 620 get_flag_body(P, stability, dynamic, M). 621sepia_property(P, M, built_in) :- 622 get_flag_body(P, type, built_in, M). 623sepia_property(P, M, exported) :- 624 get_flag_body(P, visibility, V, M), 625 (V == exported; V == reexported) -> true. 626sepia_property(P, M, foreign) :- 627 get_flag_body(P, call_type, external, M). 628sepia_property(P, M, imported_from(Mi)) :- 629 get_flag_body(P, visibility, imported, M), 630 get_flag_body(P, definition_module, Mi, M). 631 632%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 633% *** Debugging *** 634 635nospyall_body(M) :- 636 nospy_body(_, M), 637 writeln('All spypoints removed'). 638 639unknown(Old, New) :- 640 (nonvar(Old) -> 641 error(5, unknown(Old, New)) 642 ; 643 (get_event_handler(68, fail/0, _) -> 644 Old = fail 645 ; 646 Old = trace 647 ), 648 (New == trace -> 649 reset_event_handler(68) 650 ; 651 New == fail -> 652 set_event_handler(68, fail/0) 653 ; 654 error(5, unknown(Old, New)) 655 ) 656 ). 657 658%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 659% *** Modules *** 660 661public_body([], _) :- !. 662public_body([Proc|Procs], M) :- 663 !, 664 globalize([Proc|Procs], M). 665public_body(Procs, M) :- 666 export_body(Procs, M). 667 668current_module(Module, File) :- 669 setof((M,F), P^(current_predicate(P), 670 get_flag(P, source_file, F), 671 get_flag(P, definition_module, M)), L), 672 member((Module,File), L). 673 674:- system_debug. 675%:- system. 676globalize([], _). 677globalize([Pred|Rest], M) :- 678 export_body(Pred, M), 679 globalize(Rest, M). 680 681:- tool(use_module/2, use_module_body/3). 682:- local use_module_body/2. 683:- tool(use_module/1, use_module_body/2). 684:- tool(ensure_loaded/1, use_module_body/2). 685 686use_module_body(F, L, M) :- 687 ensure_loaded(F, M), 688 (F = library(FM) -> 689 true 690 ; 691 FM = F 692 ), 693 import_list(L, FM, M). 694 695use_module_body(F, M) :- 696 ensure_loaded(F, M), 697 import_list(F, M). 698 699import_list([], _, _). 700import_list([Pred|L], F, M) :- 701 import_body((Pred from F), M), 702 import_list(L, F, M). 703 704import_list([], _). 705import_list([File|L], M) :- 706 !, 707 import1(File, M), 708 import_list(L, M). 709import_list(File, M) :- 710 import1(File, M). 711 712import1(library(File), M) :- 713 !, 714 import1(File, M). 715import1(File, M) :- 716 pathname(File, _, ModS), 717 atom_string(Module, ModS), 718 current_module(Module), 719 !, 720 import_body(Module, M). 721import1(_, _). 722 723 724%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 725% *** Dynamic Database *** 726 727q_abolish_body(Name/Arity, Module) :- 728 !, 729 abolish_body(Name/Arity, Module). 730q_abolish_body(:(Module, Spec), _) :- 731 !, 732 q_abolish_body(Spec, Module). 733q_abolish_body([], _) :- !. % wrong, but compatible 734q_abolish_body([Spec|T], Module) :- 735 !, 736 q_abolish_body(Spec, Module), 737 q_abolish_body(T, Module). 738q_abolish_body(Atom, Module) :- 739 atom(Atom), % this is wrong in Q2.0! 740 !, 741 ( 742 @(current_predicate(Atom/N),Module), 743 @(get_flag(Atom/N, definition_module, Module), Module), 744 abolish_body(Atom/N, Module), 745 fail 746 ; 747 true 748 ). 749q_abolish_body(Term, _) :- 750 error(5, abolish(Term)). 751 752:- tool((abolish)/2, abolish_body/3). 753abolish_body(Name, Arity, Module):- 754 q_abolish_body(Name/Arity, Module). 755 756:- tool((dynamic)/1, qdynamic_body/2). 757 758qdynamic_body(M:P, _) :- 759 dynamic_body(P, M). 760qdynamic_body(F/A, M) :- 761 dynamic_body(F/A, M). 762qdynamic_body((P1, P2), M) :- 763 qdynamic_body(P1, M), 764 qdynamic_body(P2, M). 765 766 767%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 768% *** Internal Database *** 769 770:- tool(current_key/2, current_key_body/3). 771current_key_body(KeyName, KeyTerm, Module) :- 772 @(current_record(IKey), Module), 773 external_key(IKey, KeyTerm), 774 functor(KeyTerm, KeyName, _). 775 776external_key(Key, KeyN) :- 777 atom(Key), 778 atom_string(Key, KeyS), 779 string_length(KeyS, N), 780 string_code(KeyS, N, 0), % last key char is \000 781 !, 782 term_string(KeyN, KeyS). 783external_key(Key, Key). 784 785 786internal_key(Key, IKey) :- 787 var(Key), !, 788 current_record(IKey), 789 external_key(IKey, Key). 790internal_key(Key, IKey) :- 791 number(Key), !, 792 concat_atom([Key, '\000'], IKey). % append \000 char 793internal_key(Key, Key). 794 795 796 797% Possible modes: recorded(+,-,-) recorded(-,-,+) recorded(-,-,-) 798:- tool(recorded/3, recorded_body/4). 799recorded_body(Key, Term, QRef, Module) :- 800 var(QRef), !, 801 internal_key(Key, IKey), 802 @(sepia_kernel:recorded(IKey, Term, DbRef), Module), 803 QRef = '$ref'(DbRef, 0). 804recorded_body(Key, Term, '$ref'(DbRef, 0), Module) :- 805 internal_key(Key, IKey), 806 @(sepia_kernel:recorded(IKey, Term, DbRef), Module), 807 !. 808 809:- tool(recorda/3, recorda_body/4). 810recorda_body(Key, Term, '$ref'(DbRef, 0), Module) :- 811 nonvar(Key), 812 internal_key(Key, NewKey), 813 @(sepia_kernel:recorda(NewKey, Term, DbRef), Module). 814 815:- tool(recordz/3, recordz_body/4). 816recordz_body(Key, Term, '$ref'(DbRef, 0), Module) :- 817 nonvar(Key), 818 internal_key(Key, NewKey), 819 @(sepia_kernel:recordz(NewKey, Term, DbRef), Module). 820 821:- tool(erase/1, erase_body/2). 822erase_body('$ref'(DbRef, 0), Module) :- 823 @(sepia_kernel:erase(DbRef), Module). 824 825instance('$ref'(DbRef, 0), Term) :- 826 referenced_record(DbRef, Term). 827 828%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 829% *** Grammar Rules *** 830 831% only temporary 832expand_term(A, B) :- 833 term_expansion(A, B), 834 !. 835expand_term(A, A). 836 837% To avoid calling an undefined procedure. 838term_expansion(_, _) :- fail. 839 840%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 841% *** Miscellaneous *** 842 843prolog_flag_body(Flag, Old, New, _Module) :- 844 var(Flag), 845 !, 846 error(4, prolog_flag(Flag, Old, New)). 847prolog_flag_body(Flag, Old, New, _Module) :- 848 var(New), 849 Old \== New, 850 !, 851 error(4, prolog_flag(Flag, Old, New)). 852prolog_flag_body(Flag, Old, New, Module) :- 853 prolog_flag_body(Flag, Old, Module), 854 set_quintus_flag(Flag, New, Module). 855 856set_quintus_flag(character_escapes, New, Module) :- 857% effect localised to Module! 858 (New == on -> 859 @(set_chtab(0'\, escape), Module) 860 ; 861 New == off -> 862 @(set_chtab(0'\, symbol), Module) 863 ). 864set_quintus_flag(debugging, New, _) :- 865 (New == off -> 866 set_flag(debugging, nodebug) 867 ; 868 set_flag(debugging, New) 869 ). 870set_quintus_flag(fileerrors, New, _) :- 871 (New == on -> 872 fileerrors 873 ; 874 New == off -> 875 nofileerrors 876 ). 877set_quintus_flag(single_var_warnings, New, _) :- 878 (New == on -> 879 set_flag(variable_names, check_singletons) 880 ; 881 get_flag(variable_names, off) -> 882 true 883 ; 884 set_flag(variable_names, on) 885 ). 886set_quintus_flag(unknown, New, _) :- 887 unknown(_, New). 888set_quintus_flag(gc, New, _) :- 889 set_flag(gc, New). 890set_quintus_flag(gc_margin, New, _) :- 891 set_flag(gc_interval, New). 892set_quintus_flag(gc_trace, New, _) :- 893 (New == on -> 894 set_flag(gc, verbose) 895 ; 896 New == off -> 897 set_flag(gc, on) 898 ). 899 900prolog_flag_body(character_escapes, Old, Module) :- 901 ( 902 @(get_chtab(0'\, escape), Module) -> Old = on ; Old = off 903 ). 904prolog_flag_body(debugging, Old, _) :- 905 get_flag(debugging, Mode), 906 (Mode == nodebug -> 907 Old = off 908 ; 909 Mode == leap -> 910 Old = debug 911 ; 912 Old = trace 913 ). 914prolog_flag_body(fileerrors, Old, _) :- 915 (get_event_handler(170, nofileerrors_handler/2, _) -> 916 Old = off 917 ; 918 Old = on 919 ). 920prolog_flag_body(single_var_warnings, Old, _) :- 921 (get_flag(variable_names, check_singletons) -> 922 Old = on 923 ; 924 Old = off 925 ). 926prolog_flag_body(unknown, Old, _) :- 927 unknown(Old, Old). 928prolog_flag_body(gc, Old, _) :- 929 get_flag(gc, OldF), 930 (OldF == off -> Old = off; Old = on). 931prolog_flag_body(gc_margin, Old, _) :- 932 get_flag(gc_interval, Old). 933prolog_flag_body(gc_trace, Old, _) :- 934 (get_flag(gc, verbose) -> 935 Old = on 936 ; 937 Old = off 938 939 ). 940prolog_flag_body(typein_module, M, _) :- 941% not in quintus, but in SICStus 942 get_flag(toplevel_module, M). 943 944 945version. 946 947version(Message) :- 948 write(Message), nl. 949 950%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 951% *** System Dependent *** 952 953is_lower(X):- X < 128, X > 96. 954is_upper(X):- X > 64, X < 91. 955is_digit(X):- X > 47, X < 58. 956 957unix(cd(Path)) :- 958 cd(Path). 959unix(cd) :- 960 getenv('HOME', Home), 961 cd(Home). 962unix(shell(X)) :- 963 getenv('SHELL', Shell), 964 concat_string([Shell, ' -c "', X, '"'], Command), 965 sh(Command). 966unix(system(X)) :- 967 sh(X). 968unix(system(X, Status)) :- 969 getenv('SHELL', Shell), 970 concat_string([Shell, ' -c "', X, '"'], Command), 971 exec(sh, [S], Pid), 972 printf(S, '%w\nexit\n%b', Command), 973 close(S), 974 wait(Pid, Status). 975unix(shell) :- 976 getenv('SHELL', Shell), 977 sh(Shell). 978unix(argv(L)) :- 979 argc(N), 980 args_list(N, [], L). 981unix(exit(N)) :- 982 exit(N). 983 984:- mode args_list(++, +, -). 985args_list(1, L, L) :- !. 986args_list(N, L, M) :- 987 N1 is N - 1, 988 argv(N1, S), 989 (number_string(A, S) -> true ; atom_string(A, S)), 990 args_list(N1, [A|L], M). 991 992% put_line(list of charcters) 993% writes the list of characters and a newline to the current output 994 995put_line([]) :- 996 !, 997 nl. 998put_line([H|T]) :- 999 put(H), 1000 put_line(T). 1001 1002gc :- set_flag(gc, on). 1003nogc :- set_flag(gc, off). 1004 1005stream_code(S, C) :- 1006 get_stream(S, C). 1007 1008absolute_file_name(Rel, Abs) :- 1009 (Rel == user -> 1010 Abs == user 1011 ; get_flag(prolog_suffix, Sufs), 1012 (existing_file(Rel, Sufs, [], ExtRel) -> true ; ExtRel = Rel), 1013 canonical_path_name(ExtRel, Abs) 1014 ). 1015 1016%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 1017% *** Statistics *** 1018 1019/* 1020memory (total) 377000 bytes: 350636 in use, 26364 free 1021 program space 219572 bytes 1022 atom space (2804 atoms) 61024 in use, 43104 free 1023 global space 65532 bytes: 9088 in use, 56444 free 1024 global stack 6984 bytes 1025 trail 16 bytes 1026 system 2088 bytes 1027 local stack 65532 bytes: 356 in use, 65176 free 1028 local stack 332 bytes 1029 system 24 bytes 1030 0.000 sec. for 0 global and 0 local space shifts 1031 0.000 sec. for 0 garbage collections which collected 0 bytes 1032 0.000 sec. for 0 atom garbage collections which collected 0 bytes 1033 0.233 sec. runtime 1034*/ 1035 1036:- local variable(systime, 0), 1037 variable(realtime, 0), 1038 variable(walltime, 0). 1039 1040statistics(runtime, TotalLast) :- 1041 eclipse_language:statistics(runtime, TotalLast). 1042statistics(system_time, [Total,Last]) :- 1043 eclipse_language:statistics(times, [_User,System,_Real]), 1044 Total is fix(System*1000), 1045 getval(systime, Prev), 1046 Last is Total - Prev, 1047 setval(systime, Total). 1048statistics(real_time, [Total,Last]) :- 1049 eclipse_language:statistics(times, [_User,_System,Real]), 1050 Total is fix(Real*1000), 1051 getval(realtime, Prev), 1052 Last is Total - Prev, 1053 setval(realtime, Total). 1054statistics(walltime, [Total,Last]) :- % Sicstus 1055 eclipse_language:statistics(times, [_User,_System,Real]), 1056 Total is fix(Real*1000), 1057 getval(walltime, Prev), 1058 Last is Total - Prev, 1059 setval(walltime, Total). 1060statistics(memory, [Total, 0]) :- 1061 Total is (eclipse_language:statistics(shared_heap_allocated)) 1062 + (eclipse_language:statistics(private_heap_allocated)) 1063 + (eclipse_language:statistics(global_stack_allocated)) 1064 + (eclipse_language:statistics(control_stack_allocated)) 1065 + (eclipse_language:statistics(trail_stack_allocated)) 1066 + (eclipse_language:statistics(local_stack_allocated)). 1067statistics(program, [Used, Free]) :- 1068 eclipse_language:statistics(shared_heap_used, Used), 1069 Free is (eclipse_language:statistics(shared_heap_allocated)) - Used. 1070statistics(global_stack, [Used, Free]) :- 1071 eclipse_language:statistics(global_stack_used, Used), 1072 Free is (eclipse_language:statistics(global_stack_allocated)) - Used. 1073statistics(local_stack, [Used, Free]) :- 1074 Used is (eclipse_language:statistics(local_stack_used)) 1075 + (eclipse_language:statistics(control_stack_used)), 1076 Free is (eclipse_language:statistics(local_stack_allocated)) 1077 + (eclipse_language:statistics(control_stack_allocated)) - Used. 1078statistics(trail, [Used, Free]) :- 1079 eclipse_language:statistics(trail_stack_used, Used), 1080 Free is (eclipse_language:statistics(trail_stack_allocated)) - Used. 1081statistics(choice, [Used, Free]) :- % Sicstus 1082 eclipse_language:statistics(control_stack_used, Used), 1083 Free is (eclipse_language:statistics(control_stack_allocated)) - Used. 1084statistics(stacks, [Global, Local]) :- % Sicstus 1085 eclipse_language:statistics(global_stack_used, Global), 1086 Local is (eclipse_language:statistics(local_stack_used)) 1087 + (eclipse_language:statistics(control_stack_used)). 1088statistics(garbage_collection, [Number, Freed, Time]) :- 1089 eclipse_language:statistics(gc_number, Number), 1090 eclipse_language:statistics(gc_collected, Freed), 1091 eclipse_language:statistics(gc_time, Time). 1092statistics(stack_shifts, [0, 0, 0.0]). 1093statistics(atoms, [Number,Used,Free]) :- 1094 eclipse_language:statistics(dictionary_entries, Number), 1095 eclipse_language:statistics(dict_hash_usage, Used/Total), 1096 Free is Total-Used. 1097statistics(atom_garbage_collection, [Number,-1,Time]) :- 1098 eclipse_language:statistics(dict_gc_number, Number), 1099 eclipse_language:statistics(dict_gc_time, Time). 1100statistics(core, List) :- % DEC-10 1101 statistics(memory, List). 1102statistics(heap, List) :- % DEC-10 1103 statistics(program, List). 1104 1105statistics :- 1106 nl(log_output), 1107 ( 1108 statistics(What, Value), 1109 Fill is 24 - atom_length(What), 1110 printf(log_output, '%w:%*c%w%n', [What, Fill, 0' , Value]), 1111 fail 1112 ; 1113 true 1114 ). 1115 1116 1117%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 1118 1119:- (current_module(user) -> 1120 true 1121 ; 1122 create_module(user), 1123 @(call(import(quintus)), user) 1124 ). 1125 1126%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 1127% 1128% MODULE INITIALIZATION 1129% 1130%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 1131