Changeset 4480 for trunk/compiler/logtalk.pl

Timestamp:

10/04/08 08:30:04 (3 months ago)

Author:

pmoura

Message:

Improved the Logtalk built-in debugger to print clause numbers for static predicates at the unification ports ("fact" and "rule").

Files:

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

trunk/compiler/logtalk.pl

@@ -2184 +2184 @@
             (   '$lgt_debugging_'(Obj) ->
                 '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx),
-                asserta((THead :- ('$lgt_nop'(Body), '$lgt_dbg_head'(Head, DbgCtx), DBody)))
+                asserta((THead :- ('$lgt_nop'(Body), '$lgt_dbg_head'(Head, 0, DbgCtx), DBody)))
             ;   asserta((THead :- ('$lgt_nop'(Body), TBody)))
             )
@@ -2216 +2216 @@
                 '$lgt_ctx_ctx'(Ctx, _, GSender, GThis, GSelf, Prefix, [], _),
                 '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx),
-                asserta((THead :- '$lgt_dbg_fact'(Head, DbgCtx)))
+                asserta((THead :- '$lgt_dbg_fact'(Head, 0, DbgCtx)))
             ;   '$lgt_add_db_lookup_cache_entry'(Obj, Head, SCtn, DclScope, Sender, THead, DDef, Update),
                 asserta(THead)
@@ -2286 +2286 @@
             (   '$lgt_debugging_'(Obj) ->
                 '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx),
-                assertz((THead :- ('$lgt_nop'(Body), '$lgt_dbg_head'(Head, DbgCtx), DBody)))
+                assertz((THead :- ('$lgt_nop'(Body), '$lgt_dbg_head'(Head, 0, DbgCtx), DBody)))
             ;   assertz((THead :- ('$lgt_nop'(Body), TBody)))
             )
@@ -2318 +2318 @@
                 '$lgt_ctx_ctx'(Ctx, _, GSender, GThis, GSelf, Prefix, [], _),
                 '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx),
-                assertz((THead :- '$lgt_dbg_fact'(Head, DbgCtx)))
+                assertz((THead :- '$lgt_dbg_fact'(Head, 0, DbgCtx)))
             ;   '$lgt_add_db_lookup_cache_entry'(Obj, Head, SCtn, DclScope, Sender, THead, DDef, Update),
                 assertz(THead)
@@ -2401 +2401 @@
     (   TBody = ('$lgt_nop'(Body), _) ->    % rules (compiled both in normal and debug mode)
         true
-    ;   TBody = '$lgt_dbg_fact'(_, _) ->    % facts compiled in debug mode
+    ;   TBody = '$lgt_dbg_fact'(_, _, _) -> % facts compiled in debug mode
         Body = true
     ;   TBody = Body                        % facts compiled in normal mode
@@ -2416 +2416 @@
                     (   TBody = ('$lgt_nop'(Body), _) ->
                         true
-                    ;   TBody = '$lgt_dbg_fact'(_, _) ->
+                    ;   TBody = '$lgt_dbg_fact'(_, _, _) ->
                         Body = true
                     ;   TBody = Body
@@ -2435 +2435 @@
             (   TBody = ('$lgt_nop'(Body), _) ->
                 true
-            ;   TBody = '$lgt_dbg_fact'(_, _) ->
+            ;   TBody = '$lgt_dbg_fact'(_, _, _) ->
                 Body = true
             ;   TBody = Body
@@ -2489 +2489 @@
                     (   TBody = ('$lgt_nop'(Body), _) ->
                         true
-                    ;   TBody = '$lgt_dbg_fact'(_, _) ->
+                    ;   TBody = '$lgt_dbg_fact'(_, _, _) ->
                         Body = true
                     ;   TBody = Body
@@ -2498 +2498 @@
                     (   TBody = ('$lgt_nop'(Body), _) ->
                         true
-                    ;   TBody = '$lgt_dbg_fact'(_, _) ->
+                    ;   TBody = '$lgt_dbg_fact'(_, _, _) ->
                         Body = true
                     ;   TBody = Body
@@ -2518 +2518 @@
             (   TBody = ('$lgt_nop'(Body), _) ->
                 true
-            ;   TBody = '$lgt_dbg_fact'(_, _) ->
+            ;   TBody = '$lgt_dbg_fact'(_, _, _) ->
                 Body = true
             ;   TBody = Body
@@ -2577 +2577 @@
                 (   call_with_args(DDef, Head, _, _, _, Call) ->
                     (   '$lgt_debugging_'(Obj) ->
-                        retract((Call :- '$lgt_dbg_fact'(_, _)))
+                        retract((Call :- '$lgt_dbg_fact'(_, _, _)))
                     ;   '$lgt_add_db_lookup_cache_entry'(Obj, Head, SCtn, PScope, Sender, Call, DDef, true),
                         retract(Call)
@@ -2584 +2584 @@
                 ;   call_with_args(Def, Head, _, _, _, Call) ->
                     (   '$lgt_debugging_'(Obj) ->
-                        retract((Call :- '$lgt_dbg_fact'(_, _)))
+                        retract((Call :- '$lgt_dbg_fact'(_, _, _)))
                     ;   '$lgt_add_db_lookup_cache_entry'(Obj, Head, PScope, Sender, Call),
                         retract(Call)
@@ -2601 +2601 @@
         (   call_with_args(DDef, Head, _, _, _, Call) ->
             (   '$lgt_debugging_'(Obj) ->
-                retract((Call :- '$lgt_dbg_fact'(_, _)))
+                retract((Call :- '$lgt_dbg_fact'(_, _, _)))
             ;   '$lgt_add_db_lookup_cache_entry'(Obj, Head, p, Sender, Call),
                 retract(Call)
@@ -3774 +3774 @@
 
 
-'$lgt_dbg_fact'(Fact, DbgCtx) :-
+'$lgt_dbg_fact'(Fact, N, DbgCtx) :-
     (   '$lgt_dbg_debugging_', \+ '$lgt_dbg_skipping_' ->
-        '$lgt_dbg_port'(fact, Fact, _, DbgCtx, Action),
+        '$lgt_dbg_port'(fact(N), Fact, _, DbgCtx, Action),
         call(Action)
     ;   true
@@ -3782 +3782 @@
 
 
-'$lgt_dbg_head'(Head, DbgCtx) :-
+'$lgt_dbg_head'(Head, N, DbgCtx) :-
     (   '$lgt_dbg_debugging_', \+ '$lgt_dbg_skipping_' ->
-        '$lgt_dbg_port'(rule, Head, _, DbgCtx, Action),
+        '$lgt_dbg_port'(rule(N), Head, _, DbgCtx, Action),
         call(Action)
     ;   true
@@ -3843 +3843 @@
 
 
-'$lgt_dbg_write_port_name'(fact) :-
-    write('   Fact: ').
-'$lgt_dbg_write_port_name'(rule) :-
-    write('   Rule: ').
+'$lgt_dbg_write_port_name'(fact(N)) :-
+    (   N =:= 0 ->
+        write('   Fact: ')
+    ;   write('   Fact('), write(N), write('): ')
+    ).
+'$lgt_dbg_write_port_name'(rule(N)) :-
+    (   N =:= 0 ->
+        write('   Rule: ')
+    ;   write('   Rule('), write(N), write('): ')
+    ).
 '$lgt_dbg_write_port_name'(call) :-
     write('   Call: ').
@@ -6431 +6437 @@
     throw(type_error(callable, Body)).
 
-'$lgt_tr_clause'((Head:-Body), (THead:-'$lgt_nop'(Body), SBody), (THead:-'$lgt_nop'(Body),'$lgt_dbg_head'(Head, DbgCtx),DBody), Ctx, Input) :-
+'$lgt_tr_clause'((Head:-Body), (THead:-'$lgt_nop'(Body), SBody), (THead:-'$lgt_nop'(Body),'$lgt_dbg_head'(Head, 0, DbgCtx),DBody), Ctx, Input) :-
     functor(Head, Functor, Arity),
     '$lgt_pp_dynamic_'(Functor, Arity),
@@ -6442 +6448 @@
     '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx).
 
-'$lgt_tr_clause'((Head:-Body), TClause, (THead:-'$lgt_dbg_head'(Head, DbgCtx),DBody), Ctx, Input) :-
+'$lgt_tr_clause'((Head:-Body), TClause, (THead:-'$lgt_dbg_head'(Head, N, DbgCtx),DBody), Ctx, Input) :-
     !,
     '$lgt_pred_meta_vars'(Head, MetaVars),
@@ -6453 +6459 @@
     ;   TClause = (THead:-SBody)
     ),
-    '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx).
+    '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx),
+    '$lgt_clause_number'(THead, N).
 
 '$lgt_tr_clause'(Fact, _, _, _, _) :-
@@ -6459 +6466 @@
     throw(type_error(callable, Fact)).
 
-'$lgt_tr_clause'(Fact, TFact, (TFact:-'$lgt_dbg_fact'(Fact, DbgCtx)), Ctx, Input) :-
+'$lgt_tr_clause'(Fact, TFact, (TFact:-'$lgt_dbg_fact'(Fact, N, DbgCtx)), Ctx, Input) :-
     '$lgt_tr_head'(Fact, TFact, Ctx, Input),
-    '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx).
+    '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx),
+    '$lgt_clause_number'(TFact, N).
+
+
+'$lgt_clause_number'(THead, N) :-
+    functor(THead, TFunctor, TArity),
+    functor(Template, TFunctor, TArity), 
+    findall(1, ('$lgt_pp_eclause_'(Template); '$lgt_pp_eclause_'((Template :- _))), List),
+    '$lgt_length'(List, 0, Length),
+    N is Length + 1.
+
+'$lgt_length'([], Length, Length).
+'$lgt_length'([_| Tail], Acc, Length) :-
+    Acc2 is Acc + 1,
+    '$lgt_length'(Tail, Acc2, Length).
+