View source with raw comments or as raw
    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	    prolog_flag/2,		% +Flag, -Value
   62
   63	    statistics/2,		% ?Key, ?Value
   64
   65	    op(1150, fx, (block)),
   66	    op(1150, fx, (mode)),
   67	    op(900, fy, (spy)),
   68	    op(900, fy, (nospy))
   69	  ]).   70
   71:- use_module(sicstus/block).   72:- use_module(library(occurs)).   73:- use_module(library(debug)).   74:- use_module(library(error)).   75:- use_module(library(lists)).   76:- use_module(library(arithmetic)).

SICStus 3 compatibility library

This library is intended to be activated using the directive below in files that are designed for use with SICStus Prolog 3. The changes are in effect until the end of the file and in each file loaded from this file.

:- expects_dialect(sicstus).

This library only provides compatibility with version 3 of SICStus Prolog. For SICStus Prolog 4 compatibility, use library(dialect/sicstus4) instead.

To be done
- The dialect-compatibility packages are developed in a `demand-driven' fashion. Please contribute to this package. */
   98% SICStus built-in operators that SWI doesn't declare by default.
   99:- op(1150, fx, user:(mode)).  100:- op(900, fy, user:(spy)).  101:- op(900, fy, user:(nospy)).  102
  103:- multifile
  104	system:goal_expansion/2.  105
  106
  107		 /*******************************
  108		 *	    LIBRARY SETUP	*
  109		 *******************************/
 push_sicstus_library
Pushes searching for dialect/sicstus in front of every library directory that contains such as sub-directory.
  116push_sicstus_library :-
  117	(   absolute_file_name(library(dialect/sicstus), Dir,
  118			       [ file_type(directory),
  119				 access(read),
  120				 solutions(all),
  121				 file_errors(fail)
  122			       ]),
  123	    asserta((user:file_search_path(library, Dir) :-
  124		    prolog_load_context(dialect, sicstus))),
  125	    fail
  126	;   true
  127	).
  128
  129
  130:- push_sicstus_library.  131
  132
  133in_sicstus_dialect :-
  134	(   prolog_load_context(dialect, sicstus)
  135	->  true
  136	;   prolog_load_context(dialect, sicstus4)
  137	).
  138
  139
  140		 /*******************************
  141		 *	      OPERATORS		*
  142		 *******************************/
  143
  144%	declare all operators globally
  145
  146user:goal_expansion(op(Pri,Ass,Name),
  147		    op(Pri,Ass,user:Name)) :-
  148	\+ qualified(Name),
  149	in_sicstus_dialect.
  150
  151qualified(Var) :- var(Var), !, fail.
  152qualified(_:_).
  153
  154% Import all operators from a module, even when using an explicit list
  155% of imports. This simulates the SICStus behavior, where operators are
  156% not module-sensitive and don't need to be listed in import lists.
  157
  158user:goal_expansion(use_module(Module,Imports),
  159		    use_module(Module,[op(_,_,_)|Imports])) :-
  160	in_sicstus_dialect,
  161	% Prevent infinite recursion.
  162	\+ 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.

  174setup_dialect :-
  175	current_prolog_flag(print_write_options, Options),
  176	(   selectchk(quoted(true), Options, OptionsNoQuoted)
  177	->  set_prolog_flag(print_write_options, OptionsNoQuoted)
  178	;   true
  179	).
  180
  181
  182		 /*******************************
  183		 *	      CONTROL		*
  184		 *******************************/
  185
  186:- meta_predicate
  187	if(0,0,0).  188
  189system:goal_expansion(if(If,Then,Else),
  190		      (If *-> Then ; Else)) :-
  191	in_sicstus_dialect,
  192	\+ (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).
  200if(If, Then, Else) :-
  201	(   If
  202	*-> Then
  203	;   Else
  204	).
  205
  206
  207		 /*******************************
  208		 *	  LIBRARY MODULES	*
  209		 *******************************/
 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.
  218:- multifile
  219	rename_module/2.  220
  221system:goal_expansion(M:Goal, SicstusM:Goal) :-
  222	atom(M),
  223	rename_module(M, SicstusM),
  224	prolog_load_context(dialect, sicstus).
  225
  226
  227		 /*******************************
  228		 *	     MODULES		*
  229		 *******************************/
  230
  231% SICStus use_module/1 does not require the target to be a module.
  232
  233system:goal_expansion(use_module(File), load_files(File, [if(changed)])) :-
  234	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.

  248use_module(Module, File, Imports) :-
  249	atom(Module), !,
  250	module_property(Module, file(Path)),
  251	use_module(Path, Imports),
  252	ignore(File = Path).
  253use_module(Module, File, Imports) :-
  254	ground(File), !,
  255	absolute_file_name(File, Path,
  256			   [ file_type(prolog),
  257			     access(read)
  258			   ]),
  259	use_module(Path, Imports),
  260	module_property(Module, file(Path)).
  261use_module(Module, _, _Imports) :-
  262	instantiation_error(Module).
  263
  264
  265		 /*******************************
  266		 *	 FOREIGN RESOURCES      *
  267		 *******************************/
  268
  269/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  270SICStus uses foreign_resource(Name, Functions) and predicate definitions
  271similar to Quintus. qpforeign can generate  the   glue  code that can be
  272linked with swipl-ld. This  part  of   the  emulation  merely  skips the
  273declarations and Maps load_foreign_resource   to load_foreign_resource/2
  274from library(qpforeign).
  275- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  276
  277system:term_expansion(
  278	   (:- load_foreign_resource(Base)),
  279	   (:- initialization(load_foreign_resource(M:Base, Source), now))) :-
  280	prolog_load_context(source, Source),
  281	prolog_load_context(module, M).
  282system:term_expansion(
  283	   (:- module(Name, Exports, Options)),
  284	   [ (:- module(Name, Exports))
  285	   | Declarations
  286	   ]) :-
  287	(prolog_load_context(dialect, sicstus) ; prolog_load_context(dialect, sicstus4)),
  288	phrase(sicstus_module_decls(Options), Declarations).
  289
  290sicstus_module_decls([]) --> [].
  291sicstus_module_decls([H|T]) -->
  292	sicstus_module_decl(H),
  293	sicstus_module_decls(T).
  294
  295sicstus_module_decl(hidden(true)) --> !,
  296	[(:- set_prolog_flag(generate_debug_info, false))].
  297sicstus_module_decl(_) -->
  298	[].
  299
  300
  301		 /*******************************
  302		 *	       BB_*		*
  303		 *******************************/
  304
  305:- meta_predicate
  306	bb_put(:, +),
  307	bb_get(:, -),
  308	bb_delete(:, -),
  309	bb_update(:, -, +).  310
  311system:goal_expansion(bb_put(Key, Value), nb_setval(Atom, Value)) :-
  312	bb_key(Key, Atom).
  313system:goal_expansion(bb_get(Key, Value), nb_current(Atom, Value)) :-
  314	bb_key(Key, Atom).
  315system:goal_expansion(bb_delete(Key, Value),
  316		      (	  nb_current(Atom, Value),
  317			  nb_delete(Atom)
  318		      )) :-
  319	bb_key(Key, Atom).
  320system:goal_expansion(bb_update(Key, Old, New),
  321		      (	  nb_current(Atom, Old),
  322			  nb_setval(Atom, New)
  323		      )) :-
  324	bb_key(Key, Atom).
  325
  326bb_key(Module:Key, Atom) :-
  327	atom(Module), !,
  328	atomic(Key),
  329	atomic_list_concat([Module, Key], :, Atom).
  330bb_key(Key, Atom) :-
  331	atomic(Key),
  332	prolog_load_context(module, Module),
  333	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.
  345bb_put(Key, Value) :-
  346	bb_key(Key, Name),
  347	nb_setval(Name, Value).
  348bb_get(Key, Value) :-
  349	bb_key(Key, Name),
  350	nb_current(Name, Value).
  351bb_delete(Key, Value) :-
  352	bb_key(Key, Name),
  353	nb_current(Name, Value),
  354	nb_delete(Name).
  355bb_update(Key, Old, New) :-
  356	bb_key(Key, Name),
  357	nb_current(Name, Old),
  358	nb_setval(Name, New).
  359
  360
  361		 /*******************************
  362		 *	     MUTABLES		*
  363		 *******************************/
 is_mutable(@Term) is det
True if Term is bound to a mutable term.
Compatibility
- sicstus
  371is_mutable(Term) :-
  372	nonvar(Term),
  373	functor(Term, '$mutable', 2).
 create_mutable(?Value, -Mutable) is det
Create a mutable term with the given initial Value.
Compatibility
- sicstus
  381create_mutable(Value, '$mutable'(Value,_)).
 get_mutable(?Value, +Mutable) is semidet
True if Value unifies with the current value of Mutable.
Compatibility
- sicstus
  389get_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
  399update_mutable(Value, Mutable) :-
  400	functor(Mutable, '$mutable', 2), !,
  401	setarg(1, Mutable, Value).
  402update_mutable(_, Mutable) :-
  403	type_error(mutable, Mutable).
  404
  405
  406		 /*******************************
  407		 *	   LINE READING		*
  408		 *******************************/
 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
  420read_line(Codes) :-
  421    read_line_to_codes(current_input, Codes).
  422
  423read_line(Stream, Codes) :-
  424    read_line_to_codes(Stream, Codes).
  425
  426% Emulate the SICStus behavior of at_end_of_stream, which silently fails
  427% instead of blocking if reading from the stream would block.
  428% Also fails silently if Stream is not actually a valid stream.
  429
  430sicstus_is_readable_stream(Stream) :-
  431	is_stream(Stream),
  432	stream_property(Stream, end_of_stream(not)).
  433
  434user:goal_expansion(at_end_of_stream(Stream), \+ sicstus_is_readable_stream(Stream)) :-
  435	in_sicstus_dialect.
  436
  437user:goal_expansion(at_end_of_stream, \+ sicstus_is_readable_stream(current_input)) :-
  438	in_sicstus_dialect.
  439
  440
  441		 /*******************************
  442		 *  COROUTINING & CONSTRAINTS	*
  443		 *******************************/
  444
  445/* This is more complicated.  Gertjan van Noord decided to use
  446   copy_term/3 in Alpino.
  447
  448%%	call_residue(:Goal, -Residue) is nondet.
  449%
  450%	Residue is a list of VarSet-Goal.  Note that this implementation
  451%	is   incomplete.   Please   consult     the   documentation   of
  452%	call_residue_vars/2 for known issues.
  453
  454:- meta_predicate
  455	call_residue(0, -).
  456
  457call_residue(Goal, Residue) :-
  458	call_residue_vars(Goal, Vars),
  459	(   Vars == []
  460	->  Residue = []
  461	;   copy_term(Vars, _AllVars, Goals),
  462	    phrase(vars_by_goal(Goals), Residue)
  463	).
  464
  465vars_by_goal((A,B)) --> !,
  466	vars_by_goal(A),
  467	vars_by_goal(B).
  468vars_by_goal(Goal) -->
  469	{ term_attvars(Goal, AttVars),
  470	  sort(AttVars, VarSet)
  471	},
  472	[ VarSet-Goal ].
  473*/
 trimcore
Trims the stacks. Other tasks of the SICStus trimcore/0 are automatically scheduled by SWI-Prolog.
  480trimcore :-
  481	trim_stacks.
  482
  483
  484		 /*******************************
  485		 *	       FLAGS		*
  486		 *******************************/
 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.
  493prolog_flag(Flag, Old, New) :-
  494	debug(prolog_flag, 'prolog_flag(~q, ~q, ~q)', [Flag, Old, New]),
  495	current_prolog_flag(Flag, Old),
  496	set_prolog_flag(Flag, New).
 prolog_flag(+Flag, -Value) is semidet
Query a Prolog flag, mapping SICSTus flags to SWI-Prolog flags
  502prolog_flag(Flag, Value) :-
  503	debug(prolog_flag, 'prolog_flag(~q, ~q)', [Flag, Value]),
  504	sicstus_flag(Flag, Value).
  505
  506sicstus_flag(host_type, HostType) :- !,
  507	% Not a perfect emulation. SWI's arch flag only contains the
  508	% architecture and OS family (e. g. 'x86_64-darwin'),
  509	% but SICStus host_type also contains the OS version number
  510	% (e. g. 'x86_64-darwin-15.6.0').
  511	% But this works well enough for code that just checks the
  512	% architecture/OS part and not the exact version.
  513	current_prolog_flag(arch, HostType).
  514sicstus_flag(system_type, Type) :- !,
  515	(   current_prolog_flag(saved_program, true)
  516	->  Type = runtime
  517	;   Type = development
  518	).
  519sicstus_flag(Name, Value) :-
  520	current_prolog_flag(Name, Value).
  521
  522
  523% As of SICStus 3.2.11, the following statistics/2 keys are still missing:
  524% * choice
  525
  526statistics(heap, Stats) :- !, system:statistics(program, Stats).
  527statistics(garbage_collection, [Count, Freed, Time]) :- !,
  528	% Remove fourth list element (SWI extension).
  529	system:statistics(garbage_collection, [Count, Freed, Time|_]).
  530statistics(atoms, [H|T]) :- !,
  531	% SWI natively provides two different values under the atoms key:
  532	% the number of atoms as a single integer,
  533	% and a Quintus/SICStus-compatible list of atom usage statistics.
  534	% Which value is returned when calling statistics(atoms, X)
  535	% depends on the value of X before the call:
  536	% if X is unbound, the single integer is returned,
  537	% but if X is already bound to a (usually non-ground) list,
  538	% the list of statistics is returned instead.
  539
  540	% Here we just force the list to be returned in all cases
  541	% if SICStus emulation is active, by forcing the second argument
  542	% to be bound to a list.
  543	system:statistics(atoms, [H|T]).
  544
  545statistics(Keyword, Value) :- system:statistics(Keyword, Value).
  546
  547
  548		 /*******************************
  549		 *	     ARITHMETIC		*
  550		 *******************************/
  551
  552% Provide (#)/2 as arithmetic function.  Ideally, we should be able to
  553% bind multiple names to built-in functions.  This is rather slow.  We
  554% could also consider adding # internally, but not turning it into an
  555% operator.
  556
  557:- op(500, yfx, user:(#)).  558
  559:- arithmetic_function(user:(#)/2).  560
  561user:(#(X,Y,R)) :-
  562	R is xor(X,Y).
  563
  564
  565		 /*******************************
  566		 *	       HACKS		*
  567		 *******************************/
 prolog:$breaklevel(-BreakLevel, Unknown)
Query the current break-level
  573prolog:'$breaklevel'(BreakLevel, _) :-
  574	current_prolog_flag(break_level, BreakLevel), !.
  575prolog:'$breaklevel'(0, _)