View source with formatted 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
   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)).   76
   77
   78/** <module> SICStus 3 compatibility library
   79
   80This library is intended to be activated   using  the directive below in
   81files that are designed for use with   SICStus Prolog 3. The changes are
   82in effect until the end of the file   and  in each file loaded from this
   83file.
   84
   85    ==
   86    :- expects_dialect(sicstus).
   87    ==
   88
   89This library only provides  compatibility  with   version  3  of SICStus
   90Prolog.     For     SICStus     Prolog      4     compatibility,     use
   91library(dialect/sicstus4) instead.
   92
   93@tbd	The dialect-compatibility packages are developed in a
   94	`demand-driven' fashion.  Please contribute to this package.
   95*/
   96
   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		 *******************************/
  109
  110%%	push_sicstus_library
  111%
  112%	Pushes searching for dialect/sicstus in   front of every library
  113%	directory that contains such as sub-directory.
  114
  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).
  162
  163%%	setup_dialect
  164%
  165%	Further dialect initialization.
  166%
  167%	Currently this disables quoting when printing atoms,
  168%	which SWI does by default, but SICStus doesn't.
  169%	This globally modifies the print_write_options Prolog flag,
  170%	so this change also affects code that doesn't request
  171%	SICStus compatibility.
  172
  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 == !).
  192
  193%%	if(:If, :Then, :Else)
  194%
  195%	Same  as  SWI-Prolog  soft-cut  construct.   Normally,  this  is
  196%	translated using goal-expansion. If either term contains a !, we
  197%	use meta-calling for full compatibility (i.e., scoping the cut).
  198
  199if(If, Then, Else) :-
  200	(   If
  201	*-> Then
  202	;   Else
  203	).
  204
  205
  206		 /*******************************
  207		 *	  LIBRARY MODULES	*
  208		 *******************************/
  209
  210%%	rename_module(?SICStusModule, ?RenamedSICSTusModule) is nondet.
  211%
  212%	True if RenamedSICSTusModule is the  name   that  we use for the
  213%	SICStus native module SICStusModule. We do  this in places where
  214%	the module-name conflicts. All explicitely   qualified goals are
  215%	mapped to the SICStus equivalent of the module.
  216
  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).
  234
  235%%	use_module(+Module, -File, +Imports) is det.
  236%%	use_module(-Module, +File, +Imports) is det.
  237%
  238%	This predicate can be used to import   from a named module while
  239%	the file-location of the module is unknown   or to get access to
  240%	the module-name loaded from a file.
  241%
  242%	If both Module and File are  given,   we  use  Module and try to
  243%	unify File with the absolute  canonical   path  to the file from
  244%	which Module was loaded. However, we   succeed regardless of the
  245%	success of this unification.
  246
  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).
  333
  334%%	bb_put(:Name, +Value) is det.
  335%%	bb_get(:Name, -Value) is semidet.
  336%%	bb_delete(:Name, -Value) is semidet.
  337%%	bb_update(:Name, -Old, +New) is semidet.
  338%
  339%	SICStus compatible blackboard routines. The implementations only
  340%	deal with cases where the module-sensitive   key  is unknown and
  341%	meta-calling. Simple cases are  directly   mapped  to SWI-Prolog
  342%	non-backtrackable global variables.
  343
  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		 *******************************/
  363
  364%%	is_mutable(@Term) is det.
  365%
  366%	True if Term is bound to a mutable term.
  367%
  368%	@compat sicstus
  369
  370is_mutable(Term) :-
  371	nonvar(Term),
  372	functor(Term, '$mutable', 2).
  373
  374%%	create_mutable(?Value, -Mutable) is det.
  375%
  376%	Create a mutable term with the given initial Value.
  377%
  378%	@compat sicstus
  379
  380create_mutable(Value, '$mutable'(Value,_)).
  381
  382%%	get_mutable(?Value, +Mutable) is semidet.
  383%
  384%	True if Value unifies with the current value of Mutable.
  385%
  386%	@compat sicstus
  387
  388get_mutable(Value, '$mutable'(Value,_)).
  389
  390%%	update_mutable(?Value, !Mutable) is det.
  391%
  392%	Set the value of Mutable to Value.  The old binding is
  393%	restored on backtracking.
  394%
  395%	@see setarg/3.
  396%	@compat sicstus
  397
  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		 *******************************/
  408
  409%%	read_line(-Codes) is det.
  410%%	read_line(+Stream, -Codes) is det.
  411%
  412%	Read a line from the given or  current input. The line read does
  413%	_not_ include the line-termination character. Unifies Codes with
  414%	=end_of_file= if the end of the input is reached.
  415%
  416%	@compat sicstus
  417%	@see	The SWI-Prolog primitive is read_line_to_codes/2.
  418
  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*/
  473
  474%%	trimcore is det.
  475%
  476%	Trims the stacks and releases unused heap memory to the
  477%	operating system where possible. Other tasks of the SICStus
  478%	trimcore/0 are automatically scheduled by SWI-Prolog.
  479
  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]).  490
  491%%	prolog_flag(+Flag, -Old, +New) is semidet.
  492%
  493%	Query and set a Prolog flag. Use the debug/1 topic =prolog_flag=
  494%	to find the flags accessed using this predicate.
  495
  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		 *******************************/
  575
  576%%	prolog:'$breaklevel'(-BreakLevel, Unknown)
  577%
  578%	Query the current break-level
  579
  580prolog:'$breaklevel'(BreakLevel, _) :-
  581	current_prolog_flag(break_level, BreakLevel), !.
  582prolog:'$breaklevel'(0, _)