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: pdb.pl,v 1.4 2013/02/18 00:42:58 jschimpf Exp $
27% ----------------------------------------------------------------------
28
29/*
30 * SEPIA PROLOG SOURCE MODULE
31 */
32
33/*
34 * IDENTIFICATION:	pdb.pl, part of module(sepia_kernel)
35 *
36 * DESCRIPTION: 	(used to be db.pl)
37 *
38 * CONTENTS:
39 *
40 */
41
42
43%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
44
45:- system.		% compiler directive to add the SYSTEM flag
46
47:- export
48	current_atom/1,
49	current_functor/1,
50	current_module/1,
51	current_op/3,
52	current_predicate/1,
53	current_built_in/1,
54	is_built_in/1,
55	current_macro/4,
56	pred/1,
57	trimcore/0,
58	abolish_op/2,
59	(als)/1,
60	(als)/2.
61
62:- tool( current_predicate/1, current_predicate_body/2).
63:- tool( current_built_in/1, current_built_in_body/2).
64:- tool( is_built_in/1, is_built_in_body/2).
65:- tool( current_op/3, current_op_body/4).
66:- tool( current_macro/4, current_macro_body/5).
67:- tool( abolish_op/2, abolish_op_body/3).
68:- tool( pred/1, pred_body/2).
69:- tool((als)/1, (als)/2).
70
71%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
72
73
74current_atom(Atom) :- var(Atom), !, current_functor(Atom, 0, 0, 0).
75current_atom(Atom) :- atom(Atom), !.
76current_atom(Atom) :- error(5, current_atom(Atom)).
77
78current_functor(Name/Arity) :-
79	(   (var(Name) ; atom(Name)),
80	    (var(Arity) ; integer(Arity), Arity >= 0 )
81	->
82	    current_functor(Name, Arity, 0, 0)
83	;
84	    error(5, current_functor(Name/Arity))
85	).
86
87current_module(M) :-
88	var(M), !,
89	current_functor(M, 0, 1, 0),	% atoms with properties only
90	is_a_module(M).
91current_module(M) :-
92	atom(M), !,
93	is_a_module(M).
94current_module(M) :-
95	error(5, current_module(M)).
96
97current_op_body(Preced, Assoc, Name, Module):-
98	legal_current_op(Preced, Assoc, Name, Module)
99	->
100	    ( var(Name) ->
101		current_functor(Name, 0, 1, 0)	% atoms with properties only
102	    ;
103		true
104	    ),
105	    (
106		is_infix_op(Preced, Assoc, Name, _, Module)
107		;
108		is_prefix_op(Preced, Assoc, Name, _, Module)
109		;
110		is_postfix_op(Preced, Assoc, Name, _, Module)
111	    ),
112	    Preced \== 0
113	;
114	    get_bip_error(Err),
115	    error(Err, current_op(Preced, Assoc, Name), Module).
116
117
118current_macro_body(Functor, Pred, List, PredModule, Module) :-
119	check_var_or_partial_macro_spec(Functor),
120	check_var_or_partial_qual_predspec(Pred),
121	check_var_or_partial_list(List),
122	check_var_or_atom(PredModule),
123	!,
124	current_macro_body1(Functor, Pred, List, PredModule, Module).
125current_macro_body(Functor, Pred, List, PredModule, Module) :-
126	bip_error(current_macro(Functor, Pred, List, PredModule), Module).
127
128current_macro_body1(Functor, Pred, List, PredModule, Module) :-
129	var(Functor),
130	!,
131	(
132	    current_functor(Name, Arity, 1, 0),	% functors with properties only
133	    Functor = Name/Arity
134	;
135	    current_type(T),
136	    Functor = type(T)
137	),
138	is_macro(Functor, Pred, List, PredModule, Module).
139current_macro_body1(Functor, Pred, List, PredModule, Module) :-
140	Functor = Name/Arity,
141	atom(Name),
142	integer(Arity),
143	!,
144	is_macro(Functor, Pred, List, PredModule, Module).
145current_macro_body1(Functor, Pred, List, PredModule, Module) :-
146	Functor = Name/Arity,
147	!,
148	current_functor(Name, Arity, 1, 0),
149	is_macro(Functor, Pred, List, PredModule, Module).
150current_macro_body1(Type, Pred, List, PredModule, Module) :-
151	Type = type(T),
152	current_type(T),
153	is_macro(Type, Pred, List, PredModule, Module).
154
155
156abolish_op_body(Operator, Assoc, Module) :-
157	abolish_op_(Operator, Assoc, Module)
158	->
159	    true
160	;
161	    get_bip_error(Error),
162	    error(Error, abolish_op(Operator, Assoc), Module).
163
164
165matches_predspec(N/A) :-
166	( var(N) -> true ; atom(N) ),
167	( var(A) -> true ; integer(A), A >= 0, A =< 255 ).
168
169current_predicate_body(P, M):-
170	illegal_unlocked_module(M, Err),
171	!,
172	error(Err, current_predicate(P), M).
173current_predicate_body(P, M):-
174	P = N/A,
175	matches_predspec(P),
176	!,
177	( nonground(P) ->
178	    current_functor(N, A, 2, 0)		% functors with predicates only
179	;
180	    true
181	),
182	get_flag_body(P, defined, on, M),
183	get_flag_body(P, type, user, M).
184current_predicate_body(P, M):-
185	error(5, current_predicate(P), M).
186
187
188current_built_in_body(P, M):-
189	illegal_unlocked_module(M, Err),
190	!,
191	error(Err, current_built_in(P), M).
192current_built_in_body(P, M):-
193	P = N/A,
194	matches_predspec(P),
195	!,
196	( nonground(P) ->
197	    current_functor(N, A, 2, 0)		% functors with predicates only
198	;
199	    true
200	),
201	get_flag_body(P, defined, on, M),
202	get_flag_body(P, type, built_in, M).
203current_built_in_body(P, M):-
204	error(5, current_built_in(P), M).
205
206
207is_built_in_body(Functor, Module) :-
208	( check_predspec(Functor, Module) ->
209		is_built_in_(Functor, Module)
210	;
211		bip_error(is_built_in(Functor), Module)
212	).
213
214
215%----------------------------------------------------------------------
216% meta_predicate declaration
217%----------------------------------------------------------------------
218
219:- export meta_predicate/1.
220:- tool(meta_predicate/1, meta_predicate_/2).
221:- local store(meta_predicate).
222
223meta_predicate_((Decl,Decls), Module) ?- !,
224	meta_predicate_single(Decl, Module),
225	meta_predicate_(Decls, Module).
226meta_predicate_(Decl, Module) :-
227	meta_predicate_single(Decl, Module).
228
229meta_predicate_single(Decl, Module) :-
230	check_callable(Decl),
231	functor(Decl, F, N),
232	functor(Meta, F, N),
233	functor(NewMode, F, N),
234	( get_flag(F/N, mode, OldMode)@Module -> true ; functor(OldMode, F, N) ),
235	( for(I,1,arity(Decl)), param(Decl,Meta,OldMode,NewMode) do
236	    arg(I, Decl, Spec),
237	    arg(I, Meta, MetaArg),
238	    arg(I, OldMode, OldModeArg),
239	    arg(I, NewMode, NewModeArg),
240	    ( var(OldModeArg) -> OldModeArg = (?) ; true ),
241	    check_meta_arg(Spec, MetaArg, OldModeArg, NewModeArg)
242	),
243	!,
244	% mode/1 also takes care of creating the predicate if necessary
245	( NewMode = (_,_) ->
246	    mode((NewMode,NewMode))@Module	% comma ambiguity...
247	;
248	    mode(NewMode)@Module
249	),
250	store_set(meta_predicate, Module:F/N, Meta).
251meta_predicate_single(Decl, Module) :-
252	bip_error(meta_predicate(Decl))@Module.
253
254    :- mode check_meta_arg(?,-,+,-).
255    check_meta_arg(Arg, _, _, _) :- var(Arg), !, set_bip_error(4).
256    check_meta_arg(Arg, Arg, M, M) :- integer(Arg), check_integer_ge(Arg, 0).
257    check_meta_arg(:, :, M, M) :- !.
258    check_meta_arg(:-, :-, M, M) :- !.
259    check_meta_arg(/, /, M, M) :- !.
260    check_meta_arg(*, *, M, M) :- !.
261    check_meta_arg(+, *, _, +) :- !.
262    check_meta_arg(-, *, _, -) :- !.
263    check_meta_arg(?, *, _, ?) :- !.
264    check_meta_arg(++, *, _, ++) :- !.
265    check_meta_arg(Arg, _, _, _) :- atom(Arg), !, set_bip_error(6).
266    check_meta_arg(_, _, _, _) :- set_bip_error(5).
267
268
269erase_meta_predicates(Module) :-
270	store_erase_qualified(meta_predicate, Module).
271
272
273%----------------------------------------------------------------------
274% Print predicate information
275%----------------------------------------------------------------------
276
277als(Proc, Module) :-
278	(var(Proc) ->
279		error(4, als(Proc))
280	;
281	atom(Proc) ->
282		(current_predicate_body(Proc/Arity, Module)
283		;
284		current_built_in_body(Proc/Arity, Module)),
285		als_(Proc/Arity, Module)
286	;
287	Proc = _/A, var(A) ->
288		(current_predicate_body(Proc, Module)
289		;
290		current_built_in_body(Proc, Module)),
291		als_(Proc, Module)
292	;
293		als_(Proc, Module)
294	).
295
296
297pred_body(Proc, M) :-
298	var(Proc), !,
299	error(4, pred(Proc), M).
300pred_body(Proc, M) :-
301	atom(Proc), !,
302	(
303	    ( current_predicate_body(Proc/A, M)
304	    ; current_built_in_body(Proc/A, M) ),
305	    nl,
306	    pred_body(Proc/A, M),
307	    fail
308	;
309	    true
310	).
311pred_body(Proc, M) :-
312	Proc = _/_, !,
313	get_flag_body(Proc, _, _, M),	% so that it fails if none visible
314	!,
315	(
316	    get_flag_body(Proc, F, V, M),
317	    printf('%-20s%w%n', [F, V]),
318	    fail
319	;
320	    true
321	).
322pred_body(Proc, M) :-
323	error(5, pred(Proc), M).
324
325
326trimcore :-
327	% We do a garbage collection first because trimcore0 unmaps unsed
328	% parts of the stacks. The gc removes trail entries which point above
329	% the stack tops. Such entries could lead to segfaults when untrailing
330	% after unmapping the former stack space they point to.
331	garbage_collect,
332	% Now unmap space above stack tops, free abolished code, etc.
333	trimcore0.
334
335
336:- skipped
337	abolish_op/2,
338	current_built_in/1,
339	current_op/3,
340	current_predicate/1,
341	is_built_in/1,
342	pred/1.
343
344:- untraceable
345	(als)/1,
346	(als)/2,
347	pred/1.
348
349