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	    create_mutable/2,		% ?Value, -Mutable
   48	    get_mutable/2,		% ?Value, +Mutable
   49	    update_mutable/2,		% ?Value, !Mutable
   50
   51	    read_line/1,		% -Codes
   52	    read_line/2,		% +Stream, -Codes
   53
   54	    trimcore/0,
   55
   56%	    call_residue/2,		% :Goal, -Residue
   57
   58	    prolog_flag/3,		% +Flag, -Old, +New
   59	    prolog_flag/2,		% +Flag, -Value
   60
   61	    op(1150, fx, (block))
   62	  ]).   63
   64:- use_module(sicstus/block).   65:- use_module(library(occurs)).   66:- use_module(library(debug)).   67:- use_module(library(error)).   68:- use_module(library(lists)).   69:- use_module(library(arithmetic)).

SICStus compatibility library

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

:- expects_dialect(sicstus).
To be done
- The dialect-compatibility packages are developed in a `demand-driven' fashion. Please contribute to this package. */
   86:- multifile
   87	system:goal_expansion/2.   88
   89
   90		 /*******************************
   91		 *	    LIBRARY SETUP	*
   92		 *******************************/
 push_sicstus_library
Pushes searching for dialect/sicstus in front of every library directory that contains such as sub-directory.
   99push_sicstus_library :-
  100	(   absolute_file_name(library(dialect/sicstus), Dir,
  101			       [ file_type(directory),
  102				 access(read),
  103				 solutions(all),
  104				 file_errors(fail)
  105			       ]),
  106	    asserta((user:file_search_path(library, Dir) :-
  107		    prolog_load_context(dialect, sicstus))),
  108	    fail
  109	;   true
  110	).
  111
  112
  113:- push_sicstus_library.  114
  115
  116		 /*******************************
  117		 *	      OPERATORS		*
  118		 *******************************/
  119
  120%	declare all operators globally
  121
  122system:goal_expansion(op(Pri,Ass,Name),
  123		      op(Pri,Ass,user:Name)) :-
  124	\+ qualified(Name),
  125	prolog_load_context(dialect, sicstus).
  126
  127qualified(Var) :- var(Var), !, fail.
  128qualified(_:_).
 setup_dialect
Further dialect initialization.
  135setup_dialect.
  136
  137
  138		 /*******************************
  139		 *	      CONTROL		*
  140		 *******************************/
  141
  142:- meta_predicate
  143	if(0,0,0).  144
  145system:goal_expansion(if(If,Then,Else),
  146		      (If *-> Then ; Else)) :-
  147	prolog_load_context(dialect, sicstus),
  148	\+ (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).
  156if(If, Then, Else) :-
  157	(   If
  158	*-> Then
  159	;   Else
  160	).
  161
  162
  163		 /*******************************
  164		 *	  LIBRARY MODULES	*
  165		 *******************************/
 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.
  174:- multifile
  175	rename_module/2.  176
  177system:goal_expansion(M:Goal, SicstusM:Goal) :-
  178	atom(M),
  179	rename_module(M, SicstusM),
  180	prolog_load_context(dialect, sicstus).
  181
  182
  183		 /*******************************
  184		 *	     MODULES		*
  185		 *******************************/
  186
  187% SICStus use_module/1 does not require the target to be a module.
  188
  189system:goal_expansion(use_module(File), load_files(File, [if(changed)])) :-
  190	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.

  204use_module(Module, File, Imports) :-
  205	atom(Module), !,
  206	module_property(Module, file(Path)),
  207	use_module(Path, Imports),
  208	ignore(File = Path).
  209use_module(Module, File, Imports) :-
  210	ground(File), !,
  211	absolute_file_name(File, Path,
  212			   [ file_type(prolog),
  213			     access(read)
  214			   ]),
  215	use_module(Path, Imports),
  216	module_property(Module, file(Path)).
  217use_module(Module, _, _Imports) :-
  218	instantiation_error(Module).
  219
  220
  221		 /*******************************
  222		 *	 FOREIGN RESOURCES      *
  223		 *******************************/
  224
  225/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  226SICStus uses foreign_resource(Name, Functions) and predicate definitions
  227similar to Quintus. qpforeign can generate  the   glue  code that can be
  228linked with swipl-ld. This  part  of   the  emulation  merely  skips the
  229declarations and Maps load_foreign_resource   to load_foreign_resource/2
  230from library(qpforeign).
  231- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  232
  233system:term_expansion(
  234	   (:- load_foreign_resource(Base)),
  235	   (:- initialization(load_foreign_resource(M:Base, Source), now))) :-
  236	prolog_load_context(source, Source),
  237	prolog_load_context(module, M).
  238system:term_expansion(
  239	   (:- module(Name, Exports, Options)),
  240	   [ (:- module(Name, Exports))
  241	   | Declarations
  242	   ]) :-
  243	prolog_load_context(dialect, sicstus),
  244	phrase(sicstus_module_decls(Options), Declarations).
  245
  246sicstus_module_decls([]) --> [].
  247sicstus_module_decls([H|T]) -->
  248	sicstus_module_decl(H),
  249	sicstus_module_decls(T).
  250
  251sicstus_module_decl(hidden(true)) --> !,
  252	[(:- set_prolog_flag(generate_debug_info, false))].
  253sicstus_module_decl(_) -->
  254	[].
  255
  256
  257		 /*******************************
  258		 *	       BB_*		*
  259		 *******************************/
  260
  261:- meta_predicate
  262	bb_put(:, +),
  263	bb_get(:, -),
  264	bb_delete(:, -),
  265	bb_update(:, -, +).  266
  267system:goal_expansion(bb_put(Key, Value), nb_setval(Atom, Value)) :-
  268	bb_key(Key, Atom).
  269system:goal_expansion(bb_get(Key, Value), nb_current(Atom, Value)) :-
  270	bb_key(Key, Atom).
  271system:goal_expansion(bb_delete(Key, Value),
  272		      (	  nb_current(Atom, Value),
  273			  nb_delete(Atom)
  274		      )) :-
  275	bb_key(Key, Atom).
  276system:goal_expansion(bb_update(Key, Old, New),
  277		      (	  nb_current(Atom, Old),
  278			  nb_setval(Atom, New)
  279		      )) :-
  280	bb_key(Key, Atom).
  281
  282bb_key(Module:Key, Atom) :-
  283	atom(Module), !,
  284	atomic(Key),
  285	atomic_list_concat([Module, Key], :, Atom).
  286bb_key(Key, Atom) :-
  287	atomic(Key),
  288	prolog_load_context(module, Module),
  289	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.
  301bb_put(Key, Value) :-
  302	bb_key(Key, Name),
  303	nb_setval(Name, Value).
  304bb_get(Key, Value) :-
  305	bb_key(Key, Name),
  306	nb_current(Name, Value).
  307bb_delete(Key, Value) :-
  308	bb_key(Key, Name),
  309	nb_current(Name, Value),
  310	nb_delete(Name).
  311bb_update(Key, Old, New) :-
  312	bb_key(Key, Name),
  313	nb_current(Name, Old),
  314	nb_setval(Name, New).
  315
  316
  317		 /*******************************
  318		 *	     MUTABLES		*
  319		 *******************************/
 create_mutable(?Value, -Mutable) is det
Create a mutable term with the given initial Value.
Compatibility
- sicstus
  327create_mutable(Value, '$mutable'(Value,_)).
 get_mutable(?Value, +Mutable) is semidet
True if Value unifies with the current value of Mutable.
Compatibility
- sicstus
  335get_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
  345update_mutable(Value, Mutable) :-
  346	functor(Mutable, '$mutable', 2), !,
  347	setarg(1, Mutable, Value).
  348update_mutable(_, Mutable) :-
  349	type_error(mutable, Mutable).
  350
  351
  352		 /*******************************
  353		 *	   LINE READING		*
  354		 *******************************/
 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
  366read_line(Codes) :-
  367    read_line_to_codes(current_input, Codes).
  368
  369read_line(Stream, Codes) :-
  370    read_line_to_codes(Stream, Codes).
  371
  372
  373		 /*******************************
  374		 *  COROUTINING & CONSTRAINTS	*
  375		 *******************************/
  376
  377/* This is more complicated.  Gertjan van Noord decided to use
  378   copy_term/3 in Alpino.
  379
  380%%	call_residue(:Goal, -Residue) is nondet.
  381%
  382%	Residue is a list of VarSet-Goal.  Note that this implementation
  383%	is   incomplete.   Please   consult     the   documentation   of
  384%	call_residue_vars/2 for known issues.
  385
  386:- meta_predicate
  387	call_residue(0, -).
  388
  389call_residue(Goal, Residue) :-
  390	call_residue_vars(Goal, Vars),
  391	(   Vars == []
  392	->  Residue = []
  393	;   copy_term(Vars, _AllVars, Goals),
  394	    phrase(vars_by_goal(Goals), Residue)
  395	).
  396
  397vars_by_goal((A,B)) --> !,
  398	vars_by_goal(A),
  399	vars_by_goal(B).
  400vars_by_goal(Goal) -->
  401	{ term_attvars(Goal, AttVars),
  402	  sort(AttVars, VarSet)
  403	},
  404	[ VarSet-Goal ].
  405*/
 trimcore
Trims the stacks. Other tasks of the SICStus trimcore/0 are automatically scheduled by SWI-Prolog.
  412trimcore :-
  413	trim_stacks.
  414
  415
  416		 /*******************************
  417		 *	       FLAGS		*
  418		 *******************************/
 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.
  425prolog_flag(Flag, Old, New) :-
  426	debug(prolog_flag, 'prolog_flag(~q, ~q, ~q)', [Flag, Old, New]),
  427	current_prolog_flag(Flag, Old),
  428	set_prolog_flag(Flag, New).
 prolog_flag(+Flag, -Value) is semidet
Query a Prolog flag, mapping SICSTus flags to SWI-Prolog flags
  434prolog_flag(Flag, Value) :-
  435	debug(prolog_flag, 'prolog_flag(~q, ~q)', [Flag, Value]),
  436	sicstus_flag(Flag, Value).
  437
  438sicstus_flag(system_type, Type) :- !,
  439	(   current_prolog_flag(saved_program, true)
  440	->  Type = runtime
  441	;   Type = development
  442	).
  443sicstus_flag(Name, Value) :-
  444	current_prolog_flag(Name, Value).
  445
  446
  447		 /*******************************
  448		 *	     ARITHMETIC		*
  449		 *******************************/
  450
  451% Provide (#)/2 as arithmetic function.  Ideally, we should be able to
  452% bind multiple names to built-in functions.  This is rather slow.  We
  453% could also consider adding # internally, but not turning it into an
  454% operator.
  455
  456:- op(500, yfx, #).  457
  458:- arithmetic_function(user:(#)/2).  459:- arithmetic_function(user:(\)/2).  460
  461user:(#(X,Y,R)) :-				% SICStus 3
  462	R is xor(X,Y).
  463user:(\(X,Y,R)) :-				% SICStus 4
  464	R is xor(X,Y).
  465
  466
  467		 /*******************************
  468		 *	       HACKS		*
  469		 *******************************/
 prolog:$breaklevel(-BreakLevel, Unknown)
Query the current break-level
  475prolog:'$breaklevel'(BreakLevel, _) :-
  476	current_prolog_flag(break_level, BreakLevel), !.
  477prolog:'$breaklevel'(0, _)