Changeset 4554 for trunk/compiler

Timestamp:

10/31/08 14:39:41 (2 months ago)

Author:

pmoura

Message:

Added an auxiliary predicate for reversing the entity prefix used in the compiled code, returning the entity identifier. This predicate is used in error handling.

Files:

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

trunk/compiler/logtalk.pl

@@ -343 +343 @@
 
 '$lgt_runtime_error_handler'(error(existence_error(procedure, TFunctor/8), _)) :-
-    once((  atom_concat(ObjArity, '__idcl', TFunctor)
-        ;   atom_concat(ObjArity, '__dcl', TFunctor)
+    once((  atom_concat(Prefix, '_idcl', TFunctor)
+        ;   atom_concat(Prefix, '_dcl', TFunctor)
     )),
-    atom_chars(ObjArity, ObjArityChars),
-    '$lgt_append'(FunctorChars, ['_', ArityChar| ArityChars], ObjArityChars),
-    catch(number_chars(Arity, [ArityChar| ArityChars]), _, fail),
-    atom_chars(Functor, FunctorChars),
-    functor(Obj, Functor, Arity),
+    '$lgt_reverse_entity_prefix'(Prefix, Obj),
     (   '$lgt_instantiates_class_'(_, Obj, _)
     ;   '$lgt_specializes_class_'(_, Obj, _)
     ;   '$lgt_extends_object_'(_, Obj, _)
+    ;   '$lgt_complemented_object_'(Obj, _, _, _, _)
     ),
     \+ '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _),
@@ -359 +356 @@
 
 '$lgt_runtime_error_handler'(error(existence_error(procedure, TFunctor/7), _)) :-
-    atom_concat(CtgOrPtc, '_0__dcl', TFunctor),
+    atom_concat(Prefix, '_dcl', TFunctor),
+    '$lgt_reverse_entity_prefix'(Prefix, CtgOrPtc),
     (   '$lgt_implements_protocol_'(_, CtgOrPtc, _), \+ '$lgt_current_protocol_'(CtgOrPtc, _, _, _, _) ->
         throw(error(existence_error(protocol, CtgOrPtc), _, _))
@@ -11201 +11199 @@
 
 
+% '$lgt_reverse_entity_prefix'(+atom, -entity_identifier)
+%
+% reverses the entity prefix used in the compiled code
+
+'$lgt_reverse_entity_prefix'(Prefix, Entity) :-
+    '$lgt_compiler_flag'(code_prefix, CodePrefix),
+    atom_concat(CodePrefix, NameUnderscoreArityUnderscore, Prefix),
+    atom_concat(NameUnderscoreArity, '_', NameUnderscoreArityUnderscore),
+    '$lgt_split_name_arity'(NameUnderscoreArity, Name, Arity),
+    functor(Entity, Name, Arity),
+    !.
+
+
+'$lgt_split_name_arity'(NameUnderscoreArity, Name, Arity) :-
+    atom_codes(NameUnderscoreArity, Codes),
+    '$lgt_reverse'(Codes, [], RCodes),
+    '$lgt_find_arity_codes'(RCodes, [], ArityCodes),
+    number_codes(Arity, ArityCodes),
+    atom_codes(ArityAtom, ArityCodes),
+    atom_concat(NameUnderscore, ArityAtom, NameUnderscoreArity),
+    atom_concat(Name, '_', NameUnderscore).
+
+
+'$lgt_find_arity_codes'([Code| Codes], Acc, ArityCodes) :-
+    (   char_code('_', Code) ->
+        ArityCodes = Acc
+    ;   '$lgt_find_arity_codes'(Codes, [Code| Acc], ArityCodes)
+    ).
+
+
+'$lgt_reverse'([], Reversed, Reversed).
+'$lgt_reverse'([Head| Tail], List, Reversed) :-
+    '$lgt_reverse'(Tail, [Head| List], Reversed).
+
+
+
 % '$lgt_construct_predicate_indicator'(+atom, +predicate_indicator, -predicate_indicator)
 %