Changeset 4526 for trunk/compiler

Timestamp:

10/21/08 09:08:54 (3 months ago)

Author:

pmoura

Message:

Allow a complementing category to define an alias for a predicate of the complemented object.

Files:

• trunk/compiler/logtalk.pl (modified) (17 diffs)

trunk/compiler/logtalk.pl

@@ -100 +100 @@
 :- dynamic('$lgt_extends_protocol_'/3).
                                                 
-:- multifile('$lgt_complemented_object_'/4).    % '$lgt_complemented_object_'(Obj, Ctg, Dcl, Def)
-:- dynamic('$lgt_complemented_object_'/4).
+:- multifile('$lgt_complemented_object_'/5).    % '$lgt_complemented_object_'(Obj, Ctg, Dcl, Def, Rnm)
+:- dynamic('$lgt_complemented_object_'/5).
 
 
@@ -216 +216 @@
 :- dynamic('$lgt_pp_extended_protocol_'/4).     % '$lgt_pp_extended_protocol_'(Ptc, Prefix, Dcl, Scope)
 :- dynamic('$lgt_pp_extended_category_'/5).     % '$lgt_pp_extended_category_'(Ctg, Prefix, Dcl, Def, Scope)
+:- dynamic('$lgt_pp_complemented_object_'/1).   % '$lgt_pp_complemented_object_'(Obj)
 
 :- dynamic('$lgt_pp_file_init_'/1).             % '$lgt_pp_file_init_'(Goal)    
@@ -1078 +1079 @@
 
 complements_object(Category, Object) :-
-    '$lgt_complemented_object_'(Object, Category, _, _).
+    '$lgt_complemented_object_'(Object, Category, _, _, _).
 
 
@@ -2408 +2409 @@
             % object doesn't supports dynamic declaration of new predicates:
             throw(error(permission_error(modify, object_protocol, Pred), Goal, Sender))
-        ;   '$lgt_assert_ddcl_clause'(DDcl, Pred, DclScope),
+        ;   functor(Pred, Functor, Arity),
+            functor(DPred, Functor, Arity),
+            Clause =.. [DDcl, DPred, DclScope],
+            assertz(Clause),
             (Scope, Type, Meta) = (DclScope, (dynamic), no)
         )
@@ -3327 +3331 @@
 % lookup predicate declarations in any category that complements the given object
 
-'$lgt_complemented_object'(This, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn) :-
-    '$lgt_complemented_object_'(This, _, Dcl, _),
-    call_with_args(Dcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn).
+'$lgt_complemented_object'(This, ThisDcl, Alias, Scope, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn) :-
+    '$lgt_complemented_object_'(This, _, Dcl, _, Rnm),
+    (   call_with_args(Dcl, Alias, Scope, Compilation, Meta, NonTerminal, Synchronized, TCtn),
+        SCtn = This
+    ;   call_with_args(Rnm, This, Pred, Alias),
+        Pred \= Alias,
+        call_with_args(ThisDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn)
+    ).
 
 
@@ -3335 +3344 @@
 % lookup predicate definitions in any category that complements the given object
 
-'$lgt_complemented_object'(Pred, Sender, This, Self, Call, Ctn) :-
-    '$lgt_complemented_object_'(This, _, _, Def),
-    call_with_args(Def, Pred, Sender, This, Self, Call, Ctn).
+'$lgt_complemented_object'(ThisDef, Alias, Sender, This, Self, Call, Ctn) :-
+    '$lgt_complemented_object_'(This, _, _, Def, Rnm),
+    (   call_with_args(Def, Alias, Sender, This, Self, Call, Ctn)
+    ;   call_with_args(Rnm, This, Pred, Alias),
+        Pred \= Alias,
+        call_with_args(ThisDef, Pred, Sender, This, Self, Call, Ctn)
+    ).  
 
 
@@ -4281 +4294 @@
     retractall('$lgt_extends_object_'(Entity, _, _)),
     retractall('$lgt_extends_category_'(Entity, _, _)),
-    retractall('$lgt_complemented_object_'(_, Entity, _, _)),
+    retractall('$lgt_complemented_object_'(_, Entity, _, _, _)),
     retractall('$lgt_debugging_'(Entity)).
 
@@ -4957 +4970 @@
     retractall('$lgt_pp_extended_protocol_'(_, _, _, _)),
     retractall('$lgt_pp_extended_category_'(_, _, _, _, _)),
+    retractall('$lgt_pp_complemented_object_'(_)),
     retractall('$lgt_pp_uses_'(_)),
     retractall('$lgt_pp_uses_'(_, _, _)),
@@ -5732 +5746 @@
     ;   '$lgt_pp_instantiated_class_'(Entity, _, _, _, _, _, _, _, _, _)
     ;   '$lgt_pp_specialized_class_'(Entity, _, _, _, _, _, _, _, _, _)
+    ;   '$lgt_pp_complemented_object_'(Entity)
     ),
     !,
@@ -9057 +9072 @@
 
 '$lgt_tr_complements_category'(Objs, Ctg) :-
-    '$lgt_pp_category_'(Ctg, _, Dcl, Def, _, _) ->
-    '$lgt_tr_complements_category'(Objs, Ctg, Dcl, Def).
-
-
-'$lgt_tr_complements_category'([], _, _, _).
-
-'$lgt_tr_complements_category'([Obj| _], _, _, _) :-
+    '$lgt_pp_category_'(Ctg, _, Dcl, Def, Rnm, _) ->
+    '$lgt_tr_complements_category'(Objs, Ctg, Dcl, Def, Rnm).
+
+
+'$lgt_tr_complements_category'([], _, _, _, _).
+
+'$lgt_tr_complements_category'([Obj| _], _, _, _, _) :-
     var(Obj),
     throw(instantiation_error).
 
-'$lgt_tr_complements_category'([Obj| Objs], Ctg, Dcl, Def) :-
+'$lgt_tr_complements_category'([Obj| Objs], Ctg, Dcl, Def, Rnm) :-
     (   callable(Obj) ->
         assertz('$lgt_pp_referenced_object_'(Obj)),
-        assertz('$lgt_pp_rclause_'('$lgt_complemented_object_'(Obj, Ctg, Dcl, Def))),
-        '$lgt_tr_complements_category'(Objs, Ctg, Dcl, Def)
+        assertz('$lgt_pp_complemented_object_'(Obj)),
+        assertz('$lgt_pp_rclause_'('$lgt_complemented_object_'(Obj, Ctg, Dcl, Def, Rnm))),
+        '$lgt_tr_complements_category'(Objs, Ctg, Dcl, Def, Rnm)
     ;   throw(type_error(object_identifier, Obj))
     ).
@@ -9339 +9355 @@
         '$lgt_clean_lookup_caches'(Head)
     ).
-
-
-
-% '$lgt_assert_ddcl_clause'(+atom, +term, +term)
-%
-% asserts a dynamic predicate declaration
-
-'$lgt_assert_ddcl_clause'(DDcl, Pred, Scope) :-
-    functor(Pred, Functor, Arity),
-    functor(DPred, Functor, Arity),
-    Clause =.. [DDcl, DPred, Scope],
-    assertz(Clause).
 
 
@@ -9860 +9864 @@
     (   '$lgt_compiler_flag'(complements, on) ->
         '$lgt_pp_object_'(Obj, _, ODcl, _, _, _, _, _, _, _, _) ->
-        Head =.. [ODcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Obj, Ctn],
-        Lookup = '$lgt_complemented_object'(Obj, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn),
+        Head =.. [ODcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn],
+        Lookup = '$lgt_complemented_object'(Obj, ODcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn),
         assertz('$lgt_pp_dcl_'((Head:-Lookup)))
     ;   true
@@ -9939 +9943 @@
         '$lgt_pp_object_'(Obj, _, _, ODef, _, _, _, _, _, _, _) ->
         Head =.. [ODef, Pred, Sender, Obj, Self, Call, Ctn],
-        Lookup = '$lgt_complemented_object'(Pred, Sender, Obj, Self, Call, Ctn),
+        Lookup = '$lgt_complemented_object'(ODef, Pred, Sender, Obj, Self, Call, Ctn),
         assertz('$lgt_pp_fdef_'((Head:-Lookup)))
     ;   true
@@ -10121 +10125 @@
     (   '$lgt_compiler_flag'(complements, on) ->
         '$lgt_pp_object_'(Obj, _, _, _, _, OIDcl, _, _, _, _, _) ->
-        Head =.. [OIDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Obj, Ctn],
-        Lookup = '$lgt_complemented_object'(Obj, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn),
+        Head =.. [OIDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn],
+        Lookup = '$lgt_complemented_object'(Obj, OIDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn),
         assertz('$lgt_pp_dcl_'((Head:-Lookup)))
     ;   true
@@ -10201 +10205 @@
         '$lgt_pp_object_'(Obj, _, _, ODef, _, _, _, _, _, _, _) ->
         Head =.. [ODef, Pred, Sender, Obj, Self, Call, Ctn],
-        Lookup = '$lgt_complemented_object'(Pred, Sender, Obj, Self, Call, Ctn),
+        Lookup = '$lgt_complemented_object'(ODef, Pred, Sender, Obj, Self, Call, Ctn),
         assertz('$lgt_pp_fdef_'((Head:-Lookup)))
     ;   true
@@ -10267 +10271 @@
         '$lgt_pp_object_'(Obj, _, _, _, _, _, OIDef, _, _, _, _) ->
         Head =.. [OIDef, Pred, Sender, Obj, Self, Call, Ctn],
-        Lookup = '$lgt_complemented_object'(Pred, Sender, Obj, Self, Call, Ctn),
+        Lookup = '$lgt_complemented_object'(OIDef, Pred, Sender, Obj, Self, Call, Ctn),
         assertz('$lgt_pp_fdef_'((Head:-Lookup)))
     ;   true
@@ -10831 +10835 @@
         '$lgt_write_runtime_clauses'(Stream, '$lgt_extends_object_'/3),
         '$lgt_write_runtime_clauses'(Stream, '$lgt_extends_protocol_'/3),
-        '$lgt_write_runtime_clauses'(Stream, '$lgt_complemented_object_'/4),
+        '$lgt_write_runtime_clauses'(Stream, '$lgt_complemented_object_'/5),
         '$lgt_write_runtime_clauses'(Stream, '$lgt_debugging_'/1)
     ;   true