root/tags/lgt2210/compiler/logtalk.pl

Revision 1494, 227.3 KB (checked in by pmoura, 4 years ago)

Corrected a bug (not present in previous stable versions) with parametric entities (due to changes to support the new alias/3 predicate directive).
  • 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.0
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
123:- dynamic('$lgt_pp_object_'/9).                % '$lgt_pp_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef)
124:- dynamic('$lgt_pp_category_'/4).              % '$lgt_pp_category_'(Ctg, Prefix, Dcl, Def)
125:- dynamic('$lgt_pp_protocol_'/3).              % '$lgt_pp_protocol_'(Ptc, Prefix, Dcl)
126
127:- dynamic('$lgt_pp_uses_'/1).                  % '$lgt_pp_uses_'(Obj)
128:- dynamic('$lgt_pp_uses_'/2).                  % '$lgt_pp_uses_'(Obj, Predicate)
129:- dynamic('$lgt_pp_calls_'/1).                 % '$lgt_pp_calls_'(Entity)
130:- dynamic('$lgt_pp_info_'/1).                  % '$lgt_pp_info_'(List)
131:- dynamic('$lgt_pp_info_'/2).                  % '$lgt_pp_info_'(Functor/Arity, List)
132
133:- dynamic('$lgt_pp_implemented_protocol_'/4).  % '$lgt_pp_implemented_protocol_'(Ptc, Prefix, Dcl, Scope)
134:- dynamic('$lgt_pp_imported_category_'/5).     % '$lgt_pp_imported_category_'(Ctg, Prefix, Dcl, Def, Scope)
135:- dynamic('$lgt_pp_extended_object_'/10).      % '$lgt_pp_extended_object_'(Parent, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)
136:- dynamic('$lgt_pp_instantiated_class_'/10).   % '$lgt_pp_instantiated_class_'(Class, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)
137:- dynamic('$lgt_pp_specialized_class_'/10).    % '$lgt_pp_specialized_class_'(Superclass, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)
138:- dynamic('$lgt_pp_extended_protocol_'/4).     % '$lgt_pp_extended_protocol_'(Ptc, Prefix, Dcl, Scope)
139
140:- dynamic('$lgt_pp_entity_'/4).                % '$lgt_pp_entity_'(Type, Entity, Prefix, Dcl)
141:- dynamic('$lgt_pp_entity_functors_'/1).       % '$lgt_pp_entity_functors_'(Clause)
142:- dynamic('$lgt_pp_entity_init_'/1).           % '$lgt_pp_entity_init_'(Goal)
143:- dynamic('$lgt_pp_fentity_init_'/1).          % '$lgt_pp_fentity_init_'(Goal)
144:- dynamic('$lgt_pp_entity_comp_mode_'/1).      % '$lgt_pp_entity_comp_mode_'(Type)
145
146:- dynamic('$lgt_pp_redefined_built_in_'/3).    % '$lgt_pp_redefined_built_in_'(Head, Context, THead)
147
148:- dynamic('$lgt_pp_directive_'/1).             % '$lgt_pp_directive_'(Dir)
149:- dynamic('$lgt_pp_rclause_'/1).               % '$lgt_pp_rclause_'(Clause)
150:- dynamic('$lgt_pp_eclause_'/1).               % '$lgt_pp_eclause_'(Clause)
151:- dynamic('$lgt_pp_feclause_'/1).              % '$lgt_pp_feclause_'(Clause)
152
153:- dynamic('$lgt_pp_defs_pred_'/1).             % '$lgt_pp_defs_pred_'(Functor/Arity)
154:- dynamic('$lgt_pp_calls_pred_'/1).            % '$lgt_pp_calls_pred_'(Functor/Arity)
155
156:- dynamic('$lgt_pp_referenced_object_'/1).     % '$lgt_pp_referenced_object_'(Object)
157:- dynamic('$lgt_pp_referenced_protocol_'/1).   % '$lgt_pp_referenced_protocol_'(Protocol)
158:- dynamic('$lgt_pp_referenced_category_'/1).   % '$lgt_pp_referenced_category_'(Category)
159
160:- dynamic('$lgt_pp_global_op_'/3).             % '$lgt_pp_global_op_'(Priority, Specifier, Operator)
161:- dynamic('$lgt_pp_local_op_'/3).              % '$lgt_pp_local_op_'(Priority, Specifier, Operator)
162
163
164
165
166%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
167%
168%  top level runtime predicate for message sending: ::/2
169%
170%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
171
172
173
174Obj::Pred :-
175    var(Obj),
176    throw(error(instantiation_error, Obj::Pred, user)).
177
178Obj::Pred :-
179    var(Pred),
180    throw(error(instantiation_error, Obj::Pred, user)).
181
182Obj::Pred :-
183    '$lgt_context'(Ctx, user, user, Obj, _, []),
184    '$lgt_tr_msg'(Pred, Obj, Call, Ctx),
185    (('$lgt_dbg_debugging_', '$lgt_debugging_'(Obj)) ->
186        catch(
187            '$lgt_dbg_goal'(Obj::Pred, Call, Ctx),
188            Error,
189            (Error = error(logtalk_debugger_aborted) ->
190                write('Debugging session aborted by user. Debugger still on.'), nl, fail
191                ;
192                throw(Error)))
193        ;
194        call(Call)).
195
196
197
198
199%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
200%
201%  built-in predicates
202%
203%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
204
205
206
207% current_object(?object_identifier)
208
209current_object(Obj) :-
210    nonvar(Obj),
211    \+ callable(Obj),
212    throw(error(type_error(object_identifier, Obj), current_object(Obj))).
213
214current_object(Obj) :-
215    '$lgt_current_object_'(Obj, _, _, _, _, _).
216
217
218
219% current_protocol(?protocol_identifier)
220
221current_protocol(Ptc) :-
222    nonvar(Ptc),
223    \+ atom(Ptc),
224    throw(error(type_error(protocol_identifier, Ptc), current_protocol(Ptc))).
225
226current_protocol(Ptc) :-
227    '$lgt_current_protocol_'(Ptc, _, _).
228
229
230
231% current_category(?category_identifier)
232
233current_category(Ctg) :-
234    nonvar(Ctg),
235    \+ atom(Ctg),
236    throw(error(type_error(category_identifier, Ctg), current_category(Ctg))).
237
238current_category(Ctg) :-
239    '$lgt_current_category_'(Ctg, _, _).
240
241
242
243% object_property(?object_identifier, ?object_property)
244
245object_property(Obj, Prop) :-
246    nonvar(Obj),
247    \+ callable(Obj),
248    throw(error(type_error(object_identifier, Obj), object_property(Obj, Prop))).
249
250object_property(Obj, Prop) :-
251    nonvar(Prop),
252    \+ '$lgt_member'(Prop, [(dynamic), static, built_in]),
253    throw(error(domain_error(object_property, Prop), object_property(Obj, Prop))).
254
255object_property(user, built_in).
256object_property(debugger, built_in).
257
258object_property(Obj, Prop) :-
259    '$lgt_current_object_'(Obj, _, _, _, _, Prop).
260
261
262
263% category_property(?category_identifier, ?category_property)
264
265category_property(Ctg, Prop) :-
266    nonvar(Ctg),
267    \+ atom(Ctg),
268    throw(error(type_error(category_identifier, Ctg), category_property(Ctg, Prop))).
269
270category_property(Ctg, Prop) :-
271    nonvar(Prop),
272    \+ '$lgt_member'(Prop, [(dynamic), static, built_in]),
273    throw(error(domain_error(category_property, Prop), category_property(Ctg, Prop))).
274
275category_property(Ctg, Prop) :-
276    '$lgt_current_category_'(Ctg, _, Prop).
277
278
279
280% protocol_property(?protocol_identifier, ?protocol_property)
281
282protocol_property(Ptc, Prop) :-
283    nonvar(Ptc),
284    \+ atom(Ptc),
285    throw(error(type_error(protocol_identifier, Ptc), protocol_property(Ptc, Prop))).
286
287protocol_property(Ptc, Prop) :-
288    nonvar(Prop),
289    \+ '$lgt_member'(Prop, [(dynamic), static, built_in]),
290    throw(error(domain_error(protocol_property, Prop), protocol_property(Ptc, Prop))).
291
292protocol_property(Ptc, Prop) :-
293    '$lgt_current_protocol_'(Ptc, _, Prop).
294
295
296
297% create_object(+object_identifier, +list, +list, +list)
298
299create_object(Obj, Rels, Dirs, Clauses) :-
300    var(Obj),
301    throw(error(instantiation_error, create_object(Obj, Rels, Dirs, Clauses))).
302
303create_object(Obj, Rels, Dirs, Clauses) :-
304    \+ callable(Obj),
305    throw(error(type_error(object_identifier, Obj), create_object(Obj, Rels, Dirs, Clauses))).
306
307create_object(Obj, Rels, Dirs, Clauses) :-
308    '$lgt_current_object_'(Obj, _, _, _, _, _),
309    throw(error(permission_error(replace, object, Obj), create_object(Obj, Rels, Dirs, Clauses))).
310
311create_object(Obj, Rels, Dirs, Clauses) :-
312    '$lgt_current_category_'(Obj, _, _),
313    throw(error(permission_error(replace, category, Obj), create_object(Obj, Rels, Dirs, Clauses))).
314
315create_object(Obj, Rels, Dirs, Clauses) :-
316    '$lgt_current_protocol_'(Obj, _, _),
317    throw(error(permission_error(replace, protocol, Obj), create_object(Obj, Rels, Dirs, Clauses))).
318
319create_object(Obj, Rels, Dirs, Clauses) :-
320    (var(Rels); \+ '$lgt_proper_list'(Rels)),
321    throw(error(type_error(list, Rels), create_object(Obj, Rels, Dirs, Clauses))).
322
323create_object(Obj, Rels, Dirs, Clauses) :-
324    (var(Dirs); \+ '$lgt_proper_list'(Dirs)),
325    throw(error(type_error(list, Dirs), create_object(Obj, Rels, Dirs, Clauses))).
326
327create_object(Obj, Rels, Dirs, Clauses) :-
328    (var(Clauses); \+ '$lgt_proper_list'(Clauses)),
329    throw(error(type_error(list, Clauses), create_object(Obj, Rels, Dirs, Clauses))).
330
331create_object(Obj, Rels, Dirs, Clauses) :-
332    '$lgt_clean_pp_clauses',
333    '$lgt_tr_directive'(object, [Obj| Rels]),
334    '$lgt_tr_directives'([(dynamic)| Dirs]),
335    '$lgt_tr_clauses'(Clauses),
336    '$lgt_fix_redef_built_ins',
337    '$lgt_gen_object_clauses',
338    '$lgt_gen_object_directives',
339    '$lgt_assert_tr_entity',
340    '$lgt_report_unknown_entities',
341    '$lgt_clean_pp_clauses'.
342
343
344
345% create_category(+category_identifier, +list, +list, +list)
346
347create_category(Ctg, Rels, Dirs, Clauses) :-
348    var(Ctg),
349    throw(error(instantiation_error, create_category(Ctg, Rels, Dirs, Clauses))).
350
351create_category(Ctg, Rels, Dirs, Clauses) :-
352    \+ atom(Ctg),
353    throw(error(type_error(category_identifier, Ctg), create_category(Ctg, Rels, Dirs, Clauses))).
354
355create_category(Ctg, Rels, Dirs, Clauses) :-
356    '$lgt_current_category_'(Ctg, _, _),
357    throw(error(permission_error(replace, category, Ctg), create_category(Ctg, Rels, Dirs, Clauses))).
358
359create_category(Ctg, Rels, Dirs, Clauses) :-
360    '$lgt_current_object_'(Ctg, _, _, _, _, _),
361    throw(error(permission_error(replace, object, Ctg), create_category(Ctg, Rels, Dirs, Clauses))).
362
363create_category(Ctg, Rels, Dirs, Clauses) :-
364    '$lgt_current_protocol_'(Ctg, _, _),
365    throw(error(permission_error(replace, protocol, Ctg), create_category(Ctg, Rels, Dirs, Clauses))).
366
367create_category(Ctg, Rels, Dirs, Clauses) :-
368    (var(Rels); \+ '$lgt_proper_list'(Rels)),
369    throw(error(type_error(list, Rels), create_category(Ctg, Rels, Dirs, Clauses))).
370
371create_category(Ctg, Rels, Dirs, Clauses) :-
372    (var(Dirs); \+ '$lgt_proper_list'(Dirs)),
373    throw(error(type_error(list, Dirs), create_category(Ctg, Rels, Dirs, Clauses))).
374
375create_category(Ctg, Rels, Dirs, Clauses) :-
376    (var(Clauses); \+ '$lgt_proper_list'(Clauses)),
377    throw(error(type_error(list, Clauses), create_category(Ctg, Rels, Dirs, Clauses))).
378
379create_category(Ctg, Rels, Dirs, Clauses) :-
380    '$lgt_clean_pp_clauses',
381    '$lgt_tr_directive'(category, [Ctg| Rels]),
382    '$lgt_tr_directives'([(dynamic)| Dirs]),
383    '$lgt_tr_clauses'(Clauses),
384    '$lgt_fix_redef_built_ins',
385    '$lgt_gen_category_clauses',
386    '$lgt_gen_category_directives',
387    '$lgt_assert_tr_entity',
388    '$lgt_report_unknown_entities',
389    '$lgt_clean_pp_clauses'.
390
391
392
393% create_protocol(+protocol_identifier, +list, +list)
394
395create_protocol(Ptc, Rels, Dirs) :-
396    var(Ptc),
397    throw(error(instantiation_error, create_protocol(Ptc, Rels, Dirs))).
398
399create_protocol(Ptc, Rels, Dirs) :-
400    \+ atom(Ptc),
401    throw(error(type_error(protocol_identifier, Ptc), create_protocol(Ptc, Rels, Dirs))).
402
403create_protocol(Ptc, Rels, Dirs) :-
404    '$lgt_current_protocol_'(Ptc, _, _),
405    throw(error(permission_error(replace, protocol, Ptc), create_protocol(Ptc, Rels, Dirs))).
406
407create_protocol(Ptc, Rels, Dirs) :-
408    '$lgt_current_object_'(Ptc, _, _, _, _, _),
409    throw(error(permission_error(replace, object, Ptc), create_protocol(Ptc, Rels, Dirs))).
410
411create_protocol(Ptc, Rels, Dirs) :-
412    '$lgt_current_category_'(Ptc, _, _),
413    throw(error(permission_error(replace, category, Ptc), create_protocol(Ptc, Rels, Dirs))).
414
415create_protocol(Ptc, Rels, Dirs) :-
416    (var(Rels); \+ '$lgt_proper_list'(Rels)),
417    throw(error(type_error(list, Rels), create_protocol(Ptc, Rels, Dirs))).
418
419create_protocol(Ptc, Rels, Dirs) :-
420    (var(Dirs); \+ '$lgt_proper_list'(Dirs)),
421    throw(error(type_error(list, Dirs), create_protocol(Ptc, Rels, Dirs))).
422
423create_protocol(Ptc, Rels, Dirs) :-
424    '$lgt_clean_pp_clauses',
425    '$lgt_tr_directive'(protocol, [Ptc| Rels]),
426    '$lgt_tr_directives'([(dynamic)| Dirs]),
427    '$lgt_gen_protocol_clauses',
428    '$lgt_gen_protocol_directives',
429    '$lgt_assert_tr_entity',
430    '$lgt_report_unknown_entities',
431    '$lgt_clean_pp_clauses'.
432
433
434
435% abolish_object(@object_identifier)
436
437abolish_object(Obj) :-
438    var(Obj),
439    throw(error(instantiation_error, abolish_object(Obj))).
440
441abolish_object(Obj) :-
442    \+ callable(Obj),
443    throw(error(type_error(object_identifier, Obj), abolish_object(Obj))).
444
445abolish_object(Obj) :-
446    '$lgt_current_object_'(Obj, Prefix, _, _, _, Type) ->
447        (Type = (dynamic) ->
448            '$lgt_call'(Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef),
449            forall(
450                '$lgt_call'(Def, _, _, _, _, Pred),
451                (functor(Pred, Functor, Arity), abolish(Functor/Arity))),
452            forall(
453                '$lgt_call'(DDef, _, _, _, _, Pred),
454                (functor(Pred, Functor, Arity), abolish(Functor/Arity))),
455            abolish(Dcl/4),
456            abolish(Dcl/6),
457            abolish(Def/5),
458            abolish(Def/6),
459            abolish(Super/6),
460            abolish(IDcl/6),
461            abolish(IDef/6),
462            abolish(DDcl/2),
463            abolish(DDef/5),
464            abolish(Prefix/7),
465            retractall('$lgt_current_object_'(Obj, _, _, _, _, _)),
466            retractall('$lgt_extends_object_'(Obj, _, _)),
467            retractall('$lgt_instantiates_class_'(Obj, _, _)),
468            retractall('$lgt_specializes_class_'(Obj, _, _)),
469            retractall('$lgt_implements_protocol_'(Obj, _, _)),
470            retractall('$lgt_imports_category_'(Obj, _, _)),
471            retractall('$lgt_debugging_'(Obj)),
472            '$lgt_clean_lookup_caches'
473            ;
474            throw(error(permission_error(modify, static_object, Obj), abolish_object(Obj))))
475        ;
476        throw(error(existence_error(object, Obj), abolish_object(Obj))).
477
478
479
480% abolish_category(@category_identifier)
481
482abolish_category(Ctg) :-
483    var(Ctg),
484    throw(error(instantiation_error, abolish_category(Ctg))).
485
486abolish_category(Ctg) :-
487    \+ atom(Ctg),
488    throw(error(type_error(category_identifier, Ctg), abolish_category(Ctg))).
489
490abolish_category(Ctg) :-
491    '$lgt_current_category_'(Ctg, Prefix, Type) ->
492        (Type = (dynamic) ->
493            '$lgt_call'(Prefix, Dcl, Def),
494            forall(
495                '$lgt_call'(Def, _, _, _, _, Pred),
496                (functor(Pred, Functor, Arity), abolish(Functor/Arity))),
497            abolish(Dcl/4),
498            abolish(Dcl/5),
499            abolish(Def/5),
500            abolish(Prefix/2),
501            retractall('$lgt_current_category_'(Ctg, _, _)),
502            retractall('$lgt_implements_protocol_'(Ctg, _, _)),
503            '$lgt_clean_lookup_caches'
504            ;
505            throw(error(permission_error(modify, static_category, Ctg), abolish_category(Ctg))))
506        ;
507        throw(error(existence_error(category, Ctg), abolish_category(Ctg))).
508
509
510
511% abolish_protocol(@protocol_identifier)
512
513abolish_protocol(Ptc) :-
514    var(Ptc),
515    throw(error(instantiation_error, abolish_protocol(Ptc))).
516
517abolish_protocol(Ptc) :-
518    \+ atom(Ptc),
519    throw(error(type_error(protocol_identifier, Ptc), abolish_protocol(Ptc))).
520
521abolish_protocol(Ptc) :-
522    '$lgt_current_protocol_'(Ptc, Prefix, Type) ->
523        (Type = (dynamic) ->
524            '$lgt_call'(Prefix, Dcl),
525            abolish(Dcl/4),
526            abolish(Dcl/5),
527            abolish(Prefix/1),
528            retractall('$lgt_current_protocol_'(Ptc, _, _)),
529            retractall('$lgt_extends_protocol_'(Ptc, _, _)),
530            '$lgt_clean_lookup_caches'
531            ;
532            throw(error(permission_error(modify, static_protocol, Ptc), abolish_protocol(Ptc))))
533        ;
534        throw(error(existence_error(protocol, Ptc), abolish_protocol(Ptc))).
535
536
537
538% implements_protocol(?object_identifier, ?protocol_identifier)
539% implements_protocol(?category_identifier, ?protocol_identifier)
540
541implements_protocol(ObjOrCtg, Ptc) :-
542    catch(
543        implements_protocol(ObjOrCtg, Ptc, _),
544        error(Error, _),
545        throw(error(Error, implements_protocol(ObjOrCtg, Ptc)))).
546
547
548
549% implements_protocol(?object_identifier, ?protocol_identifier, ?atom)
550% implements_protocol(?category_identifier, ?protocol_identifier, ?atom)
551
552implements_protocol(ObjOrCtg, Ptc, Scope) :-
553    nonvar(ObjOrCtg),
554    \+ callable(ObjOrCtg),
555    throw(error(type_error(object_identifier, ObjOrCtg), implements_protocol(ObjOrCtg, Ptc, Scope))).
556
557implements_protocol(ObjOrCtg, Ptc, Scope) :-
558    nonvar(Ptc),
559    \+ atom(Ptc),
560    throw(error(type_error(protocol_identifier, Ptc), implements_protocol(ObjOrCtg, Ptc, Scope))).
561
562implements_protocol(ObjOrCtg, Ptc, Scope) :-
563    nonvar(Scope),
564    \+ '$lgt_member'(Scope, [(public), protected, private]),
565    throw(error(type_error(scope, Scope), implements_protocol(ObjOrCtg, Ptc, Scope))).
566
567implements_protocol(ObjOrCtg, Ptc, Scope) :-
568    '$lgt_implements_protocol_'(ObjOrCtg, Ptc, Scope).
569
570
571
572% imports_category(?object_identifier, ?category_identifier)
573% imports_category(?category_identifier, ?category_identifier)
574
575imports_category(ObjOrCtg, Ctg) :-
576    catch(
577        imports_category(ObjOrCtg, Ctg, _),
578        error(Error, _),
579        throw(error(Error, imports_category(ObjOrCtg, Ctg)))).
580
581
582
583% imports_category(?object_identifier, ?category_identifier, ?atom)
584% imports_category(?category_identifier, ?category_identifier, ?atom)
585
586imports_category(ObjOrCtg, Ctg, Scope) :-
587    nonvar(ObjOrCtg),
588    \+ callable(ObjOrCtg),
589    throw(error(type_error(object_identifier, ObjOrCtg), imports_category(ObjOrCtg, Ctg, Scope))).
590
591imports_category(ObjOrCtg, Ctg, Scope) :-
592    nonvar(Ctg),
593    \+ atom(Ctg),
594    throw(error(type_error(category_identifier, Ctg), imports_category(ObjOrCtg, Ctg, Scope))).
595
596imports_category(ObjOrCtg, Ctg, Scope) :-
597    nonvar(Scope),
598    \+ '$lgt_member'(Scope, [(public), protected, private]),
599    throw(error(type_error(scope, Scope), imports_category(ObjOrCtg, Ctg, Scope))).
600
601imports_category(ObjOrCtg, Ctg, Scope) :-
602    '$lgt_imports_category_'(ObjOrCtg, Ctg, Scope).
603
604
605
606% instantiates_class(?object_identifier, ?object_identifier)
607
608instantiates_class(Obj, Class) :-
609    catch(
610        instantiates_class(Obj, Class, _),
611        error(Error, _),
612        throw(error(Error, instantiates_class(Obj, Class)))).
613
614
615
616% instantiates_class(?object_identifier, ?object_identifier, ?atom)
617
618instantiates_class(Obj, Class, Scope) :-
619    nonvar(Obj),
620    \+ callable(Obj),
621    throw(error(type_error(object_identifier, Obj), instantiates_class(Obj, Class, Scope))).
622
623instantiates_class(Obj, Class, Scope) :-
624    nonvar(Class),
625    \+ callable(Class),
626    throw(error(type_error(object_identifier, Class), instantiates_class(Obj, Class, Scope))).
627
628instantiates_class(Obj, Class, Scope) :-
629    nonvar(Scope),
630    \+ '$lgt_member'(Scope, [(public), protected, private]),
631    throw(error(type_error(scope, Scope), instantiates_class(Obj, Class, Scope))).
632
633instantiates_class(Obj, Class, Scope) :-
634    '$lgt_instantiates_class_'(Obj, Class, Scope).
635
636
637
638% specializes_class(?object_identifier, ?object_identifier)
639
640specializes_class(Class, Superclass) :-
641    catch(
642        specializes_class(Class, Superclass, _),
643        error(Error, _),
644        throw(error(Error, specializes_class(Class, Superclass)))).
645
646
647
648% specializes_class(?object_identifier, ?object_identifier, ?atom)
649
650specializes_class(Class, Superclass, Scope) :-
651    nonvar(Class),
652    \+ callable(Class),
653    throw(error(type_error(object_identifier, Class), specializes_class(Class, Superclass, Scope))).
654
655specializes_class(Class, Superclass, Scope) :-
656    nonvar(Superclass),
657    \+ callable(Superclass),
658    throw(error(type_error(object_identifier, Superclass), specializes_class(Class, Superclass, Scope))).
659
660specializes_class(Class, Superclass, Scope) :-
661    nonvar(Scope),
662    \+ '$lgt_member'(Scope, [(public), protected, private]),
663    throw(error(type_error(scope, Scope), specializes_class(Class, Superclass, Scope))).
664
665specializes_class(Class, Superclass, Scope) :-
666    '$lgt_specializes_class_'(Class, Superclass, Scope).
667
668
669
670% extends_protocol(?protocol_identifier, ?protocol_identifier)
671
672extends_protocol(Ptc1, Ptc2) :-
673    catch(
674        extends_protocol(Ptc1, Ptc2, _),
675        error(Error, _),
676        throw(error(Error, extends_protocol(Ptc1, Ptc2)))).
677
678
679
680% extends_protocol(?protocol_identifier, ?protocol_identifier, ?atom)
681
682extends_protocol(Ptc1, Ptc2, Scope) :-
683    nonvar(Ptc1),
684    \+ atom(Ptc1),
685    throw(error(type_error(protocol_identifier, Ptc1), extends_protocol(Ptc1, Ptc2, Scope))).
686
687extends_protocol(Ptc1, Ptc2, Scope) :-
688    nonvar(Ptc2),
689    \+ atom(Ptc2),
690    throw(error(type_error(protocol_identifier, Ptc2), extends_protocol(Ptc1, Ptc2, Scope))).
691
692extends_protocol(Ptc1, Ptc2, Scope) :-
693    nonvar(Scope),
694    \+ '$lgt_member'(Scope, [(public), protected, private]),
695    throw(error(type_error(scope, Scope), extends_protocol(Ptc1, Ptc2, Scope))).
696
697extends_protocol(Ptc1, Ptc2, Scope) :-
698    '$lgt_extends_protocol_'(Ptc1, Ptc2, Scope).
699
700
701
702% extends_object(?object_identifier, ?object_identifier)
703
704extends_object(Prototype, Parent) :-
705    catch(
706        extends_object(Prototype, Parent, _),
707        error(Error, _),
708        throw(error(Error, extends_object(Prototype, Parent)))).
709
710
711
712% extends_object(?object_identifier, ?object_identifier, ?atom)
713
714extends_object(Prototype, Parent, Scope) :-
715    nonvar(Prototype),
716    \+ callable(Prototype),
717    throw(error(type_error(object_identifier, Prototype), extends_object(Prototype, Parent, Scope))).
718
719extends_object(Prototype, Parent, Scope) :-
720    nonvar(Parent),
721    \+ callable(Parent),
722    throw(error(type_error(object_identifier, Parent), extends_object(Prototype, Parent, Scope))).
723
724extends_object(Prototype, Parent, Scope) :-
725    nonvar(Scope),
726    \+ '$lgt_member'(Scope, [(public), protected, private]),
727    throw(error(type_error(scope, Scope), extends_object(Prototype, Parent, Scope))).
728
729extends_object(Prototype, Parent, Scope) :-
730    '$lgt_extends_object_'(Prototype, Parent, Scope).
731
732
733