kibi-swipl-linux-x64-gnu 1.0.0

package/lib/swipl/library/dialect/ifprolog.pl

@@ -0,0 +1,1317 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker, Johan Romme
+    E-mail:        J.Wielemaker@cs.vu.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (c)  2012-2016, VU University Amsterdam
+    All rights reserved.
+
+    Redistribution and use in source and binary forms, with or without
+    modification, are permitted provided that the following conditions
+    are met:
+
+    1. Redistributions of source code must retain the above copyright
+       notice, this list of conditions and the following disclaimer.
+
+    2. Redistributions in binary form must reproduce the above copyright
+       notice, this list of conditions and the following disclaimer in
+       the documentation and/or other materials provided with the
+       distribution.
+
+    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+    POSSIBILITY OF SUCH DAMAGE.
+*/
+
+:- module(ifprolog,
+	  [ calling_context/1,			% -Module
+	    context/2,				% :Goal, +Mapping
+	    block/3,				% :Goal, +Tag, :Recovery
+	    exit_block/1,			% +Tag
+	    cut_block/1,			% +Tag
+
+	    modify_mode/3,			% +PI, -Old, +New
+	    debug_mode/3,			% +PI, -Old, +New
+	    ifprolog_debug/1,			% :Goal,
+	    debug_config/3,			% +Key, +Current, +Value
+	    float_format/2,			% -Old, +New
+	    program_parameters/1,		% -Argv
+	    user_parameters/1,			% -Argv
+	    match/2,				% +Mask, +Atom
+	    match/3,				% +Mask, +Atom, ?Replacements
+	    lower_upper/2,			% ?Lower, ?Upper
+	    current_error/1,			% -Stream
+	    writeq_atom/2,			% +Term, -Atom
+	    write_atom/2,			% +Term, -Atom
+	    write_formatted_atom/3,		% -Atom, +Format, +ArgList
+	    write_formatted/2,			% +Format, +ArgList
+	    write_formatted/3,			% +Stream, +Format, +ArgList
+	    atom_part/4,			% +Atom, +Pos, +Len, -Sub
+	    atom_prefix/3,			% +Atom, +Len, -Sub
+	    atom_suffix/3,			% +Atom, +Len, -Sub
+	    atom_split/3,			% +Atom, +Delimiter, ?Subatoms
+	    if_concat_atom/2,			% +List, ?Atom
+	    if_concat_atom/3,			% +List, +Delimiter, ?Atom
+	    getchar/3,				% +Atom, +Pos, -Char
+	    parse_atom/6,			% +Atom, +StartPos, ?EndPos,
+						% ?Term, ?VarList, ?Error
+	    index/3,				% +Atom, +String, -Position
+	    list_length/2,			% +List, ?Length
+	    load/1,				% :FileName
+%	    unload/1,				% +Module
+	    file_test/2,			% +File, +Mode
+	    filepos/2,				% @Stream, -Line
+	    filepos/3,				% @Stream, -Line, -Column
+	    getcwd/1,				% -Dir
+	    assign_alias/2,			% +Alias, @Stream
+	    get_until/3,			% +SearchChar, ?Text, ?EndChar
+	    get_until/4,			% @In, +SearchChar, ?Text, ?EndChar
+	    for/3,				% +Start, ?Counter, +End
+	    prolog_version/1,                   % -Atom
+	    proroot/1,				% -Atom
+	    system_name/1,			% -Atom
+	    localtime/9,			% +Time, ?Year, ?Month,
+						% ?Day, ?DoW, ?DoY,
+						% ?Hour, ?Min, ?Sec
+
+	    asserta_with_names/2,		% @Term, +VarNames
+	    assertz_with_names/2,		% @Term, +VarNames
+	    clause_with_names/3,		% ?Head, ?Body, ?VarNames
+	    retract_with_names/2,		% ?Clause, ?VarNames
+	    predicate_type/2,			% @Predicate, ?Type
+	    current_visible/2,			% @Module, @Predicate
+	    current_signal/2,			% ?Signal, ?Mode
+	    digit/1,				% +Character
+	    letter/1,				% +Character
+
+	    current_global/1,			% +Name
+	    get_global/2,			% +Name, ?Value
+	    set_global/2,			% +Name, ?Value
+	    unset_global/1,			% +Name
+
+	    current_default_module/1,		% -Module
+	    set_default_module/1,		% +Module
+
+	    op(1150, fx, (meta)),
+	    op(1150, fx, (export)),
+	    op(100, xfx, @),
+	    op(900, xfx, =>),
+	    op(900,  fy, not)
+	  ]).
+:- use_module(library(debug)).
+:- use_module(library(arithmetic)).
+:- use_module(library(memfile)).
+:- use_module(library(apply)).
+:- set_prolog_flag(double_quotes, codes).
+
+/** <module> IF/Prolog compatibility package
+
+This library realises emulation of IF/Prolog.  As with all the emulation
+layers in the dialect directory, the   emulation has been established on
+`as needed' basis from porting programs. This implies that the emulation
+is incomplete. Emumated directives, predicates   and libraries are often
+not 100% compatible with the IF/Prolog version.
+
+Note that this emulation layer targets primarily IF/Prolog version 5.
+
+Please   help   extending   this   library   and   submit   patches   to
+bugs@swi-prolog.org.
+*/
+
+:- module_transparent
+	calling_context/1.
+
+:- meta_predicate
+	context(0, +),
+	block(0, +, 0),
+	modify_mode(:, -, +),
+	debug_mode(:, -, +),
+	ifprolog_debug(0),
+	load(:),
+	asserta_with_names(:, +),
+	assertz_with_names(:, +),
+	clause_with_names(:, -, -),
+	retract_with_names(:, -),
+	predicate_type(:, -),
+	current_global(:),
+	get_global(:, -),
+	set_global(:, +),
+	unset_global(:).
+
+
+		 /*******************************
+		 *	     EXPANSION		*
+		 *******************************/
+
+:- multifile
+	user:goal_expansion/2,
+	user:term_expansion/2,
+	user:file_search_path/2,
+	user:prolog_file_type/2,
+	ifprolog_goal_expansion/2,
+	ifprolog_term_expansion/2.
+:- dynamic
+	user:goal_expansion/2,
+	user:term_expansion/2,
+	user:file_search_path/2,
+	user:prolog_file_type/2.
+
+:- dynamic
+	in_module_interface/1.
+
+user:goal_expansion(In, Out) :-
+	prolog_load_context(dialect, ifprolog),
+	ifprolog_goal_expansion(In, Out).
+
+user:term_expansion(In, Out) :-
+	prolog_load_context(dialect, ifprolog),
+	ifprolog_term_expansion(In, Out).
+
+%%	ifprolog_goal_expansion(+In, +Out)
+%
+%	goal_expansion  rules  to   emulate    IF/Prolog   behaviour  in
+%	SWI-Prolog. The expansions  below   maintain  optimization  from
+%	compilation.   Defining   them   as   predicates   would   loose
+%	compilation.
+
+%%	context(:Goal, Handler)
+%
+%	Is  mapped  to  catch(Goal,  Error,    Recover)  is  Handler  is
+%	=|error(_,_) => Recover|=. Other cases are   not  covered by the
+%	emulation.
+
+%%	asserta(Head,Body) is det.
+%%	assertz(Head,Body) is det.
+%%	retract(Head,Body) is det.
+%
+%	Mapped to asserta((Head:-Body)),  etc.  Note   that  this  masks
+%	SWI-Prolog's asserta/2, etc.
+
+ifprolog_goal_expansion(Module:Goal, Expanded) :-
+	Module == system, nonvar(Goal), !,
+	expand_goal(Goal, ExpandedGoal),
+	head_pi(ExpandedGoal, PI),
+	(   current_predicate(ifprolog:PI),
+	    \+ predicate_property(ExpandedGoal, imported_from(_))
+	->  Expanded = ifprolog:ExpandedGoal
+	;   Expanded = ExpandedGoal
+	).
+ifprolog_goal_expansion(Goal, Expanded) :-
+	if_goal_expansion(Goal, Expanded).
+
+if_goal_expansion(context(Goal, [Error => Recover]),
+		  catch(Goal, Error, Recover)) :-
+	assertion(Error = error(_,_)).
+if_goal_expansion(assertz(Head,Body),
+		  assertz((Head:-Body))).
+if_goal_expansion(asserta(Head,Body),
+		  asserta((Head:-Body))).
+if_goal_expansion(retract(Head,Body),
+		  retract((Head:-Body))).
+if_goal_expansion(Call@Module, call((Module:Goal)@Module)) :-
+	nonvar(Call),
+	Call = call(Goal).
+if_goal_expansion(concat_atom(L,A), if_concat_atom(L,A)).
+if_goal_expansion(concat_atom(L,D,A), if_concat_atom(L,D,A)).
+
+
+head_pi(M:Head, M:PI) :- !,
+	head_pi(Head, PI).
+head_pi(Head, Name/Arity) :-
+	functor(Head, Name, Arity).
+
+
+%%	ifprolog_term_expansion(+In, +Out)
+%
+%	term_expansion  rules  to   emulate    IF/Prolog   behaviour  in
+%	SWI-Prolog.
+
+%%	meta(+ListOfPI)
+%
+%	Mapped  to  module_transparent/1.  Not  sure   whether  this  is
+%	correct. It surely is not very elegant   to  map to a deprecated
+%	feature.  Luckily,  although  the  module_transparent/1  API  is
+%	deprecated, the underlying functionality is   still  core of the
+%	module system.
+%
+%	Note that if :- meta  appears   inside  a  module interface, the
+%	predicate is also exported.
+
+%%	export(+ListOfPI) is det.
+%%	discontiguous(+ListOfPI) is det.
+%
+%	Mapped to comma-lists
+
+%%	module(+Name).
+%%	begin_module(+Name).
+%%	end_module(+Name).
+%
+%	These are emulated correctly,  provided   module/1  is the first
+%	term of the file and the  implementation   is  part  of the same
+%	file. Begin/end are ignored.
+
+ifprolog_term_expansion((:- meta([])), []).
+ifprolog_term_expansion((:- meta(List)),
+			[ (:- module_transparent(Spec))
+			| Export
+			]) :-
+	pi_list_to_pi_term(List, Spec),
+	(   in_module_interface(_)
+	->  Export = [(:- export(Spec))]
+	;   Export = []
+	).
+
+ifprolog_term_expansion((:- export([])), []).
+ifprolog_term_expansion((:- export(List)),
+			(:- export(Spec))) :-
+	is_list(List),
+	pi_list_to_pi_term(List, Spec).
+
+ifprolog_term_expansion((:- private(_)), []).
+
+ifprolog_term_expansion((:- discontiguous([])), []).
+ifprolog_term_expansion((:- discontiguous(List)),
+			(:- discontiguous(Spec))) :-
+	is_list(List),
+	pi_list_to_pi_term(List, Spec).
+
+ifprolog_term_expansion((:- multifile([])), []).
+ifprolog_term_expansion((:- multifile(List)),
+			(:- multifile(Spec))) :-
+	is_list(List),
+	pi_list_to_pi_term(List, Spec).
+
+ifprolog_term_expansion((:- module(Name)),
+			(:- module(Name, []))) :-
+	asserta(in_module_interface(Name)).
+ifprolog_term_expansion((:- begin_module(Name)), []) :-
+	prolog_load_context(module, Loading),
+	assertion(Name == Loading),
+	retract(in_module_interface(Name)).
+ifprolog_term_expansion((:- end_module(_)), []).
+ifprolog_term_expansion((:- end_module), []).
+ifprolog_term_expansion((:- nonotify), []).	% TBD: set verbosity
+
+
+ifprolog_term_expansion((:- import(Module)),
+			(:- use_module(File))) :-
+	(   module_property(Module, file(File))
+	->  true
+	;   existence_error(module, Module)
+	).
+ifprolog_term_expansion((:- import(Module, ImportList)),
+			(:- use_module(File, ImportList))) :-
+	(   module_property(Module, file(File))
+	->  true
+	;   existence_error(module, Module)
+	).
+
+%%	pi_list_to_pi_term(+List, -CommaList) is det.
+
+pi_list_to_pi_term([PI], PI) :- !.
+pi_list_to_pi_term([H|T], (H,CommaList)) :-
+	pi_list_to_pi_term(T, CommaList).
+
+                 /*******************************
+                 *          LIBRARY SETUP       *
+                 *******************************/
+
+%%      push_ifprolog_library
+%
+%       Pushes searching for dialect/ifprolog in   front of every library
+%       directory that contains such as sub-directory.
+
+push_ifprolog_library :-
+        (   absolute_file_name(library(dialect/ifprolog), Dir,
+                               [ file_type(directory),
+                                 access(read),
+                                 solutions(all),
+                                 file_errors(fail)
+                               ]),
+            asserta((user:file_search_path(library, Dir) :-
+                    prolog_load_context(dialect, ifprolog))),
+            fail
+        ;   true
+        ).
+
+%%	push_ifprolog_file_extension
+%
+%	Looks for .pro files before looking for .pl files if the current
+%	dialect is =pro=. If the dialect is   not active, the .pro files
+%	are found as last resort.
+
+push_ifprolog_file_extension :-
+	asserta((user:prolog_file_type(pro, prolog) :-
+		prolog_load_context(dialect, ifprolog))).
+
+user:prolog_file_type(pro, prolog) :-
+	\+ prolog_load_context(dialect, ifprolog).
+
+:- push_ifprolog_library,
+   push_ifprolog_file_extension.
+
+
+		 /*******************************
+		 *	    PREDICATES		*
+		 *******************************/
+
+%%	calling_context(-Context)
+%
+%	Mapped to context_module/1.
+
+calling_context(Context) :-
+	context_module(Context).
+
+%%	context(:Goal, +Mapping)
+%
+%	IF/Prolog context/2 construct. This is  the true predicate. This
+%	is normally mapped by goal-expansion.
+%
+%	@bug	Does not deal with IF/Prolog signal mapping
+
+context(M:Goal, Mapping) :-
+	member(Error => Action, Mapping),
+	nonvar(Error),
+	Error = error(_,_), !,
+	catch(M:Goal, Error, Action).
+context(M:Goal, _Mapping) :-
+	M:Goal.
+
+%%	block(:Goal, +Tag, :Recovery).
+%%	exit_block(+Tag).
+%%	cut_block(+Tag) is semidet.
+%
+%	The control construct block/3 runs Goal in a block labelled Tag.
+%	If Goal calls exit_block/1 using a   matching Tag, the execution
+%	of Goal is abandoned  using   exception  handling  and execution
+%	continues by running Recovery.  Goal   can  call cut_block/1. If
+%	there is a block with matching   Tag,  all choice points created
+%	since the block was started are destroyed.
+%
+%	@bug	The block control structure is implemented on top of
+%		catch/3 and throw/1.  If catch/3 is used inside Goal,
+%		the user must ensure that either (1) the protected
+%		goal does not call exit_block/1 or cut_block/1 or (2)
+%		the _Catcher_ of the catch/3 call does *not* unify with
+%		a term block(_,_).
+
+block(Goal, Tag, Recovery) :-
+	prolog_current_choice(Choice),
+	catch(Goal, block(Tag, Choice), Recovery).
+
+exit_block(Tag) :-
+	throw(block(Tag, _)).
+
+cut_block(Tag) :-
+	prolog_current_frame(Frame),
+	findall(Choice,			% use findall/3 to avoid binding
+		prolog_frame_attribute(
+		    Frame, parent_goal,
+		    system:catch(_, block(Tag, Choice), _)),
+		[Choice]),
+	nonvar(Choice),
+	prolog_cut_to(Choice).
+
+%%	modify_mode(+PI, -OldMode, +NewMode) is det.
+%
+%	Switch between static and  dynamic   code.  Fully supported, but
+%	notably changing static to dynamic code   is  not allowed if the
+%	predicate has clauses.
+
+modify_mode(PI, OldMode, NewMode) :-
+	pi_head(PI, Head),
+	old_mode(Head, OldMode),
+	set_mode(PI, OldMode, NewMode).
+
+old_mode(Head, Mode) :-
+	(   predicate_property(Head, dynamic)
+	->  Mode = on
+	;   Mode = off
+	).
+
+set_mode(_, Old, Old) :- !.
+set_mode(PI, _, on) :- !,
+	dynamic(PI).
+set_mode(PI, _, off) :-
+	compile_predicates([PI]).
+
+pi_head(M:PI, M:Head) :- !,
+	pi_head(PI, Head).
+pi_head(Name/Arity, Term) :-
+	functor(Term, Name, Arity).
+
+%%	debug_mode(:PI, -Old, +New)
+%
+%	Old is not unified.  Only  New  ==   off  is  mapped  to disable
+%	debugging of a predicate.
+
+debug_mode(PI, _, off) :- !,
+	'$hide'(PI).
+debug_mode(_, _, on).
+
+%%	ifprolog_debug(:Goal)
+%
+%	Map IF/Prolog debug(Goal)@Module. This should  run Goal in debug
+%	mode. We rarely needs this type of measures in SWI-Prolog.
+
+ifprolog_debug(Goal) :-
+	Goal.
+
+%%	debug_config(+Key, -Current, +Value)
+%
+%	Ignored.  Prints a message.
+
+debug_config(Key,Current,Value) :-
+	print_message(informational, ignored(debug_config(Key,Current,Value))).
+
+%%	float_format(-Old, +New)
+%
+%	Ignored. Prints a message. Cannot   be emulated. Printing floats
+%	with a specified precision can only be done using format/2.
+
+float_format(Old, New) :-
+	print_message(informational, ignored(float_format(Old, New))).
+
+%%	program_parameters(-List:atom)
+%
+%	All command-line argument, including the executable,
+
+program_parameters(Argv) :-
+	current_prolog_flag(os_argv, Argv).
+
+%%	user_parameters(-List:atom)
+%
+%	Parameters after =|--|=.
+
+user_parameters(Argv) :-
+	current_prolog_flag(argv, Argv).
+
+%%	match(+Mask, +Atom) is semidet.
+%
+%	Same as once(match(Mask, Atom, _Replacements)).
+
+match(Mask, Atom) :-
+	match(Mask, Atom, _), !.
+
+%%	match(+Mask, +Atom, ?Replacements) is nondet.
+%
+%	Pattern matching. This emulation  should   be  complete.  Can be
+%	optimized using caching of  the   pattern-analysis  or doing the
+%	analysis at compile-time.
+
+match(Mask, Atom, Replacements) :-
+	atom_codes(Mask, MaskCodes),
+	atom_codes(Atom, Codes),
+	phrase(match_pattern(Pattern), MaskCodes), !,
+	pattern_goal(Pattern, Codes, Replacements, Goal),
+	Goal.
+
+pattern_goal([], [], [], true).
+pattern_goal([string(String)|T], Codes, Replacements, Goal) :- !,
+	append(String, Rest, Codes),
+	pattern_goal(T, Rest, Replacements, Goal).
+pattern_goal([star|T], Codes, [Atom|Replacements], Goal) :-
+	append(Replacement, Rest, Codes),
+	Goal = (atom_codes(Atom, Replacement),Goal2),
+	pattern_goal(T, Rest, Replacements, Goal2).
+pattern_goal([set(S)|T], [C|Rest], [Atom|Replacements], Goal) :-
+	memberchk(C, S), !,
+	Goal = (char_code(Atom, C),Goal2),
+	pattern_goal(T, Rest, Replacements, Goal2).
+pattern_goal([any|T], [C|Rest], [Atom|Replacements], Goal) :-
+	Goal = (char_code(Atom, C),Goal2),
+	pattern_goal(T, Rest, Replacements, Goal2).
+
+match_pattern([set(S)|T]) -->
+	"[",
+	match_set(S), !,
+	match_pattern(T).
+match_pattern([string(List)|T]) -->
+	non_special(List),
+	{ List \== [] }, !,
+	match_pattern(T).
+match_pattern([star|T]) -->
+	"*", !,
+	match_pattern(T).
+match_pattern([any|T]) -->
+	"?", !,
+	match_pattern(T).
+match_pattern([]) --> [].
+
+match_set([]) --> "]", !.
+match_set(L) -->
+	[C0], "-", [C1],
+	{ C1 \= 0'],
+	  C0 =< C1,
+	  numlist(C0, C1, Range),
+	  append(Range, T, L)
+	},
+	match_set(T).
+match_set([C|L]) -->
+	[C],
+	match_set(L).
+
+non_special([H|T]) -->
+	[H],
+	{ \+ special(H) }, !,
+	non_special(T).
+non_special([]) --> [].
+
+special(0'*).
+special(0'?).
+special(0'[).
+
+%%	lower_upper(+Lower, -Upper) is det.
+%%	lower_upper(-Lower, +Upper) is det.
+%
+%	Multi-moded combination of upcase_atom/2 and downcase_atom/2.
+
+
+lower_upper(Lower, Upper) :-
+	nonvar(Lower), !,
+	upcase_atom(Lower, Upper).
+lower_upper(Lower, Upper) :-
+	downcase_atom(Upper, Lower).
+
+%%	load(File)
+%
+%	Mapped to consult.  I think that the compatible version should
+%	only load .qlf (compiled) code.
+
+load(File) :-
+	consult(File).
+
+%%	unload(+Module) is det.
+%
+%	Unload the named module.
+%
+%	@bug: What to do with modules that are not associated to a
+%	file?
+
+unload(Module) :-
+	module_property(Module, file(File)), !,
+	unload_file(File).
+unload(_Module) :-
+	assertion(fail).
+
+%%	file_test(+File, +Mode)
+%
+%	Mapped to access_file/2 (which understand more modes). Note that
+%	this predicate is defined in the   module  =system= to allow for
+%	direct calling.
+
+file_test(File, Mode) :-
+	access_file(File, Mode).
+
+%%	filepos(@Stream, -Line)
+%
+%	from  the  IF/Prolog  documentation    The  predicate  filepos/2
+%	determines the current line  position   of  the  specified input
+%	stream and unifies the  result  with   Line.  The  current  line
+%	position is the number of line processed + 1
+
+filepos(Stream, Line) :-
+	line_count(Stream, L),
+	Line is L + 1.
+
+
+%%	getcwd(-Dir)
+%
+%	The predicate getcwd/1 unifies Dir with the full pathname of the
+%	current working directory.
+
+getcwd(Dir) :-
+	working_directory(Dir, Dir).
+
+%%	filepos(@Stream, -Line, -Column)
+%
+%	from  the  IF/Prolog  documentation    The  predicate  filepos/2
+%	determines the current line  position   of  the  specified input
+%	stream and unifies the  result  with   Line.  The  current  line
+%	position is the number of line processed + 1
+
+filepos(Stream, Line, Column) :-
+	line_count(Stream, L),
+	line_position(Stream, C),
+	Line is L + 1,
+	Column is C + 1.
+
+%%	assign_alias(+Alias, @Stream) is det.
+%
+
+assign_alias(Alias, Stream) :-
+	set_stream(Stream, alias(Alias)).
+
+%%	writeq_atom(+Term, -Atom)
+%
+%	Use writeq/1 to write Term to Atom.
+
+writeq_atom(Term, Atom) :-
+	with_output_to(atom(Atom), writeq(Term)).
+
+%%	write_atom(+Term, -Atom)
+%
+%	Use write/1 to write Term to Atom.
+
+write_atom(Term, Atom) :-
+	with_output_to(atom(Atom), write(Term)).
+
+%%	current_error(-Stream)
+%
+%	Doesn't exist in SWI-Prolog, but =user_error= is always an alias
+%	to the current error stream.
+
+current_error(user_error).
+
+
+		 /*******************************
+		 *	  FORMATTED WRITE	*
+		 *******************************/
+
+%%	write_formatted_atom(-Atom, +Format, +ArgList) is det.
+%%	write_formatted(+Format, +ArgList) is det.
+%%	write_formatted(@Stream, +Format, +ArgList) is det.
+%
+%	Emulation of IF/Prolog formatted write.   The  emulation is very
+%	incomplete. Notable asks for dealing with aligned fields, etc.
+%
+%	@bug	Not all format characters are processed
+%	@bug    Incomplete processing of modifiers, fieldwidth and precision
+%	@tbd	This should become goal-expansion based to process
+%		format specifiers at compile-time.
+
+write_formatted_atom(Atom, Format, ArgList) :-
+	with_output_to(atom(Atom), write_formatted(Format, ArgList)).
+
+write_formatted(Format, ArgList) :-
+	write_formatted(current_output, Format, ArgList).
+
+write_formatted(Out, Format, ArgList) :-
+	atom_codes(Format, Codes),
+	phrase(format_string(FormatCodes), Codes), !,
+	string_codes(FormatString, FormatCodes),
+	format(Out, FormatString, ArgList).
+
+format_string([]) --> [].
+format_string(Fmt) -->
+	"%", format_modifiers(Flags, FieldLen, Precision), [IFC], !,
+	{   map_format([IFC], Flags, FieldLen, Precision, Repl)
+	->  append(Repl, T, Fmt)
+	;   print_message(warning, ifprolog_format(IFC)),
+	    %backtrace(20),
+	    T = Fmt
+	},
+	format_string(T).
+format_string([H|T]) -->
+	[H],
+	format_string(T).
+
+map_format(Format, [], default, default, Mapped) :- !,
+	map_format(Format, Mapped).
+map_format(Format, Flags, Width, Precision, Mapped) :-
+	integer(Width), !,			% left/right aligned in Width
+	map_format(Format, Field),
+	format_precision(Precision, Field, PrecField),
+	fill_code(Flags, [Fill]),
+	(   memberchk(-, Flags)			% left aligned
+	->  format(codes(Mapped), '~~|~s~~`~ct~~~d+', [PrecField, Fill, Width])
+	;   format(codes(Mapped), '~~|~~`~ct~s~~~d+', [Fill, PrecField, Width])
+	).
+map_format(Format, Flags, _, _, Mapped) :-
+	memberchk(#, Flags),
+	can_format(Format, Mapped), !.
+map_format(Format, _, _, Precision, Mapped) :-
+	map_format(Format, Field),
+	format_precision(Precision, Field, Mapped).
+
+can_format("o", "0~8r").
+can_format("x", "0x~16r").
+can_format("X", "0x~16R").
+can_format("w", "~k").
+
+map_format("t", "~w").
+map_format("q", "~q").
+map_format("s", "~a").
+map_format("f", "~f").
+map_format("e", "~e").
+map_format("E", "~E").
+map_format("g", "~G").
+map_format("d", "~d").
+map_format("x", "~16r").
+map_format("o", "~8r").
+map_format("X", "~16R").
+map_format("O", "~8R").
+map_format("c", "~c").
+map_format("%", "%").
+
+have_precision("d").
+have_precision("D").
+have_precision("e").
+have_precision("E").
+have_precision("f").
+have_precision("g").
+have_precision("G").
+
+format_precision(N, [0'~|C], [0'~|Field]) :-
+    integer(N),
+    have_precision(C),
+    !,
+    format(codes(Field), '~d~s', [N, C]).
+format_precision(_, Field, Field).
+
+fill_code(Flags, "0") :- memberchk(0, Flags), !.
+fill_code(_,     " ").
+
+%%	format_modifiers(-Flags, -FieldLength, -Precision) is det.
+%
+%	Read the IF/Prolog format modifiers. We currently do not process
+%	any of the modifiers! Some code seems to be using e.g. %07lx. We
+%	assume this is the same as -07x (assuming l=left).
+
+format_modifiers(Flags, FieldLength, Precision) -->
+	format_flags(Flags0),
+	digits(FieldLengthDigits),
+	{   FieldLengthDigits == []
+	->  FieldLength = default
+	;   number_codes(FieldLength, FieldLengthDigits)
+	},
+	(   "."
+	->  digits(PrecisionDigits),
+	    { number_codes(Precision, PrecisionDigits) }
+	;   { Precision = default }
+	),
+	opt_alignment(Flags0, Flags).
+
+format_flags([H|T]) -->
+	format_flag(H), !,
+	format_flags(T).
+format_flags([]) --> [].
+
+format_flag(+) --> "+".		% Always prefix number with a sign
+format_flag(-) --> "-".		% Left-justify
+format_flag(space) --> " ".	% Space before positive numbers
+format_flag(#) --> "#".		% Canonical output
+format_flag(0) --> "0".		% Use leading 0 for integers
+
+digits([D0|T]) -->
+	digit(D0), !,
+	digits(T).
+digits([]) --> [].
+
+digit(D) --> [D], {between(0'0, 0'9, D)}.
+
+opt_alignment(L, [-|L]) --> "l", !.
+opt_alignment(L, L) --> [].
+
+
+%%	get_until(+SearchChar, -Text, -EndChar) is det.
+%%	get_until(@Stream, +SearchChar, -Text, -EndChar) is det.
+%
+%	Read input from Stream  until   SearchChar.  Unify  EndChar with
+%	either SearchChar or the atom =end_of_file=.
+
+get_until(SearchChar, Text, EndChar) :-
+	get_until(current_input, SearchChar, Text, EndChar).
+
+get_until(In, SearchChar, Text, EndChar) :-
+	get_char(In, C0),
+	get_until(C0, In, SearchChar, Codes, EndChar),
+	atom_chars(Text, Codes).
+
+get_until(C0, _, C0, [], C0) :- !.
+get_until(end_of_file, _, _,  [], end_of_file) :- !.
+get_until(C0, In, Search, [C0|T], End) :-
+	get_char(In, C1),
+	get_until(C1, In, Search, T, End).
+
+
+		 /*******************************
+		 *	      PARSE		*
+		 *******************************/
+
+%%	atom_part(+Atom, +Pos, +Len, -Sub) is det.
+%
+%	True when Sub is part  of   the  atom [Pos,Pos+Len). Unifies Sub
+%	with '' if Pos or Len is out of range!?
+
+atom_part(_, Pos, _, Sub) :-
+	Pos < 1, !,
+	Sub = ''.
+atom_part(_, _, Len, Sub) :-
+	Len < 1, !,
+	Sub = ''.
+atom_part(Atom, Pos, _, Sub) :-
+	atom_length(Atom, Len),
+	Pos > Len, !,
+	Sub = ''.
+atom_part(Atom, Pos, Len, Sub) :-
+	Pos >= 1,
+	Pos0 is Pos - 1,
+	atom_length(Atom, ALen),
+	Len0 is min(Len, ALen-Pos0),
+	sub_atom(Atom, Pos0, Len0, _, Sub).
+
+%%	atom_prefix(+Atom, +Len, -Sub) is det.
+%
+%	Unifies Sub with the atom formed by  the first Len characters in
+%	atom.
+%
+%	 - If Len < 1, Sub is unified with the null atom ''.
+%	 - If Len > length of Atom, Sub is unified with Atom.
+
+atom_prefix(_, Len, Sub) :-
+	Len < 1, !,
+	Sub = ''.
+atom_prefix(Atom, Len, Sub) :-
+	atom_length(Atom, AtomLen),
+	Len > AtomLen, !,
+	Sub = Atom.
+atom_prefix(Atom, Len, Sub) :-
+	sub_atom(Atom, 0, Len, _, Sub).
+
+%%	atom_suffix(+Atom, +Len, -Sub) is det.
+%
+%	Unifies Sub with the atom formed by   the last Len characters in
+%	atom.
+%
+%	  - If Len < 1, Sub is unified with the null atom ''.
+%	  - If Len > length of Atom, Sub is unified with Atom.
+
+atom_suffix(_, Len, Sub) :-
+	Len < 1, !,
+	Sub = ''.
+atom_suffix(Atom, Len, Sub) :-
+	atom_length(Atom, AtomLen),
+	Len > AtomLen, !,
+	Sub = Atom.
+atom_suffix(Atom, Len, Sub) :-
+	atom_length(Atom, AtomLen),
+	Pos is AtomLen - Len,
+	sub_atom(Atom, Pos, Len, _, Sub).
+
+%%	atom_split( +Atom, +Delimiter, ?Subatoms )
+%
+%	Split Atom over Delimiter and unify the parts with Subatoms.
+
+atom_split(Atom, Delimiter, Subatoms)  :-
+	atomic_list_concat(Subatoms, Delimiter, Atom).
+
+%%	if_concat_atom(+List, +Delimiter, -Atom) is det.
+%
+%	True when Atom is the concatenation of   the lexical form of all
+%	elements from List, using Delimiter to delimit the elements.
+%
+%	The behavior of this  ifprolog   predicate  is  different w.r.t.
+%	SWI-Prolog in two respect: it supports   arbitrary terms in List
+%	rather than only atomic and it does _not_ work in mode -,+,+.
+
+if_concat_atom(List, Delimiter, Atom) :-
+	maplist(write_term_to_atom, List, AtomList),
+	atomic_list_concat(AtomList, Delimiter, Atom).
+
+write_term_to_atom(Term, Atom) :-
+	(   atomic(Term)
+	->  Atom = Term
+	;   with_output_to(string(Atom), write(Term))
+	).
+
+%%	if_concat_atom(+List, -Atom) is det.
+%
+%	True when Atom is the concatenation of   the lexical form of all
+%	elements  from  List.  Same  as  if_concat_atom/3  using  ''  as
+%	delimiter.
+
+if_concat_atom(List, Atom) :-
+	maplist(write_term_to_atom, List, AtomList),
+	atomic_list_concat(AtomList, Atom).
+
+%%	getchar(+Atom, +Pos, -Char)
+%
+%	Unifies Char with the Position-th character in Atom
+%	If Pos < 1 or Pos > length of Atom, then fail.
+
+getchar(_, Pos, _) :-
+	Pos < 1, !,
+	fail.
+getchar(Atom, Pos, _) :-
+	atom_length(Atom, Len),
+	Pos > Len, !,
+	fail.
+getchar(Atom, Pos, Char) :-
+	P is Pos - 1,
+	sub_atom(Atom, P, 1, _, Char).
+
+
+%%	parse_atom(+Atom, +StartPos, ?EndPos, ?Term, ?VarList, ?Error)
+%
+%	Read from an atom.
+%
+%	@param StartPos is 1-based position to start reading
+%	@param Error is the 1-based position of a syntax error or 0 if
+%	       there is no error.
+
+parse_atom(Atom, StartPos, EndPos, Term, VarList, Error) :-
+	setup_call_cleanup(
+	    ( atom_to_memory_file(Atom, MemF),
+	      open_memory_file(MemF, read, In)
+	    ),
+	    ( StartPos0 is StartPos-1,
+	      seek(In, StartPos0, bof, _),
+	      catch(read_term(In, Term, [variable_names(VarList)]), E, true),
+	      parse_atom_error(E, Error),
+	      character_count(In, EndPos0),
+	      EndPos is EndPos0+1
+	    ),
+	    ( close(In),
+	      free_memory_file(MemF)
+	    )).
+
+parse_atom_error(Var, Pos) :-
+	var(Var), !, Pos = 0.
+parse_atom_error(error(_, stream(_Stream, _, _, Pos)), Pos1) :-
+	Pos1 is Pos+1.
+
+
+%%	index(+Atom, +String, -Position) is semidet.
+%
+%	True when Position is the first   occurrence  of String in Atom.
+%	Position is 1-based.
+
+index(Atom, String, Position) :-
+	sub_string(Atom, Pos0, _, _, String), !,
+        Position is Pos0 + 1.
+
+%%	list_length(+List, ?Length) is det.
+%
+%	Deterministic version of length/2. Current implementation simply
+%	calls length/2.
+
+list_length(List, Length) :-
+	length(List, Length).
+
+
+		 /*******************************
+		 *	      MISC		*
+		 *******************************/
+
+%%	for(+Start, ?Count, +End) is nondet.
+%
+%	Similar to between/3, but can count down if Start > End.
+
+for(Start, Count, End) :-
+	Start =< End, !,
+	between(Start, End, Count).
+for(Start, Count, End) :-
+	nonvar(Count), !,
+	between(End, Start, Count).
+for(Start, Count, End) :-
+	Range is Start-End,
+	between(0, Range, X),
+	Count is Start-X.
+
+%%	prolog_version(-Version)
+%
+%	Return IF/Prolog simulated version string
+
+prolog_version(Version) :-
+	current_prolog_flag(version_data, swi(Major, Minor, Patch, _)),
+	atomic_list_concat([Major, Minor, Patch], '.', Version).
+
+%%	proroot(-Path)
+%
+%	True when Path is  the  installation   location  of  the  Prolog
+%	system.
+
+proroot(Path) :-
+	current_prolog_flag(home, Path).
+
+%%	system_name(-SystemName)
+%
+%	True when SystemName identifies the  operating system. Note that
+%	this returns the SWI-Prolog =arch= flag,   and not the IF/Prolog
+%	identifiers.
+
+system_name(SystemName) :-
+	current_prolog_flag(arch, SystemName).
+
+%%	localtime(+Time, ?Year, ?Month, ?Day, ?DoW, ?DoY, ?Hour, ?Min, ?Sec)
+%
+%	Break system time into its components.  Deefines components:
+%
+%	  | Year    | Year number    | 4 digits        |
+%	  | Month   | Month number   | 1..12           |
+%	  | Day	    | Day of month   | 1..31           |
+%	  | DoW	    | Day of week    | 1..7 (Mon-Sun)  |
+%	  | DoY	    | Day in year    | 1..366          |
+%	  | Hour    | Hours	     | 0..23           |
+%	  | Min	    | Minutes	     | 0..59           |
+%	  | Sec	    | Seconds	     | 0..59           |
+%
+%	Note that in IF/Prolog  V4,  Year  is   0..99,  while  it  is  a
+%	four-digit number in IF/Prolog V5.  We emulate IF/Prolog V5.
+
+localtime(TimeExpr, Year, Month, Day, DoW, DoY, Hour, Min, Sec) :-
+	arithmetic_expression_value(TimeExpr, Time),
+        stamp_date_time(Time, date(Year, Month, Day,
+				   Hour, Min, SecFloat,
+				   _Off, _TZ, _DST), local),
+        Sec is floor(SecFloat),
+	Date = date(Year,Month,Day),
+	day_of_the_year(Date, DoY),
+        day_of_the_week(Date, DoW).
+
+
+%%	current_global(+Name) is semidet.
+%%	get_global(+Name, ?Value) is det.
+%%	set_global(+Name, ?Value) is det.
+%%	unset_global(+Name) is det.
+%
+%	IF/Prolog  global  variables,  mapped    to   SWI-Prolog's  nb_*
+%	predicates.
+
+current_global(Name) :-
+	gvar_name(Name, GName),
+	nb_current(GName, _).
+
+get_global(Name, Value) :-
+	gvar_name(Name, GName),
+	nb_getval(GName, Value).
+
+set_global(Name, Value) :-
+	gvar_name(Name, GName),
+	nb_setval(GName, Value).
+
+unset_global(Name) :-
+	gvar_name(Name, GName),
+	nb_delete(GName).
+
+gvar_name(Module:Name, GName) :-
+	atomic_list_concat([Module, :, Name], GName).
+
+
+%%	current_default_module(-Module) is det.
+%
+%	Name of the toplevel typein module.
+
+current_default_module(Module) :-
+	'$current_typein_module'(Module).
+
+%%	set_default_module(+Module) is det.
+%
+%	Set the default toplevel module.
+
+set_default_module(Module) :-
+	module(Module).
+
+
+		 /*******************************
+		 *	      DATABASE		*
+		 *******************************/
+
+:- dynamic
+	names/2.
+
+%%	asserta_with_names(@Clause, +VarNames) is det.
+%%	assertz_with_names(@Clause, +VarNames) is det.
+%%	clause_with_names(?Head, ?Body, -VarNames) is det.
+%%	retract_with_names(?Clause, -VarNames) is det.
+%
+%	Predicates that manage  the  database   while  keeping  track of
+%	variable names.
+
+asserta_with_names(M:Clause, VarNames) :-
+	term_varnames(Clause, VarNames, VarTerm),
+	system:asserta(M:Clause, Ref),
+	asserta(names(Ref, VarTerm)).
+assertz_with_names(M:Clause, VarNames) :-
+	term_varnames(Clause, VarNames, VarTerm),
+	system:assertz(M:Clause, Ref),
+	asserta(names(Ref, VarTerm)).
+
+term_varnames(Term, VarNames, VarTerm) :-
+	findall(Vars,
+		( term_variables(Term, Vars),
+		  bind_names(VarNames)
+		),
+		[ VarList ]),
+	VarTerm =.. [ v | VarList ].
+
+bind_names([]).
+bind_names([Name=Var|T]) :-
+	Name=Var,
+	bind_names(T).
+
+
+clause_with_names(M:Head, Body, VarNames) :-
+	clause(M:Head, Body, Ref),
+	(   names(Ref, VarTerm)
+	->  term_variables((Head:-Body), Vars),
+	    VarTerm =.. [v|NameList],
+	    make_bindings(NameList, Vars, VarNames)
+	;   VarNames = []
+	).
+
+retract_with_names(M:Term, VarNames) :-
+	clause(M:Term, Ref),
+	erase(Ref),
+	(   retract(names(Ref, VarTerm))
+	->  term_variables((Term), Vars),
+	    VarTerm =.. [v|NameList],
+	    make_bindings(NameList, Vars, VarNames)
+	;   VarNames = []
+	).
+
+make_bindings([], [], []).
+make_bindings([Name|NT], [Var|VT], [Name=Var|BT]) :-
+	make_bindings(NT, VT, BT).
+
+
+%%	predicate_type(:PI, -Type) is det.
+%
+%	True when Type describes the type  of   PI.  Note that the value
+%	=linear= seems to mean you can use clause/2 on it, which is true
+%	for any SWI-Prolog predicate that is  defined. Therefore, we use
+%	it for any predicate that is defined.
+
+predicate_type(M:Name/Arity, Type) :-
+	functor(Head, Name, Arity),
+	Pred = M:Head,
+	(   (   predicate_property(Pred, built_in)
+	    ;	predicate_property(Pred, foreign)
+	    )
+	->  Type = builtin
+	;   predicate_property(Pred, imported_from(_))
+	->  Type = imported
+	;   predicate_property(Pred, dynamic)
+	->  Type = linear
+	;   control(Head)
+	->  Type = control
+	;   Name == call
+	->  Type = control
+	;   current_predicate(M:Name/Arity)
+	->  Type = linear
+	;   Type = undefined
+	).
+
+control((_,_)).
+control((_;_)).
+control((_->_)).
+control((_*->_)).
+control((!)).
+
+%%	current_visible(@Module, @PredicateIndicator).
+%
+%	FIXME check with documentation
+
+current_visible(Module, Name/Arity) :-
+	atom(Name), integer(Arity), !,
+	functor(Head, Name, Arity),
+	predicate_property(Module:Head, visible).
+current_visible(Module, Name/Arity) :-
+	predicate_property(Module:Head, visible),
+	functor(Head, Name, Arity).
+
+%%	current_signal(?Signal, ?Mode) is nondet.
+%
+%	True when Mode is the current   mode  for handling Signal. Modes
+%	are =on=, =off=,  =default=,  =ignore=.   Signals  are  =abort=,
+%	=alarm=, =interrupt=, =pipe=, =quit=,   =termination=,  =user_1=
+%	and =user_2=.
+%
+%	@tbd	Implement
+
+current_signal(_,_) :- fail.
+
+
+%%	digit(+A).
+%
+%	Is the character A a digit [0-9]
+digit(A) :-
+	char_type(A, digit).
+
+%%	letter(+A).
+%
+%	Is the character A a letter [A-Za-z]
+letter(A) :-
+	char_type(A, alpha).
+
+		 /*******************************
+		 *	    ARITHMETIC		*
+		 *******************************/
+
+:- arithmetic_function(system:time/0).
+:- arithmetic_function(system:trunc/1).
+:- arithmetic_function(system:ln/1).
+:- arithmetic_function(system:minint/0).
+:- arithmetic_function(system:maxint/0).
+:- arithmetic_function(system:dbsize/0).
+:- arithmetic_function(system:dbused/0).
+:- arithmetic_function(system:ssize/0).
+:- arithmetic_function(system:gused/0).
+:- arithmetic_function(system:lused/0).
+:- arithmetic_function(system:tused/0).
+
+system:time(Time) :-
+	get_time(GetTime),
+	Time is round(GetTime).  % Time in seconds since 1970-01-01 00:00:00 UTC
+system:trunc(Val, Trunc) :-
+	Trunc is truncate(Val).
+system:ln(Val, Log) :-
+	Log is log(Val).
+system:minint(MinInt) :-
+	MinInt is -1<<31.
+system:maxint(MaxInt) :-
+	MaxInt is 1<<31 - 1.
+system:dbsize(0).
+system:dbused(0).
+system:ssize(Size) :-
+	statistics(globallimit, Size).
+system:gused(Size) :-
+	statistics(globalused, Size).
+system:lused(Size) :-
+	statistics(localused, Size).
+system:tused(Size) :-
+	statistics(trailused, Size).
+
+
+		 /*******************************
+		 *	       MESSAGES		*
+		 *******************************/
+
+prolog:message(ifprolog_format(IFC)) -->
+	[ 'Unknown specifier for write_formatted/3: ~c'-[IFC] ].
+
+
+		 /*******************************
+		 *	  COLOUR SUPPORT	*
+		 *******************************/
+
+:- multifile
+	prolog_colour:style/2,
+	prolog_colour:goal_colours/2.
+
+prolog_colour:goal_colours(meta(_),
+			   ifprolog-[predicates]).
+prolog_colour:goal_colours(private(_),
+			   ifprolog-[predicates]).
+prolog_colour:goal_colours(import(Module,_),
+			   ifprolog-[module(Module),predicates]).
+prolog_colour:goal_colours(begin_module(Module),
+			   ifprolog-[module(Module)]).
+prolog_colour:goal_colours(end_module(Module),
+			   ifprolog-[module(Module)]).
+prolog_colour:goal_colours(end_module,
+			   ifprolog-[]).
+prolog_colour:goal_colours(nonotify,
+			   ifprolog-[]).
+
+prolog_colour:style(goal(ifprolog,_), [ colour(blue), background(lightcyan) ]).