1/*  Part of XPCE --- The SWI-Prolog GUI toolkit
    2
    3    Author:        Jan Wielemaker and Anjo Anjewierden
    4    E-mail:        jan@swi.psy.uva.nl
    5    WWW:           http://www.swi.psy.uva.nl/projects/xpce/
    6    Copyright (c)  1985-2002, University of Amsterdam
    7    All rights reserved.
    8
    9    Redistribution and use in source and binary forms, with or without
   10    modification, are permitted provided that the following conditions
   11    are met:
   12
   13    1. Redistributions of source code must retain the above copyright
   14       notice, this list of conditions and the following disclaimer.
   15
   16    2. Redistributions in binary form must reproduce the above copyright
   17       notice, this list of conditions and the following disclaimer in
   18       the documentation and/or other materials provided with the
   19       distribution.
   20
   21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   32    POSSIBILITY OF SUCH DAMAGE.
   33*/
   34
   35:- module(pce_debug,
   36        [ debugpce/0
   37        , debugpce/1
   38        , nodebugpce/0
   39        , nodebugpce/1
   40        , tracepce/1                    % Trace a pce method
   41        , notracepce/1                  % UnTrace a pce method
   42        , spypce/1                      % Trace a pce method
   43        , nospypce/1                    % UnTrace a pce method
   44        , checkpce/0                    % Check all global pce objects
   45        , show_slots/1                  % Show all pce slot-values
   46        , pcerefer/1                    % Print objects refering to me
   47        , pcerefer/2                    % Print objects refering to me
   48        , pce_global_objects/1          % -globals
   49        ]).   50:- use_module(library(pce)).   51:- require([ forall/2
   52           , pce_to_method/2
   53           , append/3
   54           , between/3
   55           , genarg/3
   56           ]).   57:- set_prolog_flag(generate_debug_info, false).   58:- meta_predicate test(0,-).   59
   60% leave this to the user
   61% :- op(100, xfx, user:(<-)).
   62
   63%   debugpce/0
   64%   nodebugpce/0
   65
   66debugpce :-
   67    send(@pce, debugging, @on).
   68nodebugpce :-
   69    send(@pce, debugging, @off).

 debugpce(+Subject) is det

 nodebugpce(+Subject) is det

Start/stop printing debugging messages on `Subject'. System maintenance usage only.

   78debugpce(Subject) :-
   79    send(@pce, debug_subject, Subject).
   80
   81nodebugpce(Subject) :-
   82    send(@pce, nodebug_subject, Subject).
   83
   84
   85
   86%       (no)tracepce(+ClassName ->|<- +Selector)
   87%
   88%       Send a ->trace message to the refered method.  This will cause
   89%       PCE to  print the enters,  exits or failures  of  this method.
   90%       Prints  the class  and selector   on  which  the tracepoint is
   91%       actually set (which might be an inherited method).
   92
   93tracepce(Spec) :-
   94    method(Spec, Method),
   95    send(Method, trace, full),
   96    trace_feedback('Tracing', Method).
   97
   98notracepce(Spec) :-
   99    !,
  100    method(Spec, Method),
  101    send(Method, trace, full, @off),
  102    trace_feedback('Stopped tracing', Method).
  103
  104%       (no)spypce(+ClassName ->|<- +Selector)
  105%
  106%       Put a spy-point on the Prolog implementation or XPCE method object
  107
  108spypce(Spec) :-
  109    method(Spec, Method),
  110    send(Method, break, full),
  111    (   prolog_method(Method)
  112    ->  debug
  113    ;   true
  114    ),
  115    trace_feedback('Spying', Method).
  116
  117nospypce(Spec) :-
  118    method(Spec, Method),
  119    send(Method, break, full, @off),
  120    trace_feedback('Stopped spying', Method).
  121
  122method(Spec, Method) :-
  123    pce_to_method(Spec, Method),
  124    send(Method, instance_of, behaviour).
  125
  126
  127%       succeed if the method is implemented in Prolog (dubious test).
  128
  129prolog_method(Implementation) :-
  130    send(Implementation, instance_of, method),
  131    get(Implementation, message, Msg),
  132    send(Msg, instance_of, c_pointer).
  133
  134trace_feedback(Action, Obj) :-
  135    (   prolog_method(Obj)
  136    ->  Type = 'Prolog implementation of'
  137    ;   get(Obj?class_name, label_name, Type)
  138    ),
  139    get(Obj?context, name, ClassName),
  140    get(Obj, name, Selector),
  141    get(Obj, access_arrow, Arrow),
  142    format('~w ~w: ~w ~w~w~n', [Action, Type, ClassName, Arrow, Selector]).
  143
  144
  145                /********************************
  146                *       CHECK PCE DATABASE      *
  147                ********************************/

 pce_global_objects(-ChainOfGlobalObjects)

Return a chain with all globally known objects.

  152pce_global_objects(Chain) :-
  153    new(Chain, chain),
  154    send(@pce, for_name_reference,
  155         message(@prolog, '_append_reference', Chain, @arg1)).
  156
  157'_append_reference'(_, Name) :-
  158    non_object_reference(Name),
  159    !.
  160'_append_reference'(Chain, Name) :-
  161    send(Chain, '_append', @Name).
  162
  163non_object_reference('_object_to_itf_table').
  164non_object_reference('_name_to_itf_table').
  165non_object_reference('_handle_to_itf_table').
  166
  167%       checkpce/0
  168%
  169%       Runs a recursive  '_check' on all  reachable objects.  See the
  170%       reference documentation of `Object ->_check' for details.
  171
  172checkpce :-
  173    get(@pce, is_runtime_system, @on),
  174    !,
  175    send(checkpce, error, runtime_version).
  176checkpce :-
  177    test(check_pce_database, Status),
  178    test(check_pce_types, Status),
  179    test(check_classes, Status),
  180    test(check_redefined_methods, Status),
  181    Status = yes.
  182
  183check_classes :-
  184    (   pce_expansion:compiling(_, _)
  185    ->  forall(pce_expansion:compiling(Class, Path),
  186               ( file_base_name(Path, File),
  187                 send(@pce, format,
  188                      '[PCE: WARNING: definition of class \c
  189                          %s in ~s not closed]\n',
  190                      Class, File))),
  191        fail
  192    ;   true
  193    ).
  194
  195check_redefined_methods :-
  196    findall(S, redefined_send_method(S), SL),
  197    maplist(report_redefined_method, SL),
  198    findall(G, redefined_get_method(G), GL),
  199    maplist(report_redefined_method, GL),
  200    SL == [],
  201    GL == [].
  202
  203redefined_send_method(method(Class, Sel, B0, B1)) :-
  204    pce_principal:pce_lazy_send_method(Sel, Class, B1),
  205    (   pce_principal:pce_lazy_send_method(Sel, Class, B0)
  206    ->  B0 \== B1
  207    ;   fail
  208    ).
  209redefined_get_method(method(Class, Sel, B0, B1)) :-
  210    pce_principal:pce_lazy_get_method(Sel, Class, B1),
  211    (   pce_principal:pce_lazy_get_method(Sel, Class, B0)
  212    ->  B0 \== B1
  213    ;   fail
  214    ).
  215
  216report_redefined_method(method(_, _, B0, B1)) :-
  217    arg(1, B0, Id0),                % deliberate redefinition
  218    arg(1, B1, Id1),
  219    Id0 \== Id1,
  220    !.
  221report_redefined_method(method(Class, Sel, B0, B1)) :-
  222    describe_location(B1, Loc1),
  223    (   Loc1 = File:Line
  224    ->  Loc = file(File, Line)
  225    ;   true
  226    ),
  227    print_message(error,
  228                  error(pce(redefined_method(Class, Sel, B0, B1)),
  229                        Loc)).
  230
  231describe_location(Binder, File:Line) :-
  232    genarg(_, Binder, source_location(File, Line)),
  233    !.
  234describe_location(_, '<no source>').
  235
  236
  237check_pce_database :-
  238    pce_global_objects(All),
  239    send(All, '_check'),
  240    send(All, done).
  241
  242check_pce_types :-
  243    get(@pce, unresolved_types, Types),
  244    get(Types, find_all,
  245        message(@prolog, no_autoload_class, @arg1?context?print_name),
  246        Unresolved),
  247    (   send(Unresolved, empty)
  248    ->  true
  249    ;   send(@pce, format,
  250             '[PCE: WARNING: The following type(s) have no associated class:\n'),
  251        send(Unresolved, for_all,
  252             message(@pce, format, '\t%N\n', @arg1)),
  253        send(@pce, format, ']\n')
  254    ).
  255
  256
  257no_autoload_class(ClassName) :-
  258    pce_prolog_class(ClassName), !, fail.
  259no_autoload_class(ClassName) :-
  260    pce_autoload:autoload(ClassName, _), !, fail.
  261no_autoload_class(_).

 show_slots(+Reference)

Show all slots of the named object. Actually, this is a terminal version of the inspector tool provided with the manual. Notably used by me if PCE is in such a bad shape the inspector won't run anymore

  271show_slots(X) :-
  272    get(X, '_class', Class),
  273    get(Class, slots, Slots),
  274    Max is Slots - 1,
  275    X = @Ref,
  276    get(X, '_class_name', ClassName),
  277    format('@~w/~w~n', [Ref, ClassName]),
  278    between(0, Max, Slot),
  279        get(X, '_slot', Slot, Value),
  280        get(Class, instance_variable, Slot, Var),
  281        get(Var, name, Name),
  282        format('~t~8|~w~t~30|~p~n', [Name, Value]),
  283    fail ; true.
  284
  285
  286                /********************************
  287                *             REFER             *
  288                ********************************/
  289
  290pcerefer(Obj) :-
  291    get(Obj, '_references', Refs),
  292    format('~p has ~d references~n', [Obj, Refs]),
  293    (   Refs > 0
  294    ->  pce_global_objects(All),
  295        new(Found, number(0)),
  296        send(All, for_slot_reference,
  297             if(message(Obj, '_same_reference', @arg4),
  298                message(@prolog, call,
  299                        pcerefer, Obj, @arg1, @arg2, @arg3, All, Found))),
  300        send(All, done),
  301        get(Found, value, FoundRefs),
  302        (   Refs == FoundRefs
  303        ->  format('Found all references~n', [])
  304        ;   format('Found ~d of ~d references~n', [FoundRefs, Refs])
  305        ),
  306        free(Found)
  307    ;   true
  308    ).
  309
  310
  311pcerefer(From, Obj) :-
  312    get(Obj, references, Refs),
  313    format('~p has ~d references~n', [Obj, Refs]),
  314    (   Refs > 0
  315    ->  new(Found, number(0)),
  316        send(From, for_slot_reference,
  317             if(Obj == @arg4,
  318                message(@prolog, call,
  319                        pcerefer, Obj, @arg1, @arg2, @arg3, @nil))),
  320        free(Found)
  321    ;   true
  322    ).
  323
  324:- public pcerefer/6.  325
  326pcerefer(Obj, From, Type, Where, All, Found) :-
  327    Obj \== All,
  328    From \== All,
  329    !,
  330    get(From, '_class_name', ClassName),
  331    format('~t~8|~w ~w of ~w/~w --> ~p~n',
  332           [Type, Where, From, ClassName, Obj]),
  333    send(Found, plus, 1).
  334pcerefer(_, _, _, _, _, _).
  335
  336
  337                /********************************
  338                *           UTILITIES           *
  339                ********************************/
  340
  341test(Goal, _) :-
  342    Goal,
  343    !.
  344test(_, no).
  345
  346                 /*******************************
  347                 *            MESSAGES          *
  348                 *******************************/
  349
  350
  351:- multifile
  352    prolog:message/3.  353
  354prolog:message(error(pce(redefined_method(Class, Sel, B0, B1)), _)) -->
  355    { describe_location(B0, Loc0),
  356      describe_location(B1, Loc1),
  357      (   functor(B0, bind_send, _)
  358      ->  Arrow = (->)
  359      ;   Arrow = (<-)
  360      )
  361    },
  362    [ '~w: ~w~w~w redefined'-[Loc1, Class, Arrow, Sel], nl,
  363      '\tFirst definition at ~w'-[Loc0]
  364    ]