1/* Part of SWI-Prolog 2 3 Author: Jan Wielemaker, Johan Romme 4 E-mail: J.Wielemaker@cs.vu.nl 5 WWW: http://www.swi-prolog.org 6 Copyright (c) 2012-2016, VU University Amsterdam 7 All rights reserved. 8 9 Redistribution and use in source and binary forms, with or without 10 modification, are permitted provided that the following conditions 11 are met: 12 13 1. Redistributions of source code must retain the above copyright 14 notice, this list of conditions and the following disclaimer. 15 16 2. Redistributions in binary form must reproduce the above copyright 17 notice, this list of conditions and the following disclaimer in 18 the documentation and/or other materials provided with the 19 distribution. 20 21 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 POSSIBILITY OF SUCH DAMAGE. 33*/ 34 35:- module(ifprolog, 36 [ calling_context/1, % -Module 37 context/2, % :Goal, +Mapping 38 block/3, % :Goal, +Tag, :Recovery 39 exit_block/1, % +Tag 40 cut_block/1, % +Tag 41 42 modify_mode/3, % +PI, -Old, +New 43 debug_mode/3, % +PI, -Old, +New 44 ifprolog_debug/1, % :Goal, 45 debug_config/3, % +Key, +Current, +Value 46 float_format/2, % -Old, +New 47 program_parameters/1, % -Argv 48 user_parameters/1, % -Argv 49 match/2, % +Mask, +Atom 50 match/3, % +Mask, +Atom, ?Replacements 51 lower_upper/2, % ?Lower, ?Upper 52 current_error/1, % -Stream 53 writeq_atom/2, % +Term, -Atom 54 write_atom/2, % +Term, -Atom 55 write_formatted_atom/3, % -Atom, +Format, +ArgList 56 write_formatted/2, % +Format, +ArgList 57 write_formatted/3, % +Stream, +Format, +ArgList 58 atom_part/4, % +Atom, +Pos, +Len, -Sub 59 atom_prefix/3, % +Atom, +Len, -Sub 60 atom_suffix/3, % +Atom, +Len, -Sub 61 atom_split/3, % +Atom, +Delimiter, ?Subatoms 62 if_concat_atom/2, % +List, ?Atom 63 if_concat_atom/3, % +List, +Delimiter, ?Atom 64 getchar/3, % +Atom, +Pos, -Char 65 parse_atom/6, % +Atom, +StartPos, ?EndPos, 66 % ?Term, ?VarList, ?Error 67 index/3, % +Atom, +String, -Position 68 list_length/2, % +List, ?Length 69 load/1, % :FileName 70% unload/1, % +Module 71 file_test/2, % +File, +Mode 72 filepos/2, % @Stream, -Line 73 filepos/3, % @Stream, -Line, -Column 74 getcwd/1, % -Dir 75 assign_alias/2, % +Alias, @Stream 76 get_until/3, % +SearchChar, ?Text, ?EndChar 77 get_until/4, % @In, +SearchChar, ?Text, ?EndChar 78 for/3, % +Start, ?Counter, +End 79 prolog_version/1, % -Atom 80 proroot/1, % -Atom 81 system_name/1, % -Atom 82 localtime/9, % +Time, ?Year, ?Month, 83 % ?Day, ?DoW, ?DoY, 84 % ?Hour, ?Min, ?Sec 85 86 asserta_with_names/2, % @Term, +VarNames 87 assertz_with_names/2, % @Term, +VarNames 88 clause_with_names/3, % ?Head, ?Body, ?VarNames 89 retract_with_names/2, % ?Clause, ?VarNames 90 predicate_type/2, % @Predicate, ?Type 91 current_visible/2, % @Module, @Predicate 92 current_signal/2, % ?Signal, ?Mode 93 digit/1, % +Character 94 letter/1, % +Character 95 96 current_global/1, % +Name 97 get_global/2, % +Name, ?Value 98 set_global/2, % +Name, ?Value 99 unset_global/1, % +Name 100 101 current_default_module/1, % -Module 102 set_default_module/1, % +Module 103 104 op(1150, fx, (meta)), 105 op(1150, fx, (export)), 106 op(100, xfx, @), 107 op(900, xfx, =>), 108 op(900, fy, not) 109 ]). 110:- use_module(library(debug)). 111:- use_module(library(arithmetic)). 112:- use_module(library(memfile)). 113:- use_module(library(apply)). 114:- set_prolog_flag(double_quotes, codes). 115 116/** <module> IF/Prolog compatibility package 117 118This library realises emulation of IF/Prolog. As with all the emulation 119layers in the dialect directory, the emulation has been established on 120`as needed' basis from porting programs. This implies that the emulation 121is incomplete. Emumated directives, predicates and libraries are often 122not 100% compatible with the IF/Prolog version. 123 124Note that this emulation layer targets primarily IF/Prolog version 5. 125 126Please help extending this library and submit patches to 127bugs@swi-prolog.org. 128*/ 129 130:- module_transparent 131 calling_context/1. 132 133:- meta_predicate 134 context(0, +), 135 block(0, +, 0), 136 modify_mode(:, -, +), 137 debug_mode(:, -, +), 138 ifprolog_debug(0), 139 load(:), 140 asserta_with_names(:, +), 141 assertz_with_names(:, +), 142 clause_with_names(:, -, -), 143 retract_with_names(:, -), 144 predicate_type(:, -), 145 current_global(:), 146 get_global(:, -), 147 set_global(:, +), 148 unset_global(:). 149 150 151 /******************************* 152 * EXPANSION * 153 *******************************/ 154 155:- multifile 156 user:goal_expansion/2, 157 user:term_expansion/2, 158 user:file_search_path/2, 159 user:prolog_file_type/2, 160 ifprolog_goal_expansion/2, 161 ifprolog_term_expansion/2. 162:- dynamic 163 user:goal_expansion/2, 164 user:term_expansion/2, 165 user:file_search_path/2, 166 user:prolog_file_type/2. 167 168:- dynamic 169 in_module_interface/1. 170 171user:goal_expansion(In, Out) :- 172 prolog_load_context(dialect, ifprolog), 173 ifprolog_goal_expansion(In, Out). 174 175user:term_expansion(In, Out) :- 176 prolog_load_context(dialect, ifprolog), 177 ifprolog_term_expansion(In, Out). 178 179%% ifprolog_goal_expansion(+In, +Out) 180% 181% goal_expansion rules to emulate IF/Prolog behaviour in 182% SWI-Prolog. The expansions below maintain optimization from 183% compilation. Defining them as predicates would loose 184% compilation. 185 186%% context(:Goal, Handler) 187% 188% Is mapped to catch(Goal, Error, Recover) is Handler is 189% =|error(_,_) => Recover|=. Other cases are not covered by the 190% emulation. 191 192%% asserta(Head,Body) is det. 193%% assertz(Head,Body) is det. 194%% retract(Head,Body) is det. 195% 196% Mapped to asserta((Head:-Body)), etc. Note that this masks 197% SWI-Prolog's asserta/2, etc. 198 199ifprolog_goal_expansion(Module:Goal, Expanded) :- 200 Module == system, nonvar(Goal), !, 201 expand_goal(Goal, ExpandedGoal), 202 head_pi(ExpandedGoal, PI), 203 ( current_predicate(ifprolog:PI), 204 \+ predicate_property(ExpandedGoal, imported_from(_)) 205 -> Expanded = ifprolog:ExpandedGoal 206 ; Expanded = ExpandedGoal 207 ). 208ifprolog_goal_expansion(Goal, Expanded) :- 209 if_goal_expansion(Goal, Expanded). 210 211if_goal_expansion(context(Goal, [Error => Recover]), 212 catch(Goal, Error, Recover)) :- 213 assertion(Error = error(_,_)). 214if_goal_expansion(assertz(Head,Body), 215 assertz((Head:-Body))). 216if_goal_expansion(asserta(Head,Body), 217 asserta((Head:-Body))). 218if_goal_expansion(retract(Head,Body), 219 retract((Head:-Body))). 220if_goal_expansion(Call@Module, call((Module:Goal)@Module)) :- 221 nonvar(Call), 222 Call = call(Goal). 223if_goal_expansion(concat_atom(L,A), if_concat_atom(L,A)). 224if_goal_expansion(concat_atom(L,D,A), if_concat_atom(L,D,A)). 225 226 227head_pi(M:Head, M:PI) :- !, 228 head_pi(Head, PI). 229head_pi(Head, Name/Arity) :- 230 functor(Head, Name, Arity). 231 232 233%% ifprolog_term_expansion(+In, +Out) 234% 235% term_expansion rules to emulate IF/Prolog behaviour in 236% SWI-Prolog. 237 238%% meta(+ListOfPI) 239% 240% Mapped to module_transparent/1. Not sure whether this is 241% correct. It surely is not very elegant to map to a deprecated 242% feature. Luckily, although the module_transparent/1 API is 243% deprecated, the underlying functionality is still core of the 244% module system. 245% 246% Note that if :- meta appears inside a module interface, the 247% predicate is also exported. 248 249%% export(+ListOfPI) is det. 250%% discontiguous(+ListOfPI) is det. 251% 252% Mapped to comma-lists 253 254%% module(+Name). 255%% begin_module(+Name). 256%% end_module(+Name). 257% 258% These are emulated correctly, provided module/1 is the first 259% term of the file and the implementation is part of the same 260% file. Begin/end are ignored. 261 262ifprolog_term_expansion((:- meta([])), []). 263ifprolog_term_expansion((:- meta(List)), 264 [ (:- module_transparent(Spec)) 265 | Export 266 ]) :- 267 pi_list_to_pi_term(List, Spec), 268 ( in_module_interface(_) 269 -> Export = [(:- export(Spec))] 270 ; Export = [] 271 ). 272 273ifprolog_term_expansion((:- export([])), []). 274ifprolog_term_expansion((:- export(List)), 275 (:- export(Spec))) :- 276 is_list(List), 277 pi_list_to_pi_term(List, Spec). 278 279ifprolog_term_expansion((:- private(_)), []). 280 281ifprolog_term_expansion((:- discontiguous([])), []). 282ifprolog_term_expansion((:- discontiguous(List)), 283 (:- discontiguous(Spec))) :- 284 is_list(List), 285 pi_list_to_pi_term(List, Spec). 286 287ifprolog_term_expansion((:- multifile([])), []). 288ifprolog_term_expansion((:- multifile(List)), 289 (:- multifile(Spec))) :- 290 is_list(List), 291 pi_list_to_pi_term(List, Spec). 292 293ifprolog_term_expansion((:- module(Name)), 294 (:- module(Name, []))) :- 295 asserta(in_module_interface(Name)). 296ifprolog_term_expansion((:- begin_module(Name)), []) :- 297 prolog_load_context(module, Loading), 298 assertion(Name == Loading), 299 retract(in_module_interface(Name)). 300ifprolog_term_expansion((:- end_module(_)), []). 301ifprolog_term_expansion((:- end_module), []). 302ifprolog_term_expansion((:- nonotify), []). % TBD: set verbosity 303 304 305ifprolog_term_expansion((:- import(Module)), 306 (:- use_module(File))) :- 307 ( module_property(Module, file(File)) 308 -> true 309 ; existence_error(module, Module) 310 ). 311ifprolog_term_expansion((:- import(Module, ImportList)), 312 (:- use_module(File, ImportList))) :- 313 ( module_property(Module, file(File)) 314 -> true 315 ; existence_error(module, Module) 316 ). 317 318%% pi_list_to_pi_term(+List, -CommaList) is det. 319 320pi_list_to_pi_term([PI], PI) :- !. 321pi_list_to_pi_term([H|T], (H,CommaList)) :- 322 pi_list_to_pi_term(T, CommaList). 323 324 /******************************* 325 * LIBRARY SETUP * 326 *******************************/ 327 328%% push_ifprolog_library 329% 330% Pushes searching for dialect/ifprolog in front of every library 331% directory that contains such as sub-directory. 332 333push_ifprolog_library :- 334 ( absolute_file_name(library(dialect/ifprolog), Dir, 335 [ file_type(directory), 336 access(read), 337 solutions(all), 338 file_errors(fail) 339 ]), 340 asserta((user:file_search_path(library, Dir) :- 341 prolog_load_context(dialect, ifprolog))), 342 fail 343 ; true 344 ). 345 346%% push_ifprolog_file_extension 347% 348% Looks for .pro files before looking for .pl files if the current 349% dialect is =pro=. If the dialect is not active, the .pro files 350% are found as last resort. 351 352push_ifprolog_file_extension :- 353 asserta((user:prolog_file_type(pro, prolog) :- 354 prolog_load_context(dialect, ifprolog))). 355 356user:prolog_file_type(pro, prolog) :- 357 \+ prolog_load_context(dialect, ifprolog). 358 359:- push_ifprolog_library, 360 push_ifprolog_file_extension. 361 362 363 /******************************* 364 * PREDICATES * 365 *******************************/ 366 367%% calling_context(-Context) 368% 369% Mapped to context_module/1. 370 371calling_context(Context) :- 372 context_module(Context). 373 374%% context(:Goal, +Mapping) 375% 376% IF/Prolog context/2 construct. This is the true predicate. This 377% is normally mapped by goal-expansion. 378% 379% @bug Does not deal with IF/Prolog signal mapping 380 381context(M:Goal, Mapping) :- 382 member(Error => Action, Mapping), 383 nonvar(Error), 384 Error = error(_,_), !, 385 catch(M:Goal, Error, Action). 386context(M:Goal, _Mapping) :- 387 M:Goal. 388 389%% block(:Goal, +Tag, :Recovery). 390%% exit_block(+Tag). 391%% cut_block(+Tag) is semidet. 392% 393% The control construct block/3 runs Goal in a block labelled Tag. 394% If Goal calls exit_block/1 using a matching Tag, the execution 395% of Goal is abandoned using exception handling and execution 396% continues by running Recovery. Goal can call cut_block/1. If 397% there is a block with matching Tag, all choice points created 398% since the block was started are destroyed. 399% 400% @bug The block control structure is implemented on top of 401% catch/3 and throw/1. If catch/3 is used inside Goal, 402% the user must ensure that either (1) the protected 403% goal does not call exit_block/1 or cut_block/1 or (2) 404% the _Catcher_ of the catch/3 call does *not* unify with 405% a term block(_,_). 406 407block(Goal, Tag, Recovery) :- 408 prolog_current_choice(Choice), 409 catch(Goal, block(Tag, Choice), Recovery). 410 411exit_block(Tag) :- 412 throw(block(Tag, _)). 413 414cut_block(Tag) :- 415 prolog_current_frame(Frame), 416 findall(Choice, % use findall/3 to avoid binding 417 prolog_frame_attribute( 418 Frame, parent_goal, 419 system:catch(_, block(Tag, Choice), _)), 420 [Choice]), 421 nonvar(Choice), 422 prolog_cut_to(Choice). 423 424%% modify_mode(+PI, -OldMode, +NewMode) is det. 425% 426% Switch between static and dynamic code. Fully supported, but 427% notably changing static to dynamic code is not allowed if the 428% predicate has clauses. 429 430modify_mode(PI, OldMode, NewMode) :- 431 pi_head(PI, Head), 432 old_mode(Head, OldMode), 433 set_mode(PI, OldMode, NewMode). 434 435old_mode(Head, Mode) :- 436 ( predicate_property(Head, dynamic) 437 -> Mode = on 438 ; Mode = off 439 ). 440 441set_mode(_, Old, Old) :- !. 442set_mode(PI, _, on) :- !, 443 dynamic(PI). 444set_mode(PI, _, off) :- 445 compile_predicates([PI]). 446 447pi_head(M:PI, M:Head) :- !, 448 pi_head(PI, Head). 449pi_head(Name/Arity, Term) :- 450 functor(Term, Name, Arity). 451 452%% debug_mode(:PI, -Old, +New) 453% 454% Old is not unified. Only New == off is mapped to disable 455% debugging of a predicate. 456 457debug_mode(PI, _, off) :- !, 458 '$hide'(PI). 459debug_mode(_, _, on). 460 461%% ifprolog_debug(:Goal) 462% 463% Map IF/Prolog debug(Goal)@Module. This should run Goal in debug 464% mode. We rarely needs this type of measures in SWI-Prolog. 465 466ifprolog_debug(Goal) :- 467 Goal. 468 469%% debug_config(+Key, -Current, +Value) 470% 471% Ignored. Prints a message. 472 473debug_config(Key,Current,Value) :- 474 print_message(informational, ignored(debug_config(Key,Current,Value))). 475 476%% float_format(-Old, +New) 477% 478% Ignored. Prints a message. Cannot be emulated. Printing floats 479% with a specified precision can only be done using format/2. 480 481float_format(Old, New) :- 482 print_message(informational, ignored(float_format(Old, New))). 483 484%% program_parameters(-List:atom) 485% 486% All command-line argument, including the executable, 487 488program_parameters(Argv) :- 489 current_prolog_flag(os_argv, Argv). 490 491%% user_parameters(-List:atom) 492% 493% Parameters after =|--|=. 494 495user_parameters(Argv) :- 496 current_prolog_flag(argv, Argv). 497 498%% match(+Mask, +Atom) is semidet. 499% 500% Same as once(match(Mask, Atom, _Replacements)). 501 502match(Mask, Atom) :- 503 match(Mask, Atom, _), !. 504 505%% match(+Mask, +Atom, ?Replacements) is nondet. 506% 507% Pattern matching. This emulation should be complete. Can be 508% optimized using caching of the pattern-analysis or doing the 509% analysis at compile-time. 510 511match(Mask, Atom, Replacements) :- 512 atom_codes(Mask, MaskCodes), 513 atom_codes(Atom, Codes), 514 phrase(match_pattern(Pattern), MaskCodes), !, 515 pattern_goal(Pattern, Codes, Replacements, Goal), 516 Goal. 517 518pattern_goal([], [], [], true). 519pattern_goal([string(String)|T], Codes, Replacements, Goal) :- !, 520 append(String, Rest, Codes), 521 pattern_goal(T, Rest, Replacements, Goal). 522pattern_goal([star|T], Codes, [Atom|Replacements], Goal) :- 523 append(Replacement, Rest, Codes), 524 Goal = (atom_codes(Atom, Replacement),Goal2), 525 pattern_goal(T, Rest, Replacements, Goal2). 526pattern_goal([set(S)|T], [C|Rest], [Atom|Replacements], Goal) :- 527 memberchk(C, S), !, 528 Goal = (char_code(Atom, C),Goal2), 529 pattern_goal(T, Rest, Replacements, Goal2). 530pattern_goal([any|T], [C|Rest], [Atom|Replacements], Goal) :- 531 Goal = (char_code(Atom, C),Goal2), 532 pattern_goal(T, Rest, Replacements, Goal2). 533 534match_pattern([set(S)|T]) --> 535 "[", 536 match_set(S), !, 537 match_pattern(T). 538match_pattern([string(List)|T]) --> 539 non_special(List), 540 { List \== [] }, !, 541 match_pattern(T). 542match_pattern([star|T]) --> 543 "*", !, 544 match_pattern(T). 545match_pattern([any|T]) --> 546 "?", !, 547 match_pattern(T). 548match_pattern([]) --> []. 549 550match_set([]) --> "]", !. 551match_set(L) --> 552 [C0], "-", [C1], 553 { C1 \= 0'], 554 C0 =< C1, 555 numlist(C0, C1, Range), 556 append(Range, T, L) 557 }, 558 match_set(T). 559match_set([C|L]) --> 560 [C], 561 match_set(L). 562 563non_special([H|T]) --> 564 [H], 565 { \+ special(H) }, !, 566 non_special(T). 567non_special([]) --> []. 568 569special(0'*). 570special(0'?). 571special(0'[). 572 573%% lower_upper(+Lower, -Upper) is det. 574%% lower_upper(-Lower, +Upper) is det. 575% 576% Multi-moded combination of upcase_atom/2 and downcase_atom/2. 577 578 579lower_upper(Lower, Upper) :- 580 nonvar(Lower), !, 581 upcase_atom(Lower, Upper). 582lower_upper(Lower, Upper) :- 583 downcase_atom(Upper, Lower). 584 585%% load(File) 586% 587% Mapped to consult. I think that the compatible version should 588% only load .qlf (compiled) code. 589 590load(File) :- 591 consult(File). 592 593%% unload(+Module) is det. 594% 595% Unload the named module. 596% 597% @bug: What to do with modules that are not associated to a 598% file? 599 600unload(Module) :- 601 module_property(Module, file(File)), !, 602 unload_file(File). 603unload(_Module) :- 604 assertion(fail). 605 606%% file_test(+File, +Mode) 607% 608% Mapped to access_file/2 (which understand more modes). Note that 609% this predicate is defined in the module =system= to allow for 610% direct calling. 611 612file_test(File, Mode) :- 613 access_file(File, Mode). 614 615%% filepos(@Stream, -Line) 616% 617% from the IF/Prolog documentation The predicate filepos/2 618% determines the current line position of the specified input 619% stream and unifies the result with Line. The current line 620% position is the number of line processed + 1 621 622filepos(Stream, Line) :- 623 line_count(Stream, L), 624 Line is L + 1. 625 626 627%% getcwd(-Dir) 628% 629% The predicate getcwd/1 unifies Dir with the full pathname of the 630% current working directory. 631 632getcwd(Dir) :- 633 working_directory(Dir, Dir). 634 635%% filepos(@Stream, -Line, -Column) 636% 637% from the IF/Prolog documentation The predicate filepos/2 638% determines the current line position of the specified input 639% stream and unifies the result with Line. The current line 640% position is the number of line processed + 1 641 642filepos(Stream, Line, Column) :- 643 line_count(Stream, L), 644 line_position(Stream, C), 645 Line is L + 1, 646 Column is C + 1. 647 648%% assign_alias(+Alias, @Stream) is det. 649% 650 651assign_alias(Alias, Stream) :- 652 set_stream(Stream, alias(Alias)). 653 654%% writeq_atom(+Term, -Atom) 655% 656% Use writeq/1 to write Term to Atom. 657 658writeq_atom(Term, Atom) :- 659 with_output_to(atom(Atom), writeq(Term)). 660 661%% write_atom(+Term, -Atom) 662% 663% Use write/1 to write Term to Atom. 664 665write_atom(Term, Atom) :- 666 with_output_to(atom(Atom), write(Term)). 667 668%% current_error(-Stream) 669% 670% Doesn't exist in SWI-Prolog, but =user_error= is always an alias 671% to the current error stream. 672 673current_error(user_error). 674 675 676 /******************************* 677 * FORMATTED WRITE * 678 *******************************/ 679 680%% write_formatted_atom(-Atom, +Format, +ArgList) is det. 681%% write_formatted(+Format, +ArgList) is det. 682%% write_formatted(@Stream, +Format, +ArgList) is det. 683% 684% Emulation of IF/Prolog formatted write. The emulation is very 685% incomplete. Notable asks for dealing with aligned fields, etc. 686% 687% @bug Not all format characters are processed 688% @bug Incomplete processing of modifiers, fieldwidth and precision 689% @tbd This should become goal-expansion based to process 690% format specifiers at compile-time. 691 692write_formatted_atom(Atom, Format, ArgList) :- 693 with_output_to(atom(Atom), write_formatted(Format, ArgList)). 694 695write_formatted(Format, ArgList) :- 696 write_formatted(current_output, Format, ArgList). 697 698write_formatted(Out, Format, ArgList) :- 699 atom_codes(Format, Codes), 700 phrase(format_string(FormatCodes), Codes), !, 701 string_codes(FormatString, FormatCodes), 702 format(Out, FormatString, ArgList). 703 704format_string([]) --> []. 705format_string(Fmt) --> 706 "%", format_modifiers(Flags, FieldLen, Precision), [IFC], !, 707 { map_format([IFC], Flags, FieldLen, Precision, Repl) 708 -> append(Repl, T, Fmt) 709 ; print_message(warning, ifprolog_format(IFC)), 710 %backtrace(20), 711 T = Fmt 712 }, 713 format_string(T). 714format_string([H|T]) --> 715 [H], 716 format_string(T). 717 718map_format(Format, [], default, default, Mapped) :- !, 719 map_format(Format, Mapped). 720map_format(Format, Flags, Width, Precision, Mapped) :- 721 integer(Width), !, % left/right aligned in Width 722 map_format(Format, Field), 723 format_precision(Precision, Field, PrecField), 724 fill_code(Flags, [Fill]), 725 ( memberchk(-, Flags) % left aligned 726 -> format(codes(Mapped), '~~|~s~~`~ct~~~d+', [PrecField, Fill, Width]) 727 ; format(codes(Mapped), '~~|~~`~ct~s~~~d+', [Fill, PrecField, Width]) 728 ). 729map_format(Format, Flags, _, _, Mapped) :- 730 memberchk(#, Flags), 731 can_format(Format, Mapped), !. 732map_format(Format, _, _, Precision, Mapped) :- 733 map_format(Format, Field), 734 format_precision(Precision, Field, Mapped). 735 736can_format("o", "0~8r"). 737can_format("x", "0x~16r"). 738can_format("X", "0x~16R"). 739can_format("w", "~k"). 740 741map_format("t", "~w"). 742map_format("q", "~q"). 743map_format("s", "~a"). 744map_format("f", "~f"). 745map_format("e", "~e"). 746map_format("E", "~E"). 747map_format("g", "~G"). 748map_format("d", "~d"). 749map_format("x", "~16r"). 750map_format("o", "~8r"). 751map_format("X", "~16R"). 752map_format("O", "~8R"). 753map_format("c", "~c"). 754map_format("%", "%"). 755 756have_precision("d"). 757have_precision("D"). 758have_precision("e"). 759have_precision("E"). 760have_precision("f"). 761have_precision("g"). 762have_precision("G"). 763 764format_precision(N, [0'~|C], [0'~|Field]) :- 765 integer(N), 766 have_precision(C), 767 !, 768 format(codes(Field), '~d~s', [N, C]). 769format_precision(_, Field, Field). 770 771fill_code(Flags, "0") :- memberchk(0, Flags), !. 772fill_code(_, " "). 773 774%% format_modifiers(-Flags, -FieldLength, -Precision) is det. 775% 776% Read the IF/Prolog format modifiers. We currently do not process 777% any of the modifiers! Some code seems to be using e.g. %07lx. We 778% assume this is the same as -07x (assuming l=left). 779 780format_modifiers(Flags, FieldLength, Precision) --> 781 format_flags(Flags0), 782 digits(FieldLengthDigits), 783 { FieldLengthDigits == [] 784 -> FieldLength = default 785 ; number_codes(FieldLength, FieldLengthDigits) 786 }, 787 ( "." 788 -> digits(PrecisionDigits), 789 { number_codes(Precision, PrecisionDigits) } 790 ; { Precision = default } 791 ), 792 opt_alignment(Flags0, Flags). 793 794format_flags([H|T]) --> 795 format_flag(H), !, 796 format_flags(T). 797format_flags([]) --> []. 798 799format_flag(+) --> "+". % Always prefix number with a sign 800format_flag(-) --> "-". % Left-justify 801format_flag(space) --> " ". % Space before positive numbers 802format_flag(#) --> "#". % Canonical output 803format_flag(0) --> "0". % Use leading 0 for integers 804 805digits([D0|T]) --> 806 digit(D0), !, 807 digits(T). 808digits([]) --> []. 809 810digit(D) --> [D], {between(0'0, 0'9, D)}. 811 812opt_alignment(L, [-|L]) --> "l", !. 813opt_alignment(L, L) --> []. 814 815 816%% get_until(+SearchChar, -Text, -EndChar) is det. 817%% get_until(@Stream, +SearchChar, -Text, -EndChar) is det. 818% 819% Read input from Stream until SearchChar. Unify EndChar with 820% either SearchChar or the atom =end_of_file=. 821 822get_until(SearchChar, Text, EndChar) :- 823 get_until(current_input, SearchChar, Text, EndChar). 824 825get_until(In, SearchChar, Text, EndChar) :- 826 get_char(In, C0), 827 get_until(C0, In, SearchChar, Codes, EndChar), 828 atom_chars(Text, Codes). 829 830get_until(C0, _, C0, [], C0) :- !. 831get_until(end_of_file, _, _, [], end_of_file) :- !. 832get_until(C0, In, Search, [C0|T], End) :- 833 get_char(In, C1), 834 get_until(C1, In, Search, T, End). 835 836 837 /******************************* 838 * PARSE * 839 *******************************/ 840 841%% atom_part(+Atom, +Pos, +Len, -Sub) is det. 842% 843% True when Sub is part of the atom [Pos,Pos+Len). Unifies Sub 844% with '' if Pos or Len is out of range!? 845 846atom_part(_, Pos, _, Sub) :- 847 Pos < 1, !, 848 Sub = ''. 849atom_part(_, _, Len, Sub) :- 850 Len < 1, !, 851 Sub = ''. 852atom_part(Atom, Pos, _, Sub) :- 853 atom_length(Atom, Len), 854 Pos > Len, !, 855 Sub = ''. 856atom_part(Atom, Pos, Len, Sub) :- 857 Pos >= 1, 858 Pos0 is Pos - 1, 859 atom_length(Atom, ALen), 860 Len0 is min(Len, ALen-Pos0), 861 sub_atom(Atom, Pos0, Len0, _, Sub). 862 863%% atom_prefix(+Atom, +Len, -Sub) is det. 864% 865% Unifies Sub with the atom formed by the first Len characters in 866% atom. 867% 868% - If Len < 1, Sub is unified with the null atom ''. 869% - If Len > length of Atom, Sub is unified with Atom. 870 871atom_prefix(_, Len, Sub) :- 872 Len < 1, !, 873 Sub = ''. 874atom_prefix(Atom, Len, Sub) :- 875 atom_length(Atom, AtomLen), 876 Len > AtomLen, !, 877 Sub = Atom. 878atom_prefix(Atom, Len, Sub) :- 879 sub_atom(Atom, 0, Len, _, Sub). 880 881%% atom_suffix(+Atom, +Len, -Sub) is det. 882% 883% Unifies Sub with the atom formed by the last Len characters in 884% atom. 885% 886% - If Len < 1, Sub is unified with the null atom ''. 887% - If Len > length of Atom, Sub is unified with Atom. 888 889atom_suffix(_, Len, Sub) :- 890 Len < 1, !, 891 Sub = ''. 892atom_suffix(Atom, Len, Sub) :- 893 atom_length(Atom, AtomLen), 894 Len > AtomLen, !, 895 Sub = Atom. 896atom_suffix(Atom, Len, Sub) :- 897 atom_length(Atom, AtomLen), 898 Pos is AtomLen - Len, 899 sub_atom(Atom, Pos, Len, _, Sub). 900 901%% atom_split( +Atom, +Delimiter, ?Subatoms ) 902% 903% Split Atom over Delimiter and unify the parts with Subatoms. 904 905atom_split(Atom, Delimiter, Subatoms) :- 906 atomic_list_concat(Subatoms, Delimiter, Atom). 907 908%% if_concat_atom(+List, +Delimiter, -Atom) is det. 909% 910% True when Atom is the concatenation of the lexical form of all 911% elements from List, using Delimiter to delimit the elements. 912% 913% The behavior of this ifprolog predicate is different w.r.t. 914% SWI-Prolog in two respect: it supports arbitrary terms in List 915% rather than only atomic and it does _not_ work in mode -,+,+. 916 917if_concat_atom(List, Delimiter, Atom) :- 918 maplist(write_term_to_atom, List, AtomList), 919 atomic_list_concat(AtomList, Delimiter, Atom). 920 921write_term_to_atom(Term, Atom) :- 922 ( atomic(Term) 923 -> Atom = Term 924 ; with_output_to(string(Atom), write(Term)) 925 ). 926 927%% if_concat_atom(+List, -Atom) is det. 928% 929% True when Atom is the concatenation of the lexical form of all 930% elements from List. Same as if_concat_atom/3 using '' as 931% delimiter. 932 933if_concat_atom(List, Atom) :- 934 maplist(write_term_to_atom, List, AtomList), 935 atomic_list_concat(AtomList, Atom). 936 937%% getchar(+Atom, +Pos, -Char) 938% 939% Unifies Char with the Position-th character in Atom 940% If Pos < 1 or Pos > length of Atom, then fail. 941 942getchar(_, Pos, _) :- 943 Pos < 1, !, 944 fail. 945getchar(Atom, Pos, _) :- 946 atom_length(Atom, Len), 947 Pos > Len, !, 948 fail. 949getchar(Atom, Pos, Char) :- 950 P is Pos - 1, 951 sub_atom(Atom, P, 1, _, Char). 952 953 954%% parse_atom(+Atom, +StartPos, ?EndPos, ?Term, ?VarList, ?Error) 955% 956% Read from an atom. 957% 958% @param StartPos is 1-based position to start reading 959% @param Error is the 1-based position of a syntax error or 0 if 960% there is no error. 961 962parse_atom(Atom, StartPos, EndPos, Term, VarList, Error) :- 963 setup_call_cleanup( 964 ( atom_to_memory_file(Atom, MemF), 965 open_memory_file(MemF, read, In) 966 ), 967 ( StartPos0 is StartPos-1, 968 seek(In, StartPos0, bof, _), 969 catch(read_term(In, Term, [variable_names(VarList)]), E, true), 970 parse_atom_error(E, Error), 971 character_count(In, EndPos0), 972 EndPos is EndPos0+1 973 ), 974 ( close(In), 975 free_memory_file(MemF) 976 )). 977 978parse_atom_error(Var, Pos) :- 979 var(Var), !, Pos = 0. 980parse_atom_error(error(_, stream(_Stream, _, _, Pos)), Pos1) :- 981 Pos1 is Pos+1. 982 983 984%% index(+Atom, +String, -Position) is semidet. 985% 986% True when Position is the first occurrence of String in Atom. 987% Position is 1-based. 988 989index(Atom, String, Position) :- 990 sub_string(Atom, Pos0, _, _, String), !, 991 Position is Pos0 + 1. 992 993%% list_length(+List, ?Length) is det. 994% 995% Deterministic version of length/2. Current implementation simply 996% calls length/2. 997 998list_length(List, Length) :- 999 length(List, Length). 1000 1001 1002 /******************************* 1003 * MISC * 1004 *******************************/ 1005 1006%% for(+Start, ?Count, +End) is nondet. 1007% 1008% Similar to between/3, but can count down if Start > End. 1009 1010for(Start, Count, End) :- 1011 Start =< End, !, 1012 between(Start, End, Count). 1013for(Start, Count, End) :- 1014 nonvar(Count), !, 1015 between(End, Start, Count). 1016for(Start, Count, End) :- 1017 Range is Start-End, 1018 between(0, Range, X), 1019 Count is Start-X. 1020 1021%% prolog_version(-Version) 1022% 1023% Return IF/Prolog simulated version string 1024 1025prolog_version(Version) :- 1026 current_prolog_flag(version_data, swi(Major, Minor, Patch, _)), 1027 atomic_list_concat([Major, Minor, Patch], '.', Version). 1028 1029%% proroot(-Path) 1030% 1031% True when Path is the installation location of the Prolog 1032% system. 1033 1034proroot(Path) :- 1035 current_prolog_flag(home, Path). 1036 1037%% system_name(-SystemName) 1038% 1039% True when SystemName identifies the operating system. Note that 1040% this returns the SWI-Prolog =arch= flag, and not the IF/Prolog 1041% identifiers. 1042 1043system_name(SystemName) :- 1044 current_prolog_flag(arch, SystemName). 1045 1046%% localtime(+Time, ?Year, ?Month, ?Day, ?DoW, ?DoY, ?Hour, ?Min, ?Sec) 1047% 1048% Break system time into its components. Deefines components: 1049% 1050% | Year | Year number | 4 digits | 1051% | Month | Month number | 1..12 | 1052% | Day | Day of month | 1..31 | 1053% | DoW | Day of week | 1..7 (Mon-Sun) | 1054% | DoY | Day in year | 1..366 | 1055% | Hour | Hours | 0..23 | 1056% | Min | Minutes | 0..59 | 1057% | Sec | Seconds | 0..59 | 1058% 1059% Note that in IF/Prolog V4, Year is 0..99, while it is a 1060% four-digit number in IF/Prolog V5. We emulate IF/Prolog V5. 1061 1062localtime(TimeExpr, Year, Month, Day, DoW, DoY, Hour, Min, Sec) :- 1063 arithmetic_expression_value(TimeExpr, Time), 1064 stamp_date_time(Time, date(Year, Month, Day, 1065 Hour, Min, SecFloat, 1066 _Off, _TZ, _DST), local), 1067 Sec is floor(SecFloat), 1068 Date = date(Year,Month,Day), 1069 day_of_the_year(Date, DoY), 1070 day_of_the_week(Date, DoW). 1071 1072 1073%% current_global(+Name) is semidet. 1074%% get_global(+Name, ?Value) is det. 1075%% set_global(+Name, ?Value) is det. 1076%% unset_global(+Name) is det. 1077% 1078% IF/Prolog global variables, mapped to SWI-Prolog's nb_* 1079% predicates. 1080 1081current_global(Name) :- 1082 gvar_name(Name, GName), 1083 nb_current(GName, _). 1084 1085get_global(Name, Value) :- 1086 gvar_name(Name, GName), 1087 nb_getval(GName, Value). 1088 1089set_global(Name, Value) :- 1090 gvar_name(Name, GName), 1091 nb_setval(GName, Value). 1092 1093unset_global(Name) :- 1094 gvar_name(Name, GName), 1095 nb_delete(GName). 1096 1097gvar_name(Module:Name, GName) :- 1098 atomic_list_concat([Module, :, Name], GName). 1099 1100 1101%% current_default_module(-Module) is det. 1102% 1103% Name of the toplevel typein module. 1104 1105current_default_module(Module) :- 1106 '$current_typein_module'(Module). 1107 1108%% set_default_module(+Module) is det. 1109% 1110% Set the default toplevel module. 1111 1112set_default_module(Module) :- 1113 module(Module). 1114 1115 1116 /******************************* 1117 * DATABASE * 1118 *******************************/ 1119 1120:- dynamic 1121 names/2. 1122 1123%% asserta_with_names(@Clause, +VarNames) is det. 1124%% assertz_with_names(@Clause, +VarNames) is det. 1125%% clause_with_names(?Head, ?Body, -VarNames) is det. 1126%% retract_with_names(?Clause, -VarNames) is det. 1127% 1128% Predicates that manage the database while keeping track of 1129% variable names. 1130 1131asserta_with_names(M:Clause, VarNames) :- 1132 term_varnames(Clause, VarNames, VarTerm), 1133 system:asserta(M:Clause, Ref), 1134 asserta(names(Ref, VarTerm)). 1135assertz_with_names(M:Clause, VarNames) :- 1136 term_varnames(Clause, VarNames, VarTerm), 1137 system:assertz(M:Clause, Ref), 1138 asserta(names(Ref, VarTerm)). 1139 1140term_varnames(Term, VarNames, VarTerm) :- 1141 findall(Vars, 1142 ( term_variables(Term, Vars), 1143 bind_names(VarNames) 1144 ), 1145 [ VarList ]), 1146 VarTerm =.. [ v | VarList ]. 1147 1148bind_names([]). 1149bind_names([Name=Var|T]) :- 1150 Name=Var, 1151 bind_names(T). 1152 1153 1154clause_with_names(M:Head, Body, VarNames) :- 1155 clause(M:Head, Body, Ref), 1156 ( names(Ref, VarTerm) 1157 -> term_variables((Head:-Body), Vars), 1158 VarTerm =.. [v|NameList], 1159 make_bindings(NameList, Vars, VarNames) 1160 ; VarNames = [] 1161 ). 1162 1163retract_with_names(M:Term, VarNames) :- 1164 clause(M:Term, Ref), 1165 erase(Ref), 1166 ( retract(names(Ref, VarTerm)) 1167 -> term_variables((Term), Vars), 1168 VarTerm =.. [v|NameList], 1169 make_bindings(NameList, Vars, VarNames) 1170 ; VarNames = [] 1171 ). 1172 1173make_bindings([], [], []). 1174make_bindings([Name|NT], [Var|VT], [Name=Var|BT]) :- 1175 make_bindings(NT, VT, BT). 1176 1177 1178%% predicate_type(:PI, -Type) is det. 1179% 1180% True when Type describes the type of PI. Note that the value 1181% =linear= seems to mean you can use clause/2 on it, which is true 1182% for any SWI-Prolog predicate that is defined. Therefore, we use 1183% it for any predicate that is defined. 1184 1185predicate_type(M:Name/Arity, Type) :- 1186 functor(Head, Name, Arity), 1187 Pred = M:Head, 1188 ( ( predicate_property(Pred, built_in) 1189 ; predicate_property(Pred, foreign) 1190 ) 1191 -> Type = builtin 1192 ; predicate_property(Pred, imported_from(_)) 1193 -> Type = imported 1194 ; predicate_property(Pred, dynamic) 1195 -> Type = linear 1196 ; control(Head) 1197 -> Type = control 1198 ; Name == call 1199 -> Type = control 1200 ; current_predicate(M:Name/Arity) 1201 -> Type = linear 1202 ; Type = undefined 1203 ). 1204 1205control((_,_)). 1206control((_;_)). 1207control((_->_)). 1208control((_*->_)). 1209control((!)). 1210 1211%% current_visible(@Module, @PredicateIndicator). 1212% 1213% FIXME check with documentation 1214 1215current_visible(Module, Name/Arity) :- 1216 atom(Name), integer(Arity), !, 1217 functor(Head, Name, Arity), 1218 predicate_property(Module:Head, visible). 1219current_visible(Module, Name/Arity) :- 1220 predicate_property(Module:Head, visible), 1221 functor(Head, Name, Arity). 1222 1223%% current_signal(?Signal, ?Mode) is nondet. 1224% 1225% True when Mode is the current mode for handling Signal. Modes 1226% are =on=, =off=, =default=, =ignore=. Signals are =abort=, 1227% =alarm=, =interrupt=, =pipe=, =quit=, =termination=, =user_1= 1228% and =user_2=. 1229% 1230% @tbd Implement 1231 1232current_signal(_,_) :- fail. 1233 1234 1235%% digit(+A). 1236% 1237% Is the character A a digit [0-9] 1238digit(A) :- 1239 char_type(A, digit). 1240 1241%% letter(+A). 1242% 1243% Is the character A a letter [A-Za-z] 1244letter(A) :- 1245 char_type(A, alpha). 1246 1247 /******************************* 1248 * ARITHMETIC * 1249 *******************************/ 1250 1251:- arithmetic_function(system:time/0). 1252:- arithmetic_function(system:trunc/1). 1253:- arithmetic_function(system:ln/1). 1254:- arithmetic_function(system:minint/0). 1255:- arithmetic_function(system:maxint/0). 1256:- arithmetic_function(system:dbsize/0). 1257:- arithmetic_function(system:dbused/0). 1258:- arithmetic_function(system:ssize/0). 1259:- arithmetic_function(system:gused/0). 1260:- arithmetic_function(system:lused/0). 1261:- arithmetic_function(system:tused/0). 1262 1263system:time(Time) :- 1264 get_time(GetTime), 1265 Time is round(GetTime). % Time in seconds since 1970-01-01 00:00:00 UTC 1266system:trunc(Val, Trunc) :- 1267 Trunc is truncate(Val). 1268system:ln(Val, Log) :- 1269 Log is log(Val). 1270system:minint(MinInt) :- 1271 MinInt is -1<<31. 1272system:maxint(MaxInt) :- 1273 MaxInt is 1<<31 - 1. 1274system:dbsize(0). 1275system:dbused(0). 1276system:ssize(Size) :- 1277 statistics(globallimit, Size). 1278system:gused(Size) :- 1279 statistics(globalused, Size). 1280system:lused(Size) :- 1281 statistics(localused, Size). 1282system:tused(Size) :- 1283 statistics(trailused, Size). 1284 1285 1286 /******************************* 1287 * MESSAGES * 1288 *******************************/ 1289 1290prolog:message(ifprolog_format(IFC)) --> 1291 [ 'Unknown specifier for write_formatted/3: ~c'-[IFC] ]. 1292 1293 1294 /******************************* 1295 * COLOUR SUPPORT * 1296 *******************************/ 1297 1298:- multifile 1299 prolog_colour:style/2, 1300 prolog_colour:goal_colours/2. 1301 1302prolog_colour:goal_colours(meta(_), 1303 ifprolog-[predicates]). 1304prolog_colour:goal_colours(private(_), 1305 ifprolog-[predicates]). 1306prolog_colour:goal_colours(import(Module,_), 1307 ifprolog-[module(Module),predicates]). 1308prolog_colour:goal_colours(begin_module(Module), 1309 ifprolog-[module(Module)]). 1310prolog_colour:goal_colours(end_module(Module), 1311 ifprolog-[module(Module)]). 1312prolog_colour:goal_colours(end_module, 1313 ifprolog-[]). 1314prolog_colour:goal_colours(nonotify, 1315 ifprolog-[]). 1316 1317prolog_colour:style(goal(ifprolog,_), [ colour(blue), background(lightcyan) ]). 1318