1/*  Part of SWI-Prolog
    2
    3    Author:        Jan Wielemaker
    4    E-mail:        J.Wielemaker@vu.nl
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (c)  2010-2014, 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(sicstus,
   36	  [ (block)/1,			% +Heads
   37
   38	    if/3,			% :If, :Then, :Else
   39
   40	    use_module/3,		% ?Module, ?File, +Imports
   41
   42	    bb_put/2,			% :Key, +Value
   43	    bb_get/2,			% :Key, -Value
   44	    bb_delete/2,		% :Key, -Value
   45	    bb_update/3,		% :Key, -Old, +New
   46
   47	    is_mutable/1,		% @Term
   48	    create_mutable/2,		% ?Value, -Mutable
   49	    get_mutable/2,		% ?Value, +Mutable
   50	    update_mutable/2,		% ?Value, !Mutable
   51
   52	    sicstus_is_readable_stream/1, % +Stream
   53	    read_line/1,		% -Codes
   54	    read_line/2,		% +Stream, -Codes
   55
   56	    trimcore/0,
   57
   58%	    call_residue/2,		% :Goal, -Residue
   59
   60	    prolog_flag/3,		% +Flag, -Old, +New
   61
   62	    statistics/2,		% ?Key, ?Value
   63
   64	    op(1150, fx, (block)),
   65	    op(1150, fx, (mode)),
   66	    op(900, fy, (spy)),
   67	    op(900, fy, (nospy))
   68	  ]).   69
   70:- use_module(sicstus/block).   71:- use_module(library(occurs)).   72:- use_module(library(debug)).   73:- use_module(library(error)).   74:- use_module(library(lists)).   75:- use_module(library(arithmetic)).

:- expects_dialect(sicstus).

   97% SICStus built-in operators that SWI doesn't declare by default.
   98:- op(1150, fx, user:(mode)).   99:- op(900, fy, user:(spy)).  100:- op(900, fy, user:(nospy)).  101
  102:- multifile
  103	system:goal_expansion/2.  104
  105
  106		 /*******************************
  107		 *	    LIBRARY SETUP	*
  108		 *******************************/

 push_sicstus_library

Pushes searching for dialect/sicstus in front of every library directory that contains such as sub-directory.

  115push_sicstus_library :-
  116	(   absolute_file_name(library(dialect/sicstus), Dir,
  117			       [ file_type(directory),
  118				 access(read),
  119				 solutions(all),
  120				 file_errors(fail)
  121			       ]),
  122	    asserta((user:file_search_path(library, Dir) :-
  123		    prolog_load_context(dialect, sicstus))),
  124	    fail
  125	;   true
  126	).
  127
  128
  129:- push_sicstus_library.  130
  131
  132in_sicstus_dialect :-
  133	(   prolog_load_context(dialect, sicstus)
  134	->  true
  135	;   prolog_load_context(dialect, sicstus4)
  136	).
  137
  138
  139		 /*******************************
  140		 *	      OPERATORS		*
  141		 *******************************/
  142
  143%	declare all operators globally
  144
  145user:goal_expansion(op(Pri,Ass,Name),
  146		    op(Pri,Ass,user:Name)) :-
  147	\+ qualified(Name),
  148	in_sicstus_dialect.
  149
  150qualified(Var) :- var(Var), !, fail.
  151qualified(_:_).
  152
  153% Import all operators from a module, even when using an explicit list
  154% of imports. This simulates the SICStus behavior, where operators are
  155% not module-sensitive and don't need to be listed in import lists.
  156
  157user:goal_expansion(use_module(Module,Imports),
  158		    use_module(Module,[op(_,_,_)|Imports])) :-
  159	in_sicstus_dialect,
  160	% Prevent infinite recursion.
  161	\+ memberchk(op(_,_,_),Imports).

 setup_dialect

Further dialect initialization.

Currently this disables quoting when printing atoms, which SWI does by default, but SICStus doesn't. This globally modifies the print_write_options Prolog flag, so this change also affects code that doesn't request SICStus compatibility.

  173setup_dialect :-
  174	current_prolog_flag(print_write_options, Options),
  175	(   selectchk(quoted(true), Options, OptionsNoQuoted)
  176	->  set_prolog_flag(print_write_options, OptionsNoQuoted)
  177	;   true
  178	).
  179
  180
  181		 /*******************************
  182		 *	      CONTROL		*
  183		 *******************************/
  184
  185:- meta_predicate
  186	if(0,0,0).  187
  188system:goal_expansion(if(If,Then,Else),
  189		      (If *-> Then ; Else)) :-
  190	in_sicstus_dialect,
  191	\+ (sub_term(X, [If,Then,Else]), X == !).

 if(:If, :Then, :Else)

Same as SWI-Prolog soft-cut construct. Normally, this is translated using goal-expansion. If either term contains a !, we use meta-calling for full compatibility (i.e., scoping the cut).

  199if(If, Then, Else) :-
  200	(   If
  201	*-> Then
  202	;   Else
  203	).
  204
  205
  206		 /*******************************
  207		 *	  LIBRARY MODULES	*
  208		 *******************************/

 rename_module(?SICStusModule, ?RenamedSICSTusModule) is nondet

True if RenamedSICSTusModule is the name that we use for the SICStus native module SICStusModule. We do this in places where the module-name conflicts. All explicitely qualified goals are mapped to the SICStus equivalent of the module.

  217:- multifile
  218	rename_module/2.  219
  220system:goal_expansion(M:Goal, SicstusM:Goal) :-
  221	atom(M),
  222	rename_module(M, SicstusM),
  223	prolog_load_context(dialect, sicstus).
  224
  225
  226		 /*******************************
  227		 *	     MODULES		*
  228		 *******************************/
  229
  230% SICStus use_module/1 does not require the target to be a module.
  231
  232system:goal_expansion(use_module(File), load_files(File, [if(changed)])) :-
  233	prolog_load_context(dialect, sicstus).

 use_module(+Module, -File, +Imports) is det

use_module(-Module, +File, +Imports) is det

This predicate can be used to import from a named module while the file-location of the module is unknown or to get access to the module-name loaded from a file.

If both Module and File are given, we use Module and try to unify File with the absolute canonical path to the file from which Module was loaded. However, we succeed regardless of the success of this unification.

  247use_module(Module, File, Imports) :-
  248	atom(Module), !,
  249	module_property(Module, file(Path)),
  250	use_module(Path, Imports),
  251	ignore(File = Path).
  252use_module(Module, File, Imports) :-
  253	ground(File), !,
  254	absolute_file_name(File, Path,
  255			   [ file_type(prolog),
  256			     access(read)
  257			   ]),
  258	use_module(Path, Imports),
  259	module_property(Module, file(Path)).
  260use_module(Module, _, _Imports) :-
  261	instantiation_error(Module).
  262
  263
  264		 /*******************************
  265		 *	 FOREIGN RESOURCES      *
  266		 *******************************/
  267
  268/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  269SICStus uses foreign_resource(Name, Functions) and predicate definitions
  270similar to Quintus. qpforeign can generate  the   glue  code that can be
  271linked with swipl-ld. This  part  of   the  emulation  merely  skips the
  272declarations and Maps load_foreign_resource   to load_foreign_resource/2
  273from library(qpforeign).
  274- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  275
  276system:term_expansion(
  277	   (:- load_foreign_resource(Base)),
  278	   (:- initialization(load_foreign_resource(M:Base, Source), now))) :-
  279	prolog_load_context(source, Source),
  280	prolog_load_context(module, M).
  281system:term_expansion(
  282	   (:- module(Name, Exports, Options)),
  283	   [ (:- module(Name, Exports))
  284	   | Declarations
  285	   ]) :-
  286	(prolog_load_context(dialect, sicstus) ; prolog_load_context(dialect, sicstus4)),
  287	phrase(sicstus_module_decls(Options), Declarations).
  288
  289sicstus_module_decls([]) --> [].
  290sicstus_module_decls([H|T]) -->
  291	sicstus_module_decl(H),
  292	sicstus_module_decls(T).
  293
  294sicstus_module_decl(hidden(true)) --> !,
  295	[(:- set_prolog_flag(generate_debug_info, false))].
  296sicstus_module_decl(_) -->
  297	[].
  298
  299
  300		 /*******************************
  301		 *	       BB_*		*
  302		 *******************************/
  303
  304:- meta_predicate
  305	bb_put(:, +),
  306	bb_get(:, -),
  307	bb_delete(:, -),
  308	bb_update(:, -, +).  309
  310system:goal_expansion(bb_put(Key, Value), nb_setval(Atom, Value)) :-
  311	bb_key(Key, Atom).
  312system:goal_expansion(bb_get(Key, Value), nb_current(Atom, Value)) :-
  313	bb_key(Key, Atom).
  314system:goal_expansion(bb_delete(Key, Value),
  315		      (	  nb_current(Atom, Value),
  316			  nb_delete(Atom)
  317		      )) :-
  318	bb_key(Key, Atom).
  319system:goal_expansion(bb_update(Key, Old, New),
  320		      (	  nb_current(Atom, Old),
  321			  nb_setval(Atom, New)
  322		      )) :-
  323	bb_key(Key, Atom).
  324
  325bb_key(Module:Key, Atom) :-
  326	atom(Module), !,
  327	atomic(Key),
  328	atomic_list_concat([Module, Key], :, Atom).
  329bb_key(Key, Atom) :-
  330	atomic(Key),
  331	prolog_load_context(module, Module),
  332	atomic_list_concat([Module, Key], :, Atom).

 bb_put(:Name, +Value) is det

 bb_get(:Name, -Value) is semidet

 bb_delete(:Name, -Value) is semidet

 bb_update(:Name, -Old, +New) is semidet

SICStus compatible blackboard routines. The implementations only deal with cases where the module-sensitive key is unknown and meta-calling. Simple cases are directly mapped to SWI-Prolog non-backtrackable global variables.

  344bb_put(Key, Value) :-
  345	bb_key(Key, Name),
  346	nb_setval(Name, Value).
  347bb_get(Key, Value) :-
  348	bb_key(Key, Name),
  349	nb_current(Name, Value).
  350bb_delete(Key, Value) :-
  351	bb_key(Key, Name),
  352	nb_current(Name, Value),
  353	nb_delete(Name).
  354bb_update(Key, Old, New) :-
  355	bb_key(Key, Name),
  356	nb_current(Name, Old),
  357	nb_setval(Name, New).
  358
  359
  360		 /*******************************
  361		 *	     MUTABLES		*
  362		 *******************************/

 is_mutable(@Term) is det

True if Term is bound to a mutable term.

Compatibility

- sicstus

  370is_mutable(Term) :-
  371	nonvar(Term),
  372	functor(Term, '$mutable', 2).

 create_mutable(?Value, -Mutable) is det

Create a mutable term with the given initial Value.

Compatibility

- sicstus

  380create_mutable(Value, '$mutable'(Value,_)).

 get_mutable(?Value, +Mutable) is semidet

True if Value unifies with the current value of Mutable.

Compatibility

- sicstus

  388get_mutable(Value, '$mutable'(Value,_)).

 update_mutable(?Value, !Mutable) is det

Set the value of Mutable to Value. The old binding is restored on backtracking.

See also

- setarg/3.

Compatibility

- sicstus

  398update_mutable(Value, Mutable) :-
  399	functor(Mutable, '$mutable', 2), !,
  400	setarg(1, Mutable, Value).
  401update_mutable(_, Mutable) :-
  402	type_error(mutable, Mutable).
  403
  404
  405		 /*******************************
  406		 *	   LINE READING		*
  407		 *******************************/

 read_line(-Codes) is det

 read_line(+Stream, -Codes) is det

Read a line from the given or current input. The line read does not include the line-termination character. Unifies Codes with end_of_file if the end of the input is reached.

See also

- The SWI-Prolog primitive is read_line_to_codes/2.

Compatibility

- sicstus

  419read_line(Codes) :-
  420    read_line_to_codes(current_input, Codes).
  421
  422read_line(Stream, Codes) :-
  423    read_line_to_codes(Stream, Codes).
  424
  425% Emulate the SICStus behavior of at_end_of_stream, which silently fails
  426% instead of blocking if reading from the stream would block.
  427% Also fails silently if Stream is not actually a valid stream.
  428
  429sicstus_is_readable_stream(Stream) :-
  430	is_stream(Stream),
  431	stream_property(Stream, end_of_stream(not)).
  432
  433user:goal_expansion(at_end_of_stream(Stream), \+ sicstus_is_readable_stream(Stream)) :-
  434	in_sicstus_dialect.
  435
  436user:goal_expansion(at_end_of_stream, \+ sicstus_is_readable_stream(current_input)) :-
  437	in_sicstus_dialect.
  438
  439
  440		 /*******************************
  441		 *  COROUTINING & CONSTRAINTS	*
  442		 *******************************/
  443
  444/* This is more complicated.  Gertjan van Noord decided to use
  445   copy_term/3 in Alpino.
  446
  447%%	call_residue(:Goal, -Residue) is nondet.
  448%
  449%	Residue is a list of VarSet-Goal.  Note that this implementation
  450%	is   incomplete.   Please   consult     the   documentation   of
  451%	call_residue_vars/2 for known issues.
  452
  453:- meta_predicate
  454	call_residue(0, -).
  455
  456call_residue(Goal, Residue) :-
  457	call_residue_vars(Goal, Vars),
  458	(   Vars == []
  459	->  Residue = []
  460	;   copy_term(Vars, _AllVars, Goals),
  461	    phrase(vars_by_goal(Goals), Residue)
  462	).
  463
  464vars_by_goal((A,B)) --> !,
  465	vars_by_goal(A),
  466	vars_by_goal(B).
  467vars_by_goal(Goal) -->
  468	{ term_attvars(Goal, AttVars),
  469	  sort(AttVars, VarSet)
  470	},
  471	[ VarSet-Goal ].
  472*/

 trimcore is det

Trims the stacks and releases unused heap memory to the operating system where possible. Other tasks of the SICStus trimcore/0 are automatically scheduled by SWI-Prolog.

  480trimcore :-
  481	trim_stacks,
  482	trim_heap.
  483
  484
  485		 /*******************************
  486		 *	       FLAGS		*
  487		 *******************************/
  488
  489:- use_module(library(quintus), [prolog_flag/2 as quintus_flag]).

 prolog_flag(+Flag, -Old, +New) is semidet

Query and set a Prolog flag. Use the debug/1 topic prolog_flag to find the flags accessed using this predicate.

  496prolog_flag(Flag, Old, New) :-
  497	debug(prolog_flag, 'prolog_flag(~q, ~q, ~q)', [Flag, Old, New]),
  498	sicstus_flag(Flag, Old),
  499	set_prolog_flag(Flag, New).
  500
  501:- public sicstus_flag/2.  502
  503sicstus_flag(host_type, HostType) :- !,
  504	% Not a perfect emulation. SWI's arch flag only contains the
  505	% architecture and OS family (e. g. 'x86_64-darwin'),
  506	% but SICStus host_type also contains the OS version number
  507	% (e. g. 'x86_64-darwin-15.6.0').
  508	% But this works well enough for code that just checks the
  509	% architecture/OS part and not the exact version.
  510	current_prolog_flag(arch, HostType).
  511sicstus_flag(system_type, Type) :- !,
  512	(   current_prolog_flag(saved_program, true)
  513	->  Type = runtime
  514	;   Type = development
  515	).
  516sicstus_flag(Name, Value) :-
  517	quintus_flag(Name, Value).
  518
  519% Replace all current_prolog_flag/2 and prolog_flag/2 calls with
  520% sicstus_flag/2. prolog_flag/2 can also be autoloaded from
  521% library(quintus) - this goal expansion ensures that sicstus_flag/2
  522% takes priority when SICStus emulation is active.
  523
  524user:goal_expansion(Goal, sicstus:sicstus_flag(Name, Value)) :-
  525	nonvar(Goal),
  526	(Goal = current_prolog_flag(Name, Value) ; Goal = prolog_flag(Name, Value)),
  527	in_sicstus_dialect.
  528
  529
  530% As of SICStus 3.2.11, the following statistics/2 keys are still missing:
  531% * choice
  532
  533statistics(heap, Stats) :- !, system:statistics(program, Stats).
  534statistics(garbage_collection, [Count, Freed, Time]) :- !,
  535	% Remove fourth list element (SWI extension).
  536	system:statistics(garbage_collection, [Count, Freed, Time|_]).
  537statistics(atoms, [H|T]) :- !,
  538	% SWI natively provides two different values under the atoms key:
  539	% the number of atoms as a single integer,
  540	% and a Quintus/SICStus-compatible list of atom usage statistics.
  541	% Which value is returned when calling statistics(atoms, X)
  542	% depends on the value of X before the call:
  543	% if X is unbound, the single integer is returned,
  544	% but if X is already bound to a (usually non-ground) list,
  545	% the list of statistics is returned instead.
  546
  547	% Here we just force the list to be returned in all cases
  548	% if SICStus emulation is active, by forcing the second argument
  549	% to be bound to a list.
  550	system:statistics(atoms, [H|T]).
  551
  552statistics(Keyword, Value) :- system:statistics(Keyword, Value).
  553
  554
  555		 /*******************************
  556		 *	     ARITHMETIC		*
  557		 *******************************/
  558
  559% Provide (#)/2 as arithmetic function.  Ideally, we should be able to
  560% bind multiple names to built-in functions.  This is rather slow.  We
  561% could also consider adding # internally, but not turning it into an
  562% operator.
  563
  564:- op(500, yfx, user:(#)).  565
  566:- arithmetic_function(user:(#)/2).  567
  568user:(#(X,Y,R)) :-
  569	R is xor(X,Y).
  570
  571
  572		 /*******************************
  573		 *	       HACKS		*
  574		 *******************************/

 prolog:$breaklevel(-BreakLevel, Unknown)

Query the current break-level

  580prolog:'$breaklevel'(BreakLevel, _) :-
  581	current_prolog_flag(break_level, BreakLevel), !.
  582prolog:'$breaklevel'(0, _)