root/tags/lgt2212/compiler/logtalk.pl

Revision 1568, 234.2 KB (checked in by pmoura, 4 years ago)

Improved the implementation of the new "alias/1" predicate property.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
Line 
1
2%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3%
4%  Logtalk - Object oriented extension to Prolog
5%  Release 2.21.2
6%
7%  Copyright (c) 1998-2004 Paulo Moura.  All Rights Reserved.
8%
9%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10
11
12
13
14%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
15%
16%  operators
17%
18%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
19
20
21
22% message sending operators
23
24:- op(600, xfy, ::).            % send to object
25:- op(600,  fy, ::).            % send to self
26
27:- op(600,  fy, ^^).            % super call
28
29
30% mode operators
31
32:- op(200, fy, +).              % input argument (instantiated)
33:- op(200, fy, ?).              % input/output argument
34:- op(200, fy, @).              % input argument (not modified by the call)
35:- op(200, fy, -).              % output argument (not instantiated)
36
37
38
39
40%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
41%
42%  runtime directives
43%
44%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
45
46
47
48% tables of defined events and monitors
49
50:- dynamic('$lgt_before_'/5).               % '$lgt_before_'(Obj, Msg, Sender, Monitor, Call)
51:- dynamic('$lgt_after_'/5).                % '$lgt_after_'(Obj, Msg, Sender, Monitor, Call)
52
53
54
55% tables of loaded entities and respective relationships
56
57:- dynamic('$lgt_current_protocol_'/3).     % '$lgt_current_protocol_'(Ptc, Prefix, Type)
58:- dynamic('$lgt_current_category_'/3).     % '$lgt_current_category_'(Ctg, Prefix, Type)
59:- dynamic('$lgt_current_object_'/6).       % '$lgt_current_object_'(Obj, Prefix, Dcl, Def, Super, Type)
60
61:- dynamic('$lgt_implements_protocol_'/3).  % '$lgt_implements_protocol_'(ObjOrCtg, Ptc, Scope)
62:- dynamic('$lgt_imports_category_'/3).     % '$lgt_imports_category_'(ObjOrCtg, Ctg, Scope)
63:- dynamic('$lgt_instantiates_class_'/3).   % '$lgt_instantiates_class_'(Instance, Class, Scope)
64:- dynamic('$lgt_specializes_class_'/3).    % '$lgt_specializes_class_'(Class, Superclass, Scope)
65:- dynamic('$lgt_extends_protocol_'/3).     % '$lgt_extends_protocol_'(Ptc1, Ptc2, Scope)
66:- dynamic('$lgt_extends_object_'/3).       % '$lgt_extends_object_'(Prototype, Parent, Scope)
67
68
69
70% debugger status and tables
71
72:- dynamic('$lgt_debugging_'/1).            % '$lgt_debugging_'(Entity)
73
74:- dynamic('$lgt_dbg_debugging_'/0).        % '$lgt_dbg_debugging_'
75:- dynamic('$lgt_dbg_tracing_'/0).          % '$lgt_dbg_tracing_'
76:- dynamic('$lgt_dbg_skipping_'/0).         % '$lgt_dbg_skipping_'
77:- dynamic('$lgt_dbg_spying_'/1).           % '$lgt_dbg_spying_'(Functor/Arity)
78:- dynamic('$lgt_dbg_spying_'/4).           % '$lgt_dbg_spying_'(Sender, This, Self, Goal)
79:- dynamic('$lgt_dbg_leashing_'/1).         % '$lgt_dbg_leashing_'(Port)
80
81
82
83% runtime flags
84
85:- dynamic('$lgt_current_flag_'/2).         % '$lgt_current_flag_'(Option, Value)
86
87
88
89% lookup caches for messages to an object, messages to self, and super calls
90
91:- dynamic('$lgt_obj_lookup_cache_'/6).     % '$lgt_obj_lookup_cache_'(Obj, Pred, Sender, This, Self, Call)
92:- dynamic('$lgt_self_lookup_cache_'/6).    % '$lgt_self_lookup_cache_'(Obj, Pred, Sender, This, Self, Call)
93:- dynamic('$lgt_super_lookup_cache_'/6).   % '$lgt_super_lookup_cache_'(Obj, Pred, Sender, This, Self, Call)
94
95
96
97
98%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
99%
100%  pre-processor directives (used for entity compilation)
101%
102%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
103
104
105
106:- dynamic('$lgt_pp_compiler_option_'/2).       % '$lgt_pp_compiler_option_'(Option, Value)
107
108:- dynamic('$lgt_pp_dcl_'/1).                   % '$lgt_pp_dcl_'(Clause)
109:- dynamic('$lgt_pp_ddcl_'/1).                  % '$lgt_pp_ddcl_'(Clause)
110:- dynamic('$lgt_pp_def_'/1).                   % '$lgt_pp_def_'(Clause)
111:- dynamic('$lgt_pp_ddef_'/1).                  % '$lgt_pp_ddef_'(Clause)
112:- dynamic('$lgt_pp_super_'/1).                 % '$lgt_pp_super_'(Clause)
113
114:- dynamic('$lgt_pp_dynamic_'/1).               % '$lgt_pp_dynamic_'(Functor/Arity)
115:- dynamic('$lgt_pp_discontiguous_'/1).         % '$lgt_pp_discontiguous_'(Functor/Arity)
116:- dynamic('$lgt_pp_mode_'/2).                  % '$lgt_pp_mode_'(Mode, Determinism)
117:- dynamic('$lgt_pp_public_'/1).                % '$lgt_pp_public_'(Functor/Arity)
118:- dynamic('$lgt_pp_protected_'/1).             % '$lgt_pp_protected_'(Functor/Arity)
119:- dynamic('$lgt_pp_private_'/1).               % '$lgt_pp_private_'(Functor/Arity)
120:- dynamic('$lgt_pp_metapredicate_'/1).         % '$lgt_pp_metapredicate_'(Pred)
121:- dynamic('$lgt_pp_alias_'/3).                 % '$lgt_pp_alias_'(Entity, Pred1, Pred2)
122:- dynamic('$lgt_pp_non_terminal_'/3).          % '$lgt_pp_non_terminal_'(Functor, Args, Arity)
123
124:- dynamic('$lgt_pp_object_'/9).                % '$lgt_pp_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef)
125:- dynamic('$lgt_pp_category_'/4).              % '$lgt_pp_category_'(Ctg, Prefix, Dcl, Def)
126:- dynamic('$lgt_pp_protocol_'/3).              % '$lgt_pp_protocol_'(Ptc, Prefix, Dcl)
127
128:- dynamic('$lgt_pp_uses_'/1).                  % '$lgt_pp_uses_'(Obj)
129:- dynamic('$lgt_pp_uses_'/2).                  % '$lgt_pp_uses_'(Obj, Predicate)
130:- dynamic('$lgt_pp_calls_'/1).                 % '$lgt_pp_calls_'(Entity)
131:- dynamic('$lgt_pp_info_'/1).                  % '$lgt_pp_info_'(List)
132:- dynamic('$lgt_pp_info_'/2).                  % '$lgt_pp_info_'(Functor/Arity, List)
133
134:- dynamic('$lgt_pp_implemented_protocol_'/4).  % '$lgt_pp_implemented_protocol_'(Ptc, Prefix, Dcl, Scope)
135:- dynamic('$lgt_pp_imported_category_'/5).     % '$lgt_pp_imported_category_'(Ctg, Prefix, Dcl, Def, Scope)
136:- dynamic('$lgt_pp_extended_object_'/10).      % '$lgt_pp_extended_object_'(Parent, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)
137:- dynamic('$lgt_pp_instantiated_class_'/10).   % '$lgt_pp_instantiated_class_'(Class, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)
138:- dynamic('$lgt_pp_specialized_class_'/10).    % '$lgt_pp_specialized_class_'(Superclass, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)
139:- dynamic('$lgt_pp_extended_protocol_'/4).     % '$lgt_pp_extended_protocol_'(Ptc, Prefix, Dcl, Scope)
140
141:- dynamic('$lgt_pp_entity_'/4).                % '$lgt_pp_entity_'(Type, Entity, Prefix, Dcl)
142:- dynamic('$lgt_pp_entity_functors_'/1).       % '$lgt_pp_entity_functors_'(Clause)
143:- dynamic('$lgt_pp_entity_init_'/1).           % '$lgt_pp_entity_init_'(Goal)
144:- dynamic('$lgt_pp_fentity_init_'/1).          % '$lgt_pp_fentity_init_'(Goal)
145:- dynamic('$lgt_pp_entity_comp_mode_'/1).      % '$lgt_pp_entity_comp_mode_'(Type)
146
147:- dynamic('$lgt_pp_redefined_built_in_'/3).    % '$lgt_pp_redefined_built_in_'(Head, Context, THead)
148
149:- dynamic('$lgt_pp_directive_'/1).             % '$lgt_pp_directive_'(Dir)
150:- dynamic('$lgt_pp_rclause_'/1).               % '$lgt_pp_rclause_'(Clause)
151:- dynamic('$lgt_pp_eclause_'/1).               % '$lgt_pp_eclause_'(Clause)
152:- dynamic('$lgt_pp_feclause_'/1).              % '$lgt_pp_feclause_'(Clause)
153
154:- dynamic('$lgt_pp_defs_pred_'/1).             % '$lgt_pp_defs_pred_'(Functor/Arity)
155:- dynamic('$lgt_pp_calls_pred_'/1).            % '$lgt_pp_calls_pred_'(Functor/Arity)
156
157:- dynamic('$lgt_pp_referenced_object_'/1).     % '$lgt_pp_referenced_object_'(Object)
158:- dynamic('$lgt_pp_referenced_protocol_'/1).   % '$lgt_pp_referenced_protocol_'(Protocol)
159:- dynamic('$lgt_pp_referenced_category_'/1).   % '$lgt_pp_referenced_category_'(Category)
160
161:- dynamic('$lgt_pp_global_op_'/3).             % '$lgt_pp_global_op_'(Priority, Specifier, Operator)
162:- dynamic('$lgt_pp_local_op_'/3).              % '$lgt_pp_local_op_'(Priority, Specifier, Operator)
163
164
165
166
167%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
168%
169%  top level runtime predicate for message sending: ::/2
170%
171%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
172
173
174
175Obj::Pred :-
176    var(Obj),
177    throw(error(instantiation_error, Obj::Pred, user)).
178
179Obj::Pred :-
180    var(Pred),
181    throw(error(instantiation_error, Obj::Pred, user)).
182
183Obj::Pred :-
184    '$lgt_context'(Ctx, user, user, Obj, _, []),
185    '$lgt_tr_msg'(Pred, Obj, Call, Ctx),
186    (('$lgt_dbg_debugging_', '$lgt_debugging_'(Obj)) ->
187        catch(
188            '$lgt_dbg_goal'(Obj::Pred, Call, Ctx),
189            Error,
190            (Error = error(logtalk_debugger_aborted) ->
191                write('Debugging session aborted by user. Debugger still on.'), nl, fail
192                ;
193                throw(Error)))
194        ;
195        call(Call)).
196
197
198
199
200%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
201%
202%  built-in predicates
203%
204%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
205
206
207
208% current_object(?object_identifier)
209
210current_object(Obj) :-
211    nonvar(Obj),
212    \+ callable(Obj),
213    throw(error(type_error(object_identifier, Obj), current_object(Obj))).
214
215current_object(Obj) :-
216    '$lgt_current_object_'(Obj, _, _, _, _, _).
217
218
219
220% current_protocol(?protocol_identifier)
221
222current_protocol(Ptc) :-
223    nonvar(Ptc),
224    \+ atom(Ptc),
225    throw(error(type_error(protocol_identifier, Ptc), current_protocol(Ptc))).
226
227current_protocol(Ptc) :-
228    '$lgt_current_protocol_'(Ptc, _, _).
229
230
231
232% current_category(?category_identifier)
233
234current_category(Ctg) :-
235    nonvar(Ctg),
236    \+ atom(Ctg),
237    throw(error(type_error(category_identifier, Ctg), current_category(Ctg))).
238
239current_category(Ctg) :-
240    '$lgt_current_category_'(Ctg, _, _).
241
242
243
244% object_property(?object_identifier, ?object_property)
245
246object_property(Obj, Prop) :-
247    nonvar(Obj),
248    \+ callable(Obj),
249    throw(error(type_error(object_identifier, Obj), object_property(Obj, Prop))).
250
251object_property(Obj, Prop) :-
252    nonvar(Prop),
253    \+ '$lgt_member'(Prop, [(dynamic), static, built_in]),
254    throw(error(domain_error(object_property, Prop), object_property(Obj, Prop))).
255
256object_property(user, built_in).
257object_property(debugger, built_in).
258
259object_property(Obj, Prop) :-
260    '$lgt_current_object_'(Obj, _, _, _, _, Prop).
261
262
263
264% category_property(?category_identifier, ?category_property)
265
266category_property(Ctg, Prop) :-
267    nonvar(Ctg),
268    \+ atom(Ctg),
269    throw(error(type_error(category_identifier, Ctg), category_property(Ctg, Prop))).
270
271category_property(Ctg, Prop) :-
272    nonvar(Prop),
273    \+ '$lgt_member'(Prop, [(dynamic), static, built_in]),
274    throw(error(domain_error(category_property, Prop), category_property(Ctg, Prop))).
275
276category_property(Ctg, Prop) :-
277    '$lgt_current_category_'(Ctg, _, Prop).
278
279
280
281% protocol_property(?protocol_identifier, ?protocol_property)
282
283protocol_property(Ptc, Prop) :-
284    nonvar(Ptc),
285    \+ atom(Ptc),
286    throw(error(type_error(protocol_identifier, Ptc), protocol_property(Ptc, Prop))).
287
288protocol_property(Ptc, Prop) :-
289    nonvar(Prop),
290    \+ '$lgt_member'(Prop, [(dynamic), static, built_in]),
291    throw(error(domain_error(protocol_property, Prop), protocol_property(Ptc, Prop))).
292
293protocol_property(Ptc, Prop) :-
294    '$lgt_current_protocol_'(Ptc, _, Prop).
295
296
297
298% create_object(+object_identifier, +list, +list, +list)
299
300create_object(Obj, Rels, Dirs, Clauses) :-
301    var(Obj),
302    throw(error(instantiation_error, create_object(Obj, Rels, Dirs, Clauses))).
303
304create_object(Obj, Rels, Dirs, Clauses) :-
305    \+ callable(Obj),
306    throw(error(type_error(object_identifier, Obj), create_object(Obj, Rels, Dirs, Clauses))).
307
308create_object(Obj, Rels, Dirs, Clauses) :-
309    '$lgt_current_object_'(Obj, _, _, _, _, _),
310    throw(error(permission_error(replace, object, Obj), create_object(Obj, Rels, Dirs, Clauses))).
311
312create_object(Obj, Rels, Dirs, Clauses) :-
313    '$lgt_current_category_'(Obj, _, _),
314    throw(error(permission_error(replace, category, Obj), create_object(Obj, Rels, Dirs, Clauses))).
315
316create_object(Obj, Rels, Dirs, Clauses) :-
317    '$lgt_current_protocol_'(Obj, _, _),
318    throw(error(permission_error(replace, protocol, Obj), create_object(Obj, Rels, Dirs, Clauses))).
319
320create_object(Obj, Rels, Dirs, Clauses) :-
321    (var(Rels); \+ '$lgt_proper_list'(Rels)),
322    throw(error(type_error(list, Rels), create_object(Obj, Rels, Dirs, Clauses))).
323
324create_object(Obj, Rels, Dirs, Clauses) :-
325    (var(Dirs); \+ '$lgt_proper_list'(Dirs)),
326    throw(error(type_error(list, Dirs), create_object(Obj, Rels, Dirs, Clauses))).
327
328create_object(Obj, Rels, Dirs, Clauses) :-
329    (var(Clauses); \+ '$lgt_proper_list'(Clauses)),
330    throw(error(type_error(list, Clauses), create_object(Obj, Rels, Dirs, Clauses))).
331
332create_object(Obj, Rels, Dirs, Clauses) :-
333    '$lgt_clean_pp_clauses',
334    '$lgt_tr_directive'(object, [Obj| Rels]),
335    '$lgt_tr_directives'([(dynamic)| Dirs]),
336    '$lgt_tr_clauses'(Clauses),
337    '$lgt_fix_redef_built_ins',
338    '$lgt_gen_object_clauses',
339    '$lgt_gen_object_directives',
340    '$lgt_assert_tr_entity',
341    '$lgt_report_unknown_entities',
342    '$lgt_clean_pp_clauses'.
343
344
345
346% create_category(+category_identifier, +list, +list, +list)
347
348create_category(Ctg, Rels, Dirs, Clauses) :-
349    var(Ctg),
350    throw(error(instantiation_error, create_category(Ctg, Rels, Dirs, Clauses))).
351
352create_category(Ctg, Rels, Dirs, Clauses) :-
353    \+ atom(Ctg),
354    throw(error(type_error(category_identifier, Ctg), create_category(Ctg, Rels, Dirs, Clauses))).
355
356create_category(Ctg, Rels, Dirs, Clauses) :-
357    '$lgt_current_category_'(Ctg, _, _),
358    throw(error(permission_error(replace, category, Ctg), create_category(Ctg, Rels, Dirs, Clauses))).
359
360create_category(Ctg, Rels, Dirs, Clauses) :-
361    '$lgt_current_object_'(Ctg, _, _, _, _, _),
362    throw(error(permission_error(replace, object, Ctg), create_category(Ctg, Rels, Dirs, Clauses))).
363
364create_category(Ctg, Rels, Dirs, Clauses) :-
365    '$lgt_current_protocol_'(Ctg, _, _),
366    throw(error(permission_error(replace, protocol, Ctg), create_category(Ctg, Rels, Dirs, Clauses))).
367
368create_category(Ctg, Rels, Dirs, Clauses) :-
369    (var(Rels); \+ '$lgt_proper_list'(Rels)),
370    throw(error(type_error(list, Rels), create_category(Ctg, Rels, Dirs, Clauses))).
371
372create_category(Ctg, Rels, Dirs, Clauses) :-
373    (var(Dirs); \+ '$lgt_proper_list'(Dirs)),
374    throw(error(type_error(list, Dirs), create_category(Ctg, Rels, Dirs, Clauses))).
375
376create_category(Ctg, Rels, Dirs, Clauses) :-
377    (var(Clauses); \+ '$lgt_proper_list'(Clauses)),
378    throw(error(type_error(list, Clauses), create_category(Ctg, Rels, Dirs, Clauses))).
379
380create_category(Ctg, Rels, Dirs, Clauses) :-
381    '$lgt_clean_pp_clauses',
382    '$lgt_tr_directive'(category, [Ctg| Rels]),
383    '$lgt_tr_directives'([(dynamic)| Dirs]),
384    '$lgt_tr_clauses'(Clauses),
385    '$lgt_fix_redef_built_ins',
386    '$lgt_gen_category_clauses',
387    '$lgt_gen_category_directives',
388    '$lgt_assert_tr_entity',
389    '$lgt_report_unknown_entities',
390    '$lgt_clean_pp_clauses'.
391
392
393
394% create_protocol(+protocol_identifier, +list, +list)
395
396create_protocol(Ptc, Rels, Dirs) :-
397    var(Ptc),
398    throw(error(instantiation_error, create_protocol(Ptc, Rels, Dirs))).
399
400create_protocol(Ptc, Rels, Dirs) :-
401    \+ atom(Ptc),
402    throw(error(type_error(protocol_identifier, Ptc), create_protocol(Ptc, Rels, Dirs))).
403
404create_protocol(Ptc, Rels, Dirs) :-
405    '$lgt_current_protocol_'(Ptc, _, _),
406    throw(error(permission_error(replace, protocol, Ptc), create_protocol(Ptc, Rels, Dirs))).
407
408create_protocol(Ptc, Rels, Dirs) :-
409    '$lgt_current_object_'(Ptc, _, _, _, _, _),
410    throw(error(permission_error(replace, object, Ptc), create_protocol(Ptc, Rels, Dirs))).
411
412create_protocol(Ptc, Rels, Dirs) :-
413    '$lgt_current_category_'(Ptc, _, _),
414    throw(error(permission_error(replace, category, Ptc), create_protocol(Ptc, Rels, Dirs))).
415
416create_protocol(Ptc, Rels, Dirs) :-
417    (var(Rels); \+ '$lgt_proper_list'(Rels)),
418    throw(error(type_error(list, Rels), create_protocol(Ptc, Rels, Dirs))).
419
420create_protocol(Ptc, Rels, Dirs) :-
421    (var(Dirs); \+ '$lgt_proper_list'(Dirs)),
422    throw(error(type_error(list, Dirs), create_protocol(Ptc, Rels, Dirs))).
423
424create_protocol(Ptc, Rels, Dirs) :-
425    '$lgt_clean_pp_clauses',
426    '$lgt_tr_directive'(protocol, [Ptc| Rels]),
427    '$lgt_tr_directives'([(dynamic)| Dirs]),
428    '$lgt_gen_protocol_clauses',
429    '$lgt_gen_protocol_directives',
430    '$lgt_assert_tr_entity',
431    '$lgt_report_unknown_entities',
432    '$lgt_clean_pp_clauses'.
433
434
435
436% abolish_object(@object_identifier)
437
438abolish_object(Obj) :-
439    var(Obj),
440    throw(error(instantiation_error, abolish_object(Obj))).
441
442abolish_object(Obj) :-
443    \+ callable(Obj),
444    throw(error(type_error(object_identifier, Obj), abolish_object(Obj))).
445
446abolish_object(Obj) :-
447    '$lgt_current_object_'(Obj, Prefix, _, _, _, Type) ->
448        (Type = (dynamic) ->
449            '$lgt_call'(Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef),
450            forall(
451                '$lgt_call'(Def, _, _, _, _, Pred),
452                (functor(Pred, Functor, Arity), abolish(Functor/Arity))),
453            forall(
454                '$lgt_call'(DDef, _, _, _, _, Pred),
455                (functor(Pred, Functor, Arity), abolish(Functor/Arity))),
456            abolish(Dcl/4),
457            abolish(Dcl/6),
458            abolish(Def/5),
459            abolish(Def/6),
460            abolish(Super/6),
461            abolish(IDcl/6),
462            abolish(IDef/6),
463            abolish(DDcl/2),
464            abolish(DDef/5),
465            abolish(Prefix/7),
466            retractall('$lgt_current_object_'(Obj, _, _, _, _, _)),
467            retractall('$lgt_extends_object_'(Obj, _, _)),
468            retractall('$lgt_instantiates_class_'(Obj, _, _)),
469            retractall('$lgt_specializes_class_'(Obj, _, _)),
470            retractall('$lgt_implements_protocol_'(Obj, _, _)),
471            retractall('$lgt_imports_category_'(Obj, _, _)),
472            retractall('$lgt_debugging_'(Obj)),
473            '$lgt_clean_lookup_caches'
474            ;
475            throw(error(permission_error(modify, static_object, Obj), abolish_object(Obj))))
476        ;
477        throw(error(existence_error(object, Obj), abolish_object(Obj))).
478
479
480
481% abolish_category(@category_identifier)
482
483abolish_category(Ctg) :-
484    var(Ctg),
485    throw(error(instantiation_error, abolish_category(Ctg))).
486
487abolish_category(Ctg) :-
488    \+ atom(Ctg),
489    throw(error(type_error(category_identifier, Ctg), abolish_category(Ctg))).
490
491abolish_category(Ctg) :-
492    '$lgt_current_category_'(Ctg, Prefix, Type) ->
493        (Type = (dynamic) ->
494            '$lgt_call'(Prefix, Dcl, Def),
495            forall(
496                '$lgt_call'(Def, _, _, _, _, Pred),
497                (functor(Pred, Functor, Arity), abolish(Functor/Arity))),
498            abolish(Dcl/4),
499            abolish(Dcl/5),
500            abolish(Def/5),
501            abolish(Prefix/2),
502            retractall('$lgt_current_category_'(Ctg, _, _)),
503            retractall('$lgt_implements_protocol_'(Ctg, _, _)),
504            '$lgt_clean_lookup_caches'
505            ;
506            throw(error(permission_error(modify, static_category, Ctg), abolish_category(Ctg))))
507        ;
508        throw(error(existence_error(category, Ctg), abolish_category(Ctg))).
509
510
511
512% abolish_protocol(@protocol_identifier)
513
514abolish_protocol(Ptc) :-
515    var(Ptc),
516    throw(error(instantiation_error, abolish_protocol(Ptc))).
517
518abolish_protocol(Ptc) :-
519    \+ atom(Ptc),
520    throw(error(type_error(protocol_identifier, Ptc), abolish_protocol(Ptc))).
521
522abolish_protocol(Ptc) :-
523    '$lgt_current_protocol_'(Ptc, Prefix, Type) ->
524        (Type = (dynamic) ->
525            '$lgt_call'(Prefix, Dcl),
526            abolish(Dcl/4),
527            abolish(Dcl/5),
528            abolish(Prefix/1),
529            retractall('$lgt_current_protocol_'(Ptc, _, _)),
530            retractall('$lgt_extends_protocol_'(Ptc, _, _)),
531            '$lgt_clean_lookup_caches'
532            ;
533            throw(error(permission_error(modify, static_protocol, Ptc), abolish_protocol(Ptc))))
534        ;
535        throw(error(existence_error(protocol, Ptc), abolish_protocol(Ptc))).
536
537
538
539% implements_protocol(?object_identifier, ?protocol_identifier)
540% implements_protocol(?category_identifier, ?protocol_identifier)
541
542implements_protocol(ObjOrCtg, Ptc) :-
543    catch(
544        implements_protocol(ObjOrCtg, Ptc, _),
545        error(Error, _),
546        throw(error(Error, implements_protocol(ObjOrCtg, Ptc)))).
547
548
549
550% implements_protocol(?object_identifier, ?protocol_identifier, ?atom)
551% implements_protocol(?category_identifier, ?protocol_identifier, ?atom)
552
553implements_protocol(ObjOrCtg, Ptc, Scope) :-
554    nonvar(ObjOrCtg),
555    \+ callable(ObjOrCtg),
556    throw(error(type_error(object_identifier, ObjOrCtg), implements_protocol(ObjOrCtg, Ptc, Scope))).
557
558implements_protocol(ObjOrCtg, Ptc, Scope) :-
559    nonvar(Ptc),
560    \+ atom(Ptc),
561    throw(error(type_error(protocol_identifier, Ptc), implements_protocol(ObjOrCtg, Ptc, Scope))).
562
563implements_protocol(ObjOrCtg, Ptc, Scope) :-
564    nonvar(Scope),
565    \+ '$lgt_member'(Scope, [(public), protected, private]),
566    throw(error(type_error(scope, Scope), implements_protocol(ObjOrCtg, Ptc, Scope))).
567
568implements_protocol(ObjOrCtg, Ptc, Scope) :-
569    '$lgt_implements_protocol_'(ObjOrCtg, Ptc, Scope).
570
571
572
573% imports_category(?object_identifier, ?category_identifier)
574% imports_category(?category_identifier, ?category_identifier)
575
576imports_category(ObjOrCtg, Ctg) :-
577    catch(
578        imports_category(ObjOrCtg, Ctg, _),
579        error(Error, _),
580        throw(error(Error, imports_category(ObjOrCtg, Ctg)))).
581
582
583
584% imports_category(?object_identifier, ?category_identifier, ?atom)
585% imports_category(?category_identifier, ?category_identifier, ?atom)
586
587imports_category(ObjOrCtg, Ctg, Scope) :-
588    nonvar(ObjOrCtg),
589    \+ callable(ObjOrCtg),
590    throw(error(type_error(object_identifier, ObjOrCtg), imports_category(ObjOrCtg, Ctg, Scope))).
591
592imports_category(ObjOrCtg, Ctg, Scope) :-
593    nonvar(Ctg),
594    \+ atom(Ctg),
595    throw(error(type_error(category_identifier, Ctg), imports_category(ObjOrCtg, Ctg, Scope))).
596
597imports_category(ObjOrCtg, Ctg, Scope) :-
598    nonvar(Scope),
599    \+ '$lgt_member'(Scope, [(public), protected, private]),
600    throw(error(type_error(scope, Scope), imports_category(ObjOrCtg, Ctg, Scope))).
601
602imports_category(ObjOrCtg, Ctg, Scope) :-
603    '$lgt_imports_category_'(ObjOrCtg, Ctg, Scope).
604
605
606
607% instantiates_class(?object_identifier, ?object_identifier)
608
609instantiates_class(Obj, Class) :-
610    catch(
611        instantiates_class(Obj, Class, _),
612        error(Error, _),
613        throw(error(Error, instantiates_class(Obj, Class)))).
614
615
616
617% instantiates_class(?object_identifier, ?object_identifier, ?atom)
618
619instantiates_class(Obj, Class, Scope) :-
620    nonvar(Obj),
621    \+ callable(Obj),
622    throw(error(type_error(object_identifier, Obj), instantiates_class(Obj, Class, Scope))).
623
624instantiates_class(Obj, Class, Scope) :-
625    nonvar(Class),
626    \+ callable(Class),
627    throw(error(type_error(object_identifier, Class), instantiates_class(Obj, Class, Scope))).
628
629instantiates_class(Obj, Class, Scope) :-
630    nonvar(Scope),
631    \+ '$lgt_member'(Scope, [(public), protected, private]),
632    throw(error(type_error(scope, Scope), instantiates_class(Obj, Class, Scope))).
633
634instantiates_class(Obj, Class, Scope) :-
635    '$lgt_instantiates_class_'(Obj, Class, Scope).
636
637
638
639% specializes_class(?object_identifier, ?object_identifier)
640
641specializes_class(Class, Superclass) :-
642    catch(
643        specializes_class(Class, Superclass, _),
644        error(Error, _),
645        throw(error(Error, specializes_class(Class, Superclass)))).
646
647
648
649% specializes_class(?object_identifier, ?object_identifier, ?atom)
650
651specializes_class(Class, Superclass, Scope) :-
652    nonvar(Class),
653    \+ callable(Class),
654    throw(error(type_error(object_identifier, Class), specializes_class(Class, Superclass, Scope))).
655
656specializes_class(Class, Superclass, Scope) :-
657    nonvar(Superclass),
658    \+ callable(Superclass),
659    throw(error(type_error(object_identifier, Superclass), specializes_class(Class, Superclass, Scope))).
660
661specializes_class(Class, Superclass, Scope) :-
662    nonvar(Scope),
663    \+ '$lgt_member'(Scope, [(public), protected, private]),
664    throw(error(type_error(scope, Scope), specializes_class(Class, Superclass, Scope))).
665
666specializes_class(Class, Superclass, Scope) :-
667    '$lgt_specializes_class_'(Class, Superclass, Scope).
668
669
670
671% extends_protocol(?protocol_identifier, ?protocol_identifier)
672
673extends_protocol(Ptc1, Ptc2) :-
674    catch(
675        extends_protocol(Ptc1, Ptc2, _),
676        error(Error, _),
677        throw(error(Error, extends_protocol(Ptc1, Ptc2)))).
678
679
680
681% extends_protocol(?protocol_identifier, ?protocol_identifier, ?atom)
682
683extends_protocol(Ptc1, Ptc2, Scope) :-
684    nonvar(Ptc1),
685    \+ atom(Ptc1),
686    throw(error(type_error(protocol_identifier, Ptc1), extends_protocol(Ptc1, Ptc2, Scope))).
687
688extends_protocol(Ptc1, Ptc2, Scope) :-
689    nonvar(Ptc2),
690    \+ atom(Ptc2),
691    throw(error(type_error(protocol_identifier, Ptc2), extends_protocol(Ptc1, Ptc2, Scope))).
692
693extends_protocol(Ptc1, Ptc2, Scope) :-
694    nonvar(Scope),
695    \+ '$lgt_member'(Scope, [(public), protected, private]),
696    throw(error(type_error(scope, Scope), extends_protocol(Ptc1, Ptc2, Scope))).
697
698extends_protocol(Ptc1, Ptc2, Scope) :-
699    '$lgt_extends_protocol_'(Ptc1, Ptc2, Scope).
700
701
702
703% extends_object(?object_identifier, ?object_identifier)
704
705extends_object(Prototype, Parent) :-
706    catch(
707        extends_object(Prototype, Parent, _),
708        error(Error, _),
709        throw(error(Error, extends_object(Prototype, Parent)))).
710
711
712
713% extends_object(?object_identifier, ?object_identifier, ?atom)
714
715extends_object(Prototype, Parent, Scope) :-
716    nonvar(Prototype),
717    \+ callable(Prototype),
718    throw(error(type_error(object_identifier, Prototype), extends_object(Prototype, Parent, Scope))).
719
720extends_object(Prototype, Parent, Scope) :-
721    nonvar(Parent),
722    \+ callable(Parent),
723    throw(error(type_error(object_identifier, Parent), extends_object(Prototype, Parent, Scope))).
724
725extends_object(Prototype, Parent, Scope) :-
726    nonvar(Scope),
727    \+ '$lgt_member'(Scope, [(public), protected, private]),
728    throw(error(type_error(scope, Scope), extends_object(Prototype, Parent, Scope))).
729
730extends_object(Prototype, Parent, Scope) :-
731    '$lgt_extends_object_'(Prototype, Parent