1% ----------------------------------------------------------------------
2% BEGIN LICENSE BLOCK
3% Version: CMPL 1.1
4%
5% The contents of this file are subject to the Cisco-style Mozilla Public
6% License Version 1.1 (the "License"); you may not use this file except
7% in compliance with the License.  You may obtain a copy of the License
8% at www.eclipse-clp.org/license.
9%
10% Software distributed under the License is distributed on an "AS IS"
11% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied.  See
12% the License for the specific language governing rights and limitations
13% under the License.
14%
15% The Original Code is  The ECLiPSe Constraint Logic Programming System.
16% The Initial Developer of the Original Code is  Cisco Systems, Inc.
17% Portions created by the Initial Developer are
18% Copyright (C) 1989-2006 Cisco Systems, Inc.  All Rights Reserved.
19%
20% Contributor(s): ECRC GmbH
21% Contributor(s): IC-Parc, Imperal College London
22%
23% END LICENSE BLOCK
24%
25% System:	ECLiPSe Constraint Logic Programming System
26% Version:	$Id: quintus.pl,v 1.16 2013/06/16 02:21:27 jschimpf Exp $
27% ----------------------------------------------------------------------
28
29/*
30 * SEPIA PROLOG SOURCE MODULE
31 */
32
33/*
34 * IDENTIFICATION:	quintus.pl
35 *
36 * DESCRIPTION: 	Quintus prolog compatibility package
37 *
38 *
39 * CONTENTS:
40 *
41 */
42
43:- module(quintus).
44
45:- comment(categories, ["Compatibility"]).
46:- comment(summary, 'Quintus prolog compatibility package').
47:- comment(author, 'Micha Meier, ECRC Munich').
48:- comment(copyright, 'Cisco Systems, Inc').
49:- comment(date, '$Date: 2013/06/16 02:21:27 $').
50:- comment(desc, html('
51    ECLiPSe includes a Quintus Prolog compatibility package to ease the
52    task of porting Quintus Prolog applications to ECLiPSe Prolog.  This
53    package does not provide the user with a system completely compatible
54    to Quintus Prolog, however it provides most of the Quintus built-in
55    predicates, moreover some of the Quintus library predicates are
56    available in the ECLiPSe library.  This package includes the C-Prolog
57    compatibility package (see Appendix A.6).
58    <P>
59    Please note that this appendix does not detail the functionality of
60    Quintus Prolog, refer to the Quintus Prolog documentation for this
61    information.
62    <P>
63    The effect of the compatibility library is local to the module where
64    it is loaded. For maximum compatibility, a Quintus program should
65    be wrapped in a separate module starting with a directive like
66    <PRE>
67    :- module(mymodule, [], quintus).
68    </PRE>
69    In this case, Eclipse-specific language constructs will not be available.
70    <P>
71    If the compatibility package is loaded into a standard module, e.g. like
72    <PRE>
73    :- module(mymixedmdule).
74    :- use_module(library(quintus)).
75    </PRE>
76    then Quintus and Eclipse language features can be used together.
77    However, ambiguities must be resolved explicitly and confusion may
78    arise from the different meaning of quotes in Eclipse vs Quintus-Prolog.
79    <P>
80    The following differences remain even with the compatibility package:
81    <DL>
82    <DT>expand_term/2
83	<DD>This predicate is dummy, since the ECLiPSe macro facility
84	works on every input term, provided that the flag
85	macro_expansion is set to on.
86    <DT>get0/2
87	<DD>This predicate is identical to get/2 in ECLiPSe.
88    <DT>help/1
89	<DD>This is the normal ECLiPSe help/1 predicate.
90    <DT>meta_predicate/1
91	<DD>This declaration does not cause passing of module information
92	in Quintus-style, as ECLiPSe\'s concept of meta predicates
93	differs substantially.  The meta-predicates very likely have
94	to be modified manually to use ECLiPSe tools (see User Manual).
95    <DT>multifile/1
96	<DD>This is implemented by declaring the predicates as dynamic, so
97	to obtain more efficient programs it is better to put all
98	clauses of the same procedure into one file (or to concatenate
99	all files where multifile predicates occur).
100    <DT>predicate_property/2
101	<DD>The property interpreted is not provided.  The property
102	exported is returned if the predicate is exported or global.
103	Use of get_flag/3 should be preferred.
104    <DT>prolog_flag/2, 3
105	<DD>There are some differences in the flags, as they are mostly
106	simulated with the ECLiPSe flags:
107	<UL>
108	    <LI>not all the character escapes used in the Quintus Prolog
109	    are available.
110	    <LI>gc_margin is taken as the ECLiPSe flag gc_interval
111	    (see Section 19.2)
112	    <LI>setting gc_trace to on sets also gc to on
113	</UL>
114    <DT>public/1
115	<DD>synonym for export/1
116    <DT>statistics/0, 2
117	<DD>these predicates are slightly different than in Quintus, in
118	particular the meaning of the memory statistics is approximate,
119	and the output format is different.
120    <DT>ttyflush/0, ttyget/1, ttyget0/1, ttynl/0, ttyput/1, ttyskip/1, ttytab/1
121	<DD>these predicates work with the stdout stream
122    <DT>line_position/2
123	<DD>Not implemented.  To perform sophisticated output formatting,
124	printf/2,3 or string streams can be used.
125    </DL>
126    The list below describes the syntax differences between
127    ECLiPSe and Quintus Prolog.  The following properties of Quintus
128    Prolog are simulated by the compatibility package:
129    <UL>
130	<LI>single (resp.  double) quote must be doubled between
131	    single (resp.  double) quote.
132	<LI>The symbol | (bar) is recognised as an alternative sign
133	    for a disjunction and it acts as an infix operator.
134	<LI>the symbol | is not an atom
135    </UL>
136    The following Quintus properties are not simulated:
137    <UL>
138	<LI>a clause can not be ended by end of file.
139	<LI>signed numbers: explicitly positive numbers are structures.
140	<LI>a real with an exponent must have a floating point.
141	<LI>a space is allowed before the decimal point and the exponent sign.
142	<LI>the definition of the escape sequence is more extended
143	    than in ECLiPSe.
144	<LI>spy/1 and nospy/1 accept as arguments lists, rather than
145	    comma-separated terms like in ECLiPSe.
146    </UL>
147    ')).
148:- comment(see_also, [library(cio),library(cprolog),library(sicstus),library(swi),
149	library(multifile)]).
150
151:- reexport cio.
152:- reexport foreign.
153:- reexport multifile.
154
155% suppress deprecation warnings for reexported builtins
156:- pragma(deprecated_warnings(not_reexports)).
157
158:- reexport eclipse_language except
159
160	(\=)/2,                         % hide (e.g. for Press)
161%	append/3, % in QP 3.6
162	delete/3,
163	gcd/3,
164%	ground/1, % in QP 3.6
165	select/3,
166        memberchk/2,
167	maplist/3,
168	member/2,
169	(not)/1,
170	union/3,
171	eval/2,
172	pathname/2,
173
174	get/1,				% redefined predicates
175	put/1,
176	put/2,
177	instance/2,
178	(abolish)/1,
179	arg/3,
180	(dynamic)/1,
181	display/1,
182	ensure_loaded/1,
183	erase/1,
184	name/2,
185	op/3,
186	recorda/3,
187	recordz/3,
188	recorded/3,
189	statistics/0,
190	statistics/2,
191	use_module/1,
192	use_module_body/2.
193
194	/*
195	op(_,   xfx, (of)),		% don't provide these
196	op(_,   xfx, (with)),
197	op(_,   xfy, (do)),
198	op(_,   xfx, (@)),
199	op(_,   fx, (-?->)),
200	op(_,	fy, (not)),
201	op(_,	fy, (spied)),
202	op(_,	fx, (delay)),
203	macro((with)/2, _, _),
204	macro((of)/2, _, _).
205	*/
206
207:- export			% temporary, while op/macros still global
208	op(0,   xfx, (of)),
209	op(0,   xfx, (with)),
210	op(0,   xfy, (do)),
211	op(0,   xfx, (@)),
212	op(0,   fx, (-?->)),
213	op(0,	fy, (not)),
214	op(0,	fy, (spied)),
215	op(0,	fx, (delay)),
216	macro((with)/2, (=)/2, []),
217	macro((of)/2, (=)/2, []).
218
219:- local
220	op(650, xfx, (@)).
221
222:- export
223	syntax_option(nl_in_quotes),
224        syntax_option(no_array_subscripts),
225	syntax_option(limit_arg_precedence),
226	syntax_option(doubled_quote_is_quote),
227	syntax_option(bar_is_no_atom),
228	syntax_option(bar_is_semicolon),
229	syntax_option(no_attributes),
230	syntax_option(no_curly_arguments),
231	syntax_option(blanks_after_sign),
232	syntax_option(float_needs_point),
233
234	chtab(0'\, symbol),		% disable escape sequences
235	chtab(128, string_quote),	% there must be some string_quote
236	chtab(0'", list_quote),
237
238	op(1150, fx, [(meta_predicate), (multifile), (discontiguous), (public),
239			(mode),
240			(dynamic), (initialization), (volatile)]).
241
242:- set_flag(macro_expansion, on).
243
244:- reexport
245	(.)/3,		% to evaluate lists in arithmetic expressions
246	consult/1,
247	current_functor/2,
248	current_predicate/2,
249	db_reference/1,
250	erased/1,
251	fileerrors/0,
252	get/1,
253	get0/1,
254	heapused/1,
255	leash/1,
256	log10/2,
257	log/2,
258	nofileerrors/0,
259	primitive/1,
260	prompt/2,
261	put/1,
262	reconsult/1,
263	sh/0
264    from cprolog.
265
266:- reexport
267    op(_,_,_)
268    from cprolog.
269
270:- reexport numbervars.
271:- reexport format.
272
273:- export
274	(abolish)/1,
275	(abolish)/2,
276	absolute_file_name/2,
277	arg/3,
278	atom_chars/2,
279        break/0,
280	character_count/2,
281	current_input/1,
282	current_output/1,
283	current_key/2,
284	current_module/2,
285	display/1,
286	(dynamic)/1,
287	ensure_loaded/1,
288	erase/1,
289	expand_term/2,
290	flush_output/1,
291	gc/0,
292	get0/2,
293	incore/1,
294	instance/2,
295	is_digit/1,
296	is_lower/1,
297	is_upper/1,
298	line_count/2,
299	manual/0,
300	name/2,
301	no_style_check/1,
302	nogc/0,
303	nospyall/0,
304	number_chars/2,
305	op/3,
306	open_null_stream/1,
307	otherwise/0,
308	portray_clause/1,
309	predicate_property/2,
310	prolog_flag/2,
311	prolog_flag/3,
312	(public)/1,
313	put/2,
314	put_line/1,
315	recorda/3,
316	recorded/3,
317	recordz/3,
318	save/1,
319	set_input/1,
320	set_output/1,
321	source_file/1,
322	source_file/2,
323	statistics/0,
324	statistics/2,
325	stream_code/2,
326	stream_position/2,
327	stream_position/3,
328	style_check/1,
329	term_expansion/2,
330        trace/0,
331	ttyflush/0,
332	ttyget/1,
333	ttyget0/1,
334	ttynl/0,
335	ttyput/1,
336	ttyskip/1,
337	ttytab/1,
338	unix/1,
339	unknown/2,
340	use_module/1,
341	use_module/2,
342	version/0,
343	version/1.
344
345
346:- export
347	tr_lib/2.
348
349:- export
350	macro(library_directory/1, tr_lib/2, [clause]).
351
352tr_lib(L, L) :-
353	L = no_macro_expansion(library_directory(Path)),
354	atom_string(Path, PathS),
355	get_flag(library_path, P),
356	(member(PathS, P) ->
357	    true
358	;
359	    append(P, [PathS], New),
360	    set_flag(library_path, New)
361	).
362
363%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
364
365:- system.		% compiler directive to add the SYSTEM flag
366
367:- import
368	abolish_body/2,
369	abolish_op_body/3,
370	current_built_in_body/2,
371	current_op_body/4,
372	current_predicate_body/2,
373	dynamic_body/2,
374	ensure_loaded/2,
375	export_body/2,
376	get_bip_error/1,
377	get_flag_body/4,
378	get_pager/1,
379	global_body/2,
380	global_op_body/4,
381	import_body/2,
382	nospy_body/2,
383	printf_/8,
384	retract_all_body/2,
385	set_flag_body/4,
386	tool_/2,
387	untraced_call/2
388   from sepia_kernel.
389
390:-
391	tool((abolish)/1, q_abolish_body/2),
392	tool(incore/1, untraced_call/2),
393	tool(nospyall/0, nospyall_body/1),
394	tool(predicate_property/2, predicate_property_body/3),
395	tool(prolog_flag/2, prolog_flag_body/3),
396	tool(prolog_flag/3, prolog_flag_body/4),
397	tool((public)/1, public_body/2),
398	tool(op/3, op_body/4).
399
400
401%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
402% *** Loading Programs ***
403
404no_style_check(X) :- var(X), !, fail.
405no_style_check(single_var) :-
406	get_flag(variable_names, check_singletons) ->
407	    set_flag(variable_names, on)
408	;
409	    true.
410no_style_check(discontiguous).
411no_style_check(multiple).
412no_style_check(all) :-
413	no_style_check(single_var).
414
415style_check(X) :- var(X), !, fail.
416style_check(single_var) :- set_flag(variable_names, check_singletons).
417style_check(discontiguous).
418style_check(multiple).
419style_check(all) :-
420	style_check(single_var).
421
422save(File) :-
423	printf(error, 'Saved states not supported: %w%n', [save(File)]).
424
425trace :-
426	printf(error, 'trace/0 only allowed as a toplevel command%n', []).
427
428break :-
429        toplevel:break.
430
431%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
432% *** Online help ***
433
434manual :-
435	get_flag(installation_directory, Sepiadir),
436	printf('To read the documentation, please open%n%s/doc/index.html%n',
437		[Sepiadir]).
438
439%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
440% *** Control ***
441
442otherwise.
443
444%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
445% *** I/O ***
446
447display(Term) :-
448	eclipse_language:display(stdout, Term).
449
450open_null_stream(null).
451flush_output(X) :- flush(X).
452set_input(Stream) :- set_stream(input, Stream).
453set_output(Stream) :- set_stream(output, Stream).
454current_input(Stream) :- get_stream(input, Stream).
455current_output(Stream) :- get_stream(output, Stream).
456
457source_file(File) :-
458	setof(X, P^(current_predicate(P), get_flag(P, source_file, X)), L),
459	member(File, L).
460
461source_file(Pred, File) :-
462	(var(Pred) ->
463	    current_predicate(F/A)
464	;
465	    true
466	),
467	functor(Pred, F, A),
468	get_flag(F/A, source_file, File).
469
470get0(S, T) :- get(S, T).
471
472put(S, T) :-
473	X is T,
474	eclipse_language:put(S, X).
475
476character_count(Stream, N) :-
477	at(Stream, N).
478
479stream_position(S, N) :-
480	at(S, N).
481
482stream_position(Stream, Old, New) :-
483	at(Stream, Old),
484	seek(Stream, New).
485
486ttyget0(X) :- get0(stdin, X).
487ttyget(X) :- get(stdin, X).
488ttyskip(X) :- skip(stdin, X).
489ttyput(X) :- put(stdout, X).
490ttynl :- nl(stdout).
491ttytab(N) :- tab(stdout, N).
492ttyflush :-
493	current_stream(S),
494	get_stream_info(S, device, tty),
495	get_stream_info(S, mode, write),
496	flush(S),
497	fail;true.
498
499portray_clause(Clause) :-
500	writeclause(Clause).
501
502line_count(Stream, Line1) :-
503	get_stream_info(Stream, line, Line),
504	Line1 is Line + 1.
505
506op_body(_, _, [], _) :- !.
507op_body(P, A, [O|L], M) :-
508	!,
509	op_body(P, A, O, M),
510	op_body(P, A, L, M).
511op_body(P, A, O, M) :-
512	global_op_body(P, A, O, M),
513	( current_op_body(P, A, O, M) ->
514	    true
515	;
516	    abolish_op_body(O, A, M)	% remove the hiding local definition
517	).
518
519%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
520% *** Arithmetic ***
521
522arith_exception_handler(_, integer(X,Y), _) :- !,
523	Y is integer(truncate(X)).
524arith_exception_handler(N, Culprit, Module) :-
525	error(default(N), Culprit, Module).
526
527:- set_event_handler(20, arith_exception_handler/3).
528
529
530%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
531% *** Term Conversion ***
532
533atom_chars(Atom, List) :-
534	var(Atom),
535	!,
536	string_list(String, List),
537	atom_string(Atom, String).
538atom_chars(Atom, List) :-
539	atom(Atom),
540	atom_string(Atom, String),
541	string_list(String, List).
542
543number_chars(Number, List) :-
544	var(Number),
545	!,
546	remove_leading_whtspaces(List, List0),
547	string_list(String, List0),
548	number_string(Number, String).
549number_chars(Number, List) :-
550	number_string(Number, String),
551	(var(List) ->
552	    List0 = List
553	;   remove_leading_whtspaces(List, List0)
554        ),
555	string_list(String, List0).
556
557remove_leading_whtspaces([C|Cs], List) ?-
558	((nonvar(C), is_white_space(C)) ->
559	    remove_leading_whtspaces(Cs, List)
560	;   List = [C|Cs]
561        ).
562
563is_white_space(C) :-
564	% concat_string(['\t','\n','\r',' '], SWhtSpaces),
565	% string_list(SWhtSpaces, WhtSpaces),
566	% this assumes ASCII as character escapes are off by default
567	WhtSpaces = [9,10,13,32],
568	memberchk(C, WhtSpaces).
569
570
571name(Name, Codes) :-
572	var(Codes),
573	( number(Name) ->
574	    number_string(Name, String),
575	    string_list(String, Codes)
576	; atom(Name) ->
577	    atom_string(Name, String),
578	    string_list(String, Codes)
579	; string(Name) ->       % convenience extension
580	    string_list(Name, Codes)
581	;
582	    error(5, name(Name, Codes))
583	).
584name(Name, Codes) :-
585	nonvar(Codes),
586	string_list(String, Codes),
587	( number_string(Number, String) ->
588	    Name = Number
589	;
590	    atom_string(Name, String)
591	).
592
593
594arg(N, S, X) :-
595	integer(N),
596	1 =< N, N =< arity(S),
597	eclipse_language:arg(N, S, X).
598
599
600%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
601% *** Term Comparison ***
602
603%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
604% *** Environment ***
605
606predicate_property_body(Pred, Property, M) :-
607	var(Pred),
608	!,
609	(current_predicate_body(F/A, M); current_built_in_body(F/A, M)),
610	functor(Pred, F, A),
611	sepia_property(F/A, M, Property).
612predicate_property_body(Pred, Property, M) :-
613	functor(Pred, F, A),
614	A < 256,
615	sepia_property(F/A, M, Property).
616
617sepia_property(P, M, compiled) :-
618	get_flag_body(P, stability, static, M).
619sepia_property(P, M, dynamic) :-
620	get_flag_body(P, stability, dynamic, M).
621sepia_property(P, M, built_in) :-
622	get_flag_body(P, type, built_in, M).
623sepia_property(P, M, exported) :-
624	get_flag_body(P, visibility, V, M),
625	(V == exported; V == reexported) -> true.
626sepia_property(P, M, foreign) :-
627	get_flag_body(P, call_type, external, M).
628sepia_property(P, M, imported_from(Mi)) :-
629	get_flag_body(P, visibility, imported, M),
630	get_flag_body(P, definition_module, Mi, M).
631
632%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
633% *** Debugging ***
634
635nospyall_body(M) :-
636	nospy_body(_, M),
637	writeln('All spypoints removed').
638
639unknown(Old, New) :-
640	(nonvar(Old) ->
641	    error(5, unknown(Old, New))
642	;
643	    (get_event_handler(68, fail/0, _) ->
644		Old = fail
645	    ;
646		Old = trace
647	    ),
648	    (New == trace ->
649		reset_event_handler(68)
650	    ;
651	    New == fail ->
652		set_event_handler(68, fail/0)
653	    ;
654		error(5, unknown(Old, New))
655	    )
656	).
657
658%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
659% *** Modules ***
660
661public_body([], _) :- !.
662public_body([Proc|Procs], M) :-
663	!,
664	globalize([Proc|Procs], M).
665public_body(Procs, M) :-
666	export_body(Procs, M).
667
668current_module(Module, File) :-
669	setof((M,F), P^(current_predicate(P),
670	    get_flag(P, source_file, F),
671	    get_flag(P, definition_module, M)), L),
672	member((Module,File), L).
673
674:- system_debug.
675%:- system.
676globalize([], _).
677globalize([Pred|Rest], M) :-
678	export_body(Pred, M),
679	globalize(Rest, M).
680
681:- tool(use_module/2, use_module_body/3).
682:- local use_module_body/2.
683:- tool(use_module/1, use_module_body/2).
684:- tool(ensure_loaded/1, use_module_body/2).
685
686use_module_body(F, L, M) :-
687	ensure_loaded(F, M),
688	(F = library(FM) ->
689		true
690	;
691		FM = F
692	),
693	import_list(L, FM, M).
694
695use_module_body(F, M) :-
696	ensure_loaded(F, M),
697	import_list(F, M).
698
699import_list([], _, _).
700import_list([Pred|L], F, M) :-
701	import_body((Pred from F), M),
702	import_list(L, F, M).
703
704import_list([], _).
705import_list([File|L], M) :-
706	!,
707	import1(File, M),
708	import_list(L, M).
709import_list(File, M) :-
710	import1(File, M).
711
712import1(library(File), M) :-
713	!,
714	import1(File, M).
715import1(File, M) :-
716	pathname(File, _, ModS),
717	atom_string(Module, ModS),
718	current_module(Module),
719	!,
720	import_body(Module, M).
721import1(_, _).
722
723
724%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
725% *** Dynamic Database ***
726
727q_abolish_body(Name/Arity, Module) :-
728	!,
729	abolish_body(Name/Arity, Module).
730q_abolish_body(:(Module, Spec), _) :-
731	!,
732	q_abolish_body(Spec, Module).
733q_abolish_body([], _) :- !.		% wrong, but compatible
734q_abolish_body([Spec|T], Module) :-
735	!,
736	q_abolish_body(Spec, Module),
737	q_abolish_body(T, Module).
738q_abolish_body(Atom, Module) :-
739	atom(Atom),			% this is wrong in Q2.0!
740	!,
741	(
742	    @(current_predicate(Atom/N),Module),
743	    @(get_flag(Atom/N, definition_module, Module), Module),
744	    abolish_body(Atom/N, Module),
745	    fail
746	;
747	    true
748	).
749q_abolish_body(Term, _) :-
750	error(5, abolish(Term)).
751
752:- tool((abolish)/2, abolish_body/3).
753abolish_body(Name, Arity, Module):-
754	q_abolish_body(Name/Arity, Module).
755
756:- tool((dynamic)/1, qdynamic_body/2).
757
758qdynamic_body(M:P, _) :-
759    dynamic_body(P, M).
760qdynamic_body(F/A, M) :-
761    dynamic_body(F/A, M).
762qdynamic_body((P1, P2), M) :-
763    qdynamic_body(P1, M),
764    qdynamic_body(P2, M).
765
766
767%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
768% *** Internal Database ***
769
770:- tool(current_key/2, current_key_body/3).
771current_key_body(KeyName, KeyTerm, Module) :-
772	@(current_record(IKey), Module),
773	external_key(IKey, KeyTerm),
774	functor(KeyTerm, KeyName, _).
775
776external_key(Key, KeyN) :-
777	atom(Key),
778	atom_string(Key, KeyS),
779	string_length(KeyS, N),
780	string_code(KeyS, N, 0),		% last key char is \000
781	!,
782	term_string(KeyN, KeyS).
783external_key(Key, Key).
784
785
786internal_key(Key, IKey) :-
787	var(Key), !,
788	current_record(IKey),
789	external_key(IKey, Key).
790internal_key(Key, IKey) :-
791	number(Key), !,
792	concat_atom([Key, '\000'], IKey).	% append \000 char
793internal_key(Key, Key).
794
795
796
797% Possible modes: recorded(+,-,-) recorded(-,-,+) recorded(-,-,-)
798:- tool(recorded/3, recorded_body/4).
799recorded_body(Key, Term, QRef, Module) :-
800	var(QRef), !,
801	internal_key(Key, IKey),
802	@(sepia_kernel:recorded(IKey, Term, DbRef), Module),
803	QRef = '$ref'(DbRef, 0).
804recorded_body(Key, Term, '$ref'(DbRef, 0), Module) :-
805	internal_key(Key, IKey),
806	@(sepia_kernel:recorded(IKey, Term, DbRef), Module),
807	!.
808
809:- tool(recorda/3, recorda_body/4).
810recorda_body(Key, Term, '$ref'(DbRef, 0), Module) :-
811	nonvar(Key),
812	internal_key(Key, NewKey),
813	@(sepia_kernel:recorda(NewKey, Term, DbRef), Module).
814
815:- tool(recordz/3, recordz_body/4).
816recordz_body(Key, Term, '$ref'(DbRef, 0), Module) :-
817	nonvar(Key),
818	internal_key(Key, NewKey),
819	@(sepia_kernel:recordz(NewKey, Term, DbRef), Module).
820
821:- tool(erase/1, erase_body/2).
822erase_body('$ref'(DbRef, 0), Module) :-
823	@(sepia_kernel:erase(DbRef), Module).
824
825instance('$ref'(DbRef, 0), Term) :-
826	referenced_record(DbRef, Term).
827
828%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
829% *** Grammar Rules ***
830
831% only temporary
832expand_term(A, B) :-
833	term_expansion(A, B),
834	!.
835expand_term(A, A).
836
837% To avoid calling an undefined procedure.
838term_expansion(_, _) :- fail.
839
840%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
841% *** Miscellaneous ***
842
843prolog_flag_body(Flag, Old, New, _Module) :-
844	var(Flag),
845	!,
846	error(4, prolog_flag(Flag, Old, New)).
847prolog_flag_body(Flag, Old, New, _Module) :-
848	var(New),
849	Old \== New,
850	!,
851	error(4, prolog_flag(Flag, Old, New)).
852prolog_flag_body(Flag, Old, New, Module) :-
853	prolog_flag_body(Flag, Old, Module),
854	set_quintus_flag(Flag, New, Module).
855
856set_quintus_flag(character_escapes, New, Module) :-
857% effect localised to Module!
858	(New == on ->
859	    @(set_chtab(0'\, escape), Module)
860	;
861	New == off ->
862	    @(set_chtab(0'\, symbol), Module)
863	).
864set_quintus_flag(debugging, New, _) :-
865	(New == off ->
866		set_flag(debugging, nodebug)
867	;
868		set_flag(debugging, New)
869	).
870set_quintus_flag(fileerrors, New, _) :-
871	(New == on ->
872		fileerrors
873	;
874	New == off ->
875		nofileerrors
876	).
877set_quintus_flag(single_var_warnings, New, _) :-
878	(New == on ->
879	    set_flag(variable_names, check_singletons)
880	;
881	get_flag(variable_names, off) ->
882	    true
883	;
884	    set_flag(variable_names, on)
885	).
886set_quintus_flag(unknown, New, _) :-
887	unknown(_, New).
888set_quintus_flag(gc, New, _) :-
889	set_flag(gc, New).
890set_quintus_flag(gc_margin, New, _) :-
891	set_flag(gc_interval, New).
892set_quintus_flag(gc_trace, New, _) :-
893	(New == on ->
894		set_flag(gc, verbose)
895	;
896	New == off ->
897		set_flag(gc, on)
898	).
899
900prolog_flag_body(character_escapes, Old, Module) :-
901	(
902		@(get_chtab(0'\, escape), Module) -> Old = on ; Old = off
903	).
904prolog_flag_body(debugging, Old, _) :-
905	get_flag(debugging, Mode),
906	(Mode == nodebug ->
907		Old = off
908	;
909	Mode == leap ->
910		Old = debug
911	;
912		Old = trace
913	).
914prolog_flag_body(fileerrors, Old, _) :-
915	(get_event_handler(170, nofileerrors_handler/2, _) ->
916		Old = off
917	;
918		Old = on
919	).
920prolog_flag_body(single_var_warnings, Old, _) :-
921	(get_flag(variable_names, check_singletons) ->
922	    Old = on
923	;
924	    Old = off
925	).
926prolog_flag_body(unknown, Old, _) :-
927	unknown(Old, Old).
928prolog_flag_body(gc, Old, _) :-
929	get_flag(gc, OldF),
930	(OldF == off -> Old = off; Old = on).
931prolog_flag_body(gc_margin, Old, _) :-
932	get_flag(gc_interval, Old).
933prolog_flag_body(gc_trace, Old, _) :-
934	(get_flag(gc, verbose) ->
935		Old = on
936	;
937		Old = off
938
939	).
940prolog_flag_body(typein_module, M, _) :-
941% not in quintus, but in SICStus
942	get_flag(toplevel_module, M).
943
944
945version.
946
947version(Message) :-
948	write(Message), nl.
949
950%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
951% *** System Dependent ***
952
953is_lower(X):- X < 128, X > 96.
954is_upper(X):- X > 64, X < 91.
955is_digit(X):- X > 47, X < 58.
956
957unix(cd(Path)) :-
958	cd(Path).
959unix(cd) :-
960	getenv('HOME', Home),
961	cd(Home).
962unix(shell(X)) :-
963	getenv('SHELL', Shell),
964	concat_string([Shell, ' -c "', X, '"'], Command),
965	sh(Command).
966unix(system(X)) :-
967	sh(X).
968unix(system(X, Status)) :-
969	getenv('SHELL', Shell),
970	concat_string([Shell, ' -c "', X, '"'], Command),
971	exec(sh, [S], Pid),
972	printf(S, '%w\nexit\n%b', Command),
973	close(S),
974	wait(Pid, Status).
975unix(shell) :-
976	getenv('SHELL', Shell),
977	sh(Shell).
978unix(argv(L)) :-
979	argc(N),
980	args_list(N, [], L).
981unix(exit(N)) :-
982	exit(N).
983
984:- mode args_list(++, +, -).
985args_list(1, L, L) :- !.
986args_list(N, L, M) :-
987	N1 is N - 1,
988	argv(N1, S),
989	(number_string(A, S) -> true ; atom_string(A, S)),
990	args_list(N1, [A|L], M).
991
992% put_line(list of charcters)
993% writes the list of characters and a newline to the current output
994
995put_line([]) :-
996	!,
997	nl.
998put_line([H|T]) :-
999	put(H),
1000	put_line(T).
1001
1002gc :-	set_flag(gc, on).
1003nogc :-	set_flag(gc, off).
1004
1005stream_code(S, C) :-
1006	get_stream(S, C).
1007
1008absolute_file_name(Rel, Abs) :-
1009	(Rel == user ->
1010	    Abs == user
1011	; get_flag(prolog_suffix, Sufs),
1012	  (existing_file(Rel, Sufs, [], ExtRel) -> true ; ExtRel = Rel),
1013	  canonical_path_name(ExtRel, Abs)
1014        ).
1015
1016%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1017% *** Statistics ***
1018
1019/*
1020memory (total)          377000 bytes:     350636 in use,       26364 free
1021   program space        219572 bytes
1022      atom space         (2804 atoms)      61024 in use,  43104 free
1023   global space          65532 bytes:       9088 in use,      56444 free
1024      global stack                          6984 bytes
1025      trail                                   16 bytes
1026      system                                2088 bytes
1027   local stack           65532 bytes:        356 in use,      65176 free
1028      local stack                            332 bytes
1029      system                                  24 bytes
1030 0.000 sec.  for 0 global and 0 local space shifts
1031 0.000 sec.  for 0 garbage collections which collected 0 bytes
1032 0.000 sec.  for 0 atom garbage collections which collected 0 bytes
1033 0.233 sec.  runtime
1034*/
1035
1036:- local variable(systime, 0),
1037	variable(realtime, 0),
1038	variable(walltime, 0).
1039
1040statistics(runtime, TotalLast) :-
1041	eclipse_language:statistics(runtime, TotalLast).
1042statistics(system_time, [Total,Last]) :-
1043	eclipse_language:statistics(times, [_User,System,_Real]),
1044	Total is fix(System*1000),
1045	getval(systime, Prev),
1046	Last is Total - Prev,
1047	setval(systime, Total).
1048statistics(real_time, [Total,Last]) :-
1049	eclipse_language:statistics(times, [_User,_System,Real]),
1050	Total is fix(Real*1000),
1051	getval(realtime, Prev),
1052	Last is Total - Prev,
1053	setval(realtime, Total).
1054statistics(walltime, [Total,Last]) :-		% Sicstus
1055	eclipse_language:statistics(times, [_User,_System,Real]),
1056	Total is fix(Real*1000),
1057	getval(walltime, Prev),
1058	Last is Total - Prev,
1059	setval(walltime, Total).
1060statistics(memory, [Total, 0]) :-
1061	Total is  (eclipse_language:statistics(shared_heap_allocated))
1062		+ (eclipse_language:statistics(private_heap_allocated))
1063		+ (eclipse_language:statistics(global_stack_allocated))
1064		+ (eclipse_language:statistics(control_stack_allocated))
1065		+ (eclipse_language:statistics(trail_stack_allocated))
1066		+ (eclipse_language:statistics(local_stack_allocated)).
1067statistics(program, [Used, Free]) :-
1068	eclipse_language:statistics(shared_heap_used, Used),
1069	Free is (eclipse_language:statistics(shared_heap_allocated)) - Used.
1070statistics(global_stack, [Used, Free]) :-
1071	eclipse_language:statistics(global_stack_used, Used),
1072	Free is (eclipse_language:statistics(global_stack_allocated)) - Used.
1073statistics(local_stack, [Used, Free]) :-
1074	Used is (eclipse_language:statistics(local_stack_used))
1075		+ (eclipse_language:statistics(control_stack_used)),
1076	Free is (eclipse_language:statistics(local_stack_allocated))
1077		+ (eclipse_language:statistics(control_stack_allocated)) - Used.
1078statistics(trail, [Used, Free]) :-
1079	eclipse_language:statistics(trail_stack_used, Used),
1080	Free is (eclipse_language:statistics(trail_stack_allocated)) - Used.
1081statistics(choice, [Used, Free]) :-		% Sicstus
1082	eclipse_language:statistics(control_stack_used, Used),
1083	Free is (eclipse_language:statistics(control_stack_allocated)) - Used.
1084statistics(stacks, [Global, Local]) :-		% Sicstus
1085	eclipse_language:statistics(global_stack_used, Global),
1086	Local is (eclipse_language:statistics(local_stack_used))
1087		+ (eclipse_language:statistics(control_stack_used)).
1088statistics(garbage_collection, [Number, Freed, Time]) :-
1089	eclipse_language:statistics(gc_number, Number),
1090	eclipse_language:statistics(gc_collected, Freed),
1091	eclipse_language:statistics(gc_time, Time).
1092statistics(stack_shifts, [0, 0, 0.0]).
1093statistics(atoms, [Number,Used,Free]) :-
1094	eclipse_language:statistics(dictionary_entries, Number),
1095	eclipse_language:statistics(dict_hash_usage, Used/Total),
1096	Free is Total-Used.
1097statistics(atom_garbage_collection, [Number,-1,Time]) :-
1098	eclipse_language:statistics(dict_gc_number, Number),
1099	eclipse_language:statistics(dict_gc_time, Time).
1100statistics(core, List) :-			% DEC-10
1101	statistics(memory, List).
1102statistics(heap, List) :-			% DEC-10
1103	statistics(program, List).
1104
1105statistics :-
1106	nl(log_output),
1107	(
1108	    statistics(What, Value),
1109	    Fill is 24 - atom_length(What),
1110	    printf(log_output, '%w:%*c%w%n', [What, Fill, 0' , Value]),
1111	    fail
1112	;
1113	    true
1114	).
1115
1116
1117%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1118
1119:- (current_module(user) ->
1120	true
1121    ;
1122	create_module(user),
1123	@(call(import(quintus)), user)
1124    ).
1125
1126%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1127%
1128%	MODULE INITIALIZATION
1129%
1130%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1131