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-2007 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: dynamic.pl,v 1.10 2013/02/18 00:42:59 jschimpf Exp $
27% ----------------------------------------------------------------------
28
29/*
30 * SEPIA PROLOG SOURCE MODULE
31 */
32
33/*
34 * IDENTIFICATION:	dynamic.pl, part of module(sepia_kernel)
35 *
36 * DESCRIPTION: 	This file contains all the Prolog predicates
37 *			that handle dynamic predicates.
38 *
39 * CONTENTS:
40 *
41 * REVISION HISTORY:
42 *
43 * AUTHOR	VERSION	 DATE	REASON
44 * periklis		26.9.89	Major revision for the logical update semantics.
45 * micha		20.3.89	Moved all the dynamic-related predicates
46 *				from db.pl into this file.
47 * joachim		2007	Radically simplified record-based version
48 */
49
50:- system.		% compiler directive to add the SYSTEM flag
51
52:- export
53	(abolish)/1,
54	assert/1,
55	asserta/1,
56	assertz/1,
57	(dynamic)/1,
58	is_dynamic/1,
59	clause/1,clause/2,
60	(listing)/0,(listing)/1,
61	retract/1,
62	retract_all/1,
63	retractall/1,
64	writeclause/1,
65	writeclause/2.
66
67
68/*
69 * TOOL DIRECTIVES
70 * (body names are chosen for backward compatibility)
71 */
72
73:- tool((abolish)/1, abolish_body/2).
74:- tool(assert/1, assert_/2).
75:- tool(asserta/1, asserta_/2).
76:- tool(assertz/1, assert_/2).
77:- tool(clause/1, clause_body/2).
78:- tool(clause/2, clause_body/3).
79:- tool((dynamic)/1, dynamic_body/2).
80:- tool(is_dynamic/1, is_dynamic_body/2).
81:- tool(listing/1, listing_body/2).
82:- tool(listing/0, listing_body/1).
83:- tool(retract/1, retract_body/2).
84:- tool(retract_all/1, retract_all_body/2).
85:- tool(retractall/1, retract_all_body/2).
86:- tool(write_goal/3, write_goal/4).		% exported, for opium
87
88:- meta_predicate((
89	assert(:-),
90	asserta(:-),
91	assertz(:-),
92	clause(:-),
93	retract(:-)
94    )).
95
96
97%
98% Dynamic clauses are recorded in source form in the indexed database,
99% under an anonymous SrcHandle.
100%
101% Additionally every dynamic predicate has the following stub code,
102% which contains that SrcHandle.  E.g. for p/3:
103%
104%	p(A, B, C) :-
105%	    call_dynamic_(<SrcHandle for p/3>, p(A,B,C), <home module>).
106%
107% call_dynamic_/3 is common code, essentially an interpreter for the
108% clauses stored under SrcHandle.  Note that cuts in the clause body
109% must cut the recorded-choicepoint that backtracks over the clauses!
110
111call_dynamic_(SrcHandle, Goal, Module) :-
112	get_cut(Cut),
113	recorded(SrcHandle, (Goal:-Body)),
114	call_with_cut(Body, Module, Module, Cut).
115
116
117
118% Dynamic declaration - we allow several variants:
119%	dynamic n/a
120%	dynamic n/a, n/a, n/a		% Sepia
121%	dynamic [n/a, n/a, n/a]		% Quintus, ISO, ...
122
123dynamic_body((F1, F2), Module) ?-
124	dynamic_body_enum((F1,F2), Module),
125	!.
126dynamic_body([F|Fs], Module) ?-
127	dynamic_body_list([F|Fs], Module),
128	!.
129dynamic_body(F, Module) :-
130	dynamic_body_single(F, Module),
131	!.
132dynamic_body(Preds, Module) :-
133	get_bip_error(E),
134	error(E, dynamic(Preds), Module).
135
136    dynamic_body_enum((F1,F2), Module) ?- !,
137    	dynamic_body_enum(F1, Module),
138    	dynamic_body_enum(F2, Module).
139    dynamic_body_enum(F, Module) :-
140    	dynamic_body_single(F, Module).
141
142    dynamic_body_list(Fs, _Module) :- var(Fs), !,
143    	set_bip_error(4).
144    dynamic_body_list([], _Module) :- !.
145    dynamic_body_list([F|Fs], Module) :- !,
146    	dynamic_body_single(F, Module),
147	dynamic_body_list(Fs, Module).
148    dynamic_body_list(_, _) :-
149    	set_bip_error(5).
150
151    dynamic_body_single(Name/Arity, Module) ?-
152    	atom(Name), integer(Arity), Arity >= 0, !,
153	dynamic_create_(Name, Arity, Module).
154    dynamic_body_single(Pred, _) :-
155	nonground(Pred) -> set_bip_error(4) ; set_bip_error(5).
156
157
158is_dynamic_body(Functor, Module) :-
159	( check_predspec(Functor, Module) ->
160		Functor = Name/Arity,
161		is_dynamic_(Name, Arity, Module)
162	;
163		bip_error(is_dynamic(Functor), Module)
164	).
165
166
167% abolish/1 gets rid of the definition of the predicate specified
168% by the argument. Name must be fully instantiated.
169% Arity must be fully instantiated (we differ from BSI).
170
171abolish_body(Name/Arity, Module ) :- !,
172	( abolish_(Name,Arity,Module) ->
173	    true
174	;
175	    get_bip_error(Error),
176	    error(Error, abolish(Name/Arity), Module)
177	).
178abolish_body( (F1, F2), Module ) :- !,
179        abolish_body( F1, Module ),
180        abolish_body( F2, Module ).
181abolish_body(Functor, Module ) :-
182	error(5, abolish(Functor), Module).
183
184
185% Auxiliary to check and decompose clause arguments
186
187clause_info(Clause, _N, _A, _NormClause) :- var(Clause), !,
188    	set_bip_error(4).
189clause_info(Clause, N, A, NormClause) :- Clause = (Head:-_), !,
190	NormClause = Clause,
191	check_callable(Head),
192	functor(Head, N, A).
193clause_info(Head, N, A, NormClause) :-
194	NormClause = (Head:-true),
195	check_callable(Head),
196	functor(Head, N, A).
197
198
199% Handler for event 70
200
201undef_dynamic_handler(N, assert(Clause), Module) :- !,
202	undef_dynamic_handler(N, assertz(Clause), Module).
203undef_dynamic_handler(_N, asserta(Clause), Module) :-
204	clause_info(Clause, Name, Arity, _NormClause),
205	dynamic_create_(Name, Arity, Module),
206	!,
207	asserta(Clause)@Module.
208undef_dynamic_handler(_N, assertz(Clause), Module) :-
209	clause_info(Clause, Name, Arity, _NormClause),
210	dynamic_create_(Name, Arity, Module),
211	!,
212	assertz(Clause)@Module.
213undef_dynamic_handler(N, Goal, _) :-
214	( get_bip_error(E) ->
215	    error_handler(E, Goal)
216	;
217	    error_handler(N, Goal)
218	).
219
220
221asserta_(Clause, Module) :-
222	( clause_info(Clause, N, A, NormClause),
223	  dynamic_source_(N, A, SrcHandle, Module) ->
224	    recorda(SrcHandle, NormClause)
225	;
226	    bip_error(asserta(Clause), Module)
227	).
228
229
230assert_(Clause, Module) :-
231	( clause_info(Clause, N, A, NormClause),
232	  dynamic_source_(N, A, SrcHandle, Module) ->
233	    recordz(SrcHandle, NormClause)
234	;
235	    bip_error(assertz(Clause), Module)
236	).
237
238
239clause_body(Clause, Module) :-
240	( clause_info(Clause, N, A, NormClause),
241	  dynamic_source_(N, A, SrcHandle, Module) ->
242	    recorded(SrcHandle, NormClause)
243	;
244	    bip_error(clause(Clause), Module)
245	).
246
247
248clause_body(Head, Body, Module) :-
249	( check_callable(Head),
250	  functor(Head, N, A),
251	  dynamic_source_(N, A, SrcHandle, Module) ->
252	    recorded(SrcHandle, (Head:-Body))
253	;
254	    bip_error(clause(Head, Body), Module)
255	).
256
257
258retract_body(Clause, Module) :-
259	( clause_info(Clause, N, A, NormClause),
260	  dynamic_source_(N, A, SrcHandle, Module) ->
261	    recorded(SrcHandle, NormClause, DbRef),
262	    ( erase(DbRef) -> true ; true )
263	;
264	    bip_error(retract(Clause), Module)
265	).
266
267
268retract_all_body(Head, Module) :-
269	( check_callable(Head),
270	  functor(Head, N, A),
271	  dynamic_source_(N, A, SrcHandle, Module) ->
272	    erase_all(SrcHandle, Head :- _)@Module
273	;
274	    bip_error(retract_all(Head), Module)
275	).
276
277
278listing_body(Pred, Module) :-
279	( check_predspec(Pred),
280	  Pred = N/A,
281	  dynamic_source_(N, A, SrcHandle, Module) ->
282	    (
283		recorded(SrcHandle, Clause)@Module,
284		writeclause(Clause)@Module,
285		fail
286	    ;
287		true
288	    )
289	;
290	    bip_error(listing(Pred), Module)
291	).
292
293
294listing_body(Module) :-
295	(
296	    Pred = N/A,
297	    current_predicate_body(Pred, Module),
298	    is_dynamic_(N, A, Module),
299	    proc_flags(Pred, 0, Module, Module), % definition module = Module
300	    listing_body(Pred, Module),
301	    nl(output),
302	    fail
303	;
304	    true
305	).
306
307
308
309
310%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
311% some predicates to output a clause (used in listing)
312
313writeclause_body(C,M):-
314	writeclause_body(output, C, M).
315
316writeclause_body(Stream, Clause, Module) :-
317	write_clause(Stream, Clause, Module),
318	put_separated(Stream, 0'., Module),
319	nl(Stream).
320
321put_separated(Stream, Char, Module) :-
322	get_chtab(Char, Class),
323	(
324	    get_stream_info(Stream, last_written, LastChar),	% may fail
325	    get_chtab(LastChar, Class)@Module
326	->
327	    put(Stream, 0' )
328	;
329	    true
330	),
331	put(Stream, Char).
332
333write_clause(Str, (H?-B), M) ?- !,
334	write_bracketed_if_needed(Str, H, 1199, M),
335	write_(Str, ' ?-', M),
336	nl(Str),
337	write_goal(Str, B, 2, 1199, M).
338write_clause(Str, (H:-B), M) ?- !,
339	(B == true ->
340		writeq_(Str, H, M)
341	;
342		write_bracketed_if_needed(Str, H, 1199, M),
343		write_(Str, ' :-', M),
344		nl(Str),
345		write_goal(Str, B, 2, 1199, M)
346	).
347write_clause(Str, (H-->B), M) ?- !,
348	write_bracketed_if_needed(Str, H, 1199, M),
349	write_(Str, '-->', M),
350	nl(Str),
351	write_goal(Str, B, 2, 1199, M).
352write_clause(Str, H, M):-
353	writeq_(Str, H, M).
354
355
356write_goal(Str, Term, Indent, M) :-
357	write_goal(Str, Term, Indent, 1200, M).
358
359% be careful not to instantiate input arguments!
360write_goal(Str, B, Indent, _Prec, M):-
361	var(B), !,
362	indent(Str, Indent, M),
363	writeq_(Str, B, M).
364write_goal(Str, (B,C), Indent, _Prec, M):- !,
365	write_goal(Str, B, Indent, 999, M),
366	put(Str, 0',), nl(Str),
367	write_goal(Str, C, Indent, 1000, M).
368write_goal(Str, (IfThen;D), Indent, _Prec, M) :-
369	nonvar(IfThen),
370	IfThen = (B->C),
371	!,
372	Ind1 is Indent+1,
373	indent(Str, Indent, M),
374	put(Str, 0'(), nl(Str),
375	write_goal(Str, B, Ind1, 1049, M),
376	nl(Str),
377	indent(Str, Indent, M),
378	write_(Str, '->', M),
379	nl(Str),
380	write_goal(Str, C, Ind1, 1050, M),
381	nl(Str),
382	indent(Str, Indent, M),
383	put(Str, 0';), nl(Str),
384	write_goal(Str, D, Ind1, 1100, M),
385	nl(Str),
386	indent(Str, Indent, M),
387	put(Str, 0')).
388write_goal(Str, (B;C), Indent, _Prec, M):- !,
389	Ind1 is Indent+1,
390	indent(Str, Indent, M),
391	put(Str, 0'(), nl(Str),
392	write_goal(Str, B, Ind1, 1099, M),
393	nl(Str),
394	indent(Str, Indent, M),
395	put(Str, 0';), nl(Str),
396	write_goal(Str, C, Ind1, 1100, M),
397	nl(Str),
398	indent(Str, Indent, M),
399	put(Str, 0')).
400write_goal(Str, (B->C), Indent, _Prec, M):- !,
401	Ind1 is Indent+1,
402	indent(Str, Indent, M),
403	put(Str, 0'(), nl(Str),
404	write_goal(Str, B, Ind1, 1049, M),
405	nl(Str),
406	indent(Str, Indent, M),
407	write_(Str, '->', M),
408	nl(Str),
409	write_goal(Str, C, Ind1, 1050, M),
410	nl(Str),
411	indent(Str, Indent, M),
412	put(Str, 0')).
413write_goal(Str, (B do C), Indent, _Prec, M):- !,
414	Ind1 is Indent+1,
415	indent(Str, Indent, M),
416	put(Str, 0'(), nl(Str),
417	write_goal(Str, B, Ind1, 1099, M),
418	nl(Str),
419	indent(Str, Indent, M),
420	write_(Str, do, M),
421	nl(Str),
422	write_goal(Str, C, Ind1, 1100, M),
423	nl(Str),
424	indent(Str, Indent, M),
425	put(Str, 0')).
426write_goal(Str, (-?-> B), Indent, _Prec, M):- !,
427	indent(Str, Indent, M),
428	write_(Str, '-?->', M),
429	nl(Str),
430	write_goal(Str, B, Indent, 1179, M).
431write_goal(Str, '{}'(B), Indent, _Prec, M):- !,
432	Ind1 is Indent+1,
433	indent(Str, Indent, M),
434	put(Str, 0'{), nl(Str),
435	write_goal(Str, B, Ind1, 1200, M),
436	nl(Str),
437	indent(Str, Indent, M),
438	put(Str, 0'}).
439write_goal(Str, B, Indent, Prec, M):-
440	indent(Str, Indent, M),
441	write_bracketed_if_needed(Str, B, Prec, M).
442
443
444% this is just to fix the bugs, better code is in the public domain write.pl
445
446write_bracketed_if_needed(Str, Term, MaxPrec, M) :-
447	compound(Term),
448	functor(Term, F, A),
449	current_op_body(Prec, Assoc, F, M),
450	atom_length(Assoc) =:= A + 1,	% Functor is an operator
451	Prec > MaxPrec,
452	!,				% Term might needs brackets
453	put(Str, 0'(),
454	writeq_(Str, Term, M),
455	put(Str, 0')).
456write_bracketed_if_needed(Str, Term, _Prec, M) :-
457	writeq_(Str, Term, M).
458
459
460indent(_, 0, _) :- !.
461indent(Str, 1, M) :- !,
462	write_(Str, '    ', M).	%  write 4 spaces
463indent(Str, N, M) :-
464	N >= 2, N1 is N-2,
465	write_(Str, '\t', M),
466	indent(Str, N1, M).
467
468%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
469
470?- skipped
471	(abolish)/1,
472	abolish_body/2,
473	clause/1,
474	clause/2,
475	clause_body/2,
476	clause_body/3,
477	(dynamic)/1,
478	dynamic_body/2,
479	is_dynamic/1,
480	is_dynamic_body/2,
481	(listing)/0,
482	(listing)/1,
483	listing_body/1,
484	listing_body/2,
485	retract/1,
486	retract_all/1,
487	retract_all_body/2,
488	retract_body/2,
489	writeclause/1,
490	writeclause/2,
491	writeclause_body/2,
492	writeclause_body/3.
493