Check-ins Using Download Hex

Artifact ce7b3f0c7a036a03213a9dbfadae6544449eca692fe5adba74f4d372bcff990b:

module rtrace$  % Portable REDUCE tracing

% $Id: rtrace.red 1.5 1999-03-14 10:16:26+00 fjw Exp $

% Based on rdebug by Herbert Melenk, June 1994

% Portability, enhanced interface and updating by
% Francis J. Wright, Time-stamp: <14 March 1999>

% This package currently implements only entry-exit tracing,
% assignment tracing and rule tracing.  (The latter was portable
% already.)  It does not implement breakpoints or conditional tracing,
% and the variable trprinter!* is not used.  However, it adds tracing
% of inactive rules identified by being assigned to variables
% (trrlid/untrrlid).  This package is completely independent of any
% tracing facilities provided by the underlying Lisp system.

% To do:
%   eval autoload stubs before tracing, e.g. for int.
%   improve showrules
%   return something useful from the trace commands?
%   merge trrl and trrlid?
%   provide more intelligible synonyms?

switch rtrace$  !*rtrace := t$

% When this switch is on then algebraic-mode output is used if
% possible; when it is off then Lisp output is used.

% The following are REDUCE commands that accept a sequence of operator
% names.  The command `rtr int, foo' causes the input and output of
% the underlying procedures, probably simpint and foo, to be traced.
% The command `rtrst int, foo' causes both the I/O and the assignments
% to be traced.  The command `unrtr int, foo' removes all tracing, and
% `unrtrst' is a synonym for `unrtr'.

symbolic macro procedure rtr fns;
   %% Trace the procedures underlying the named operators.
   rtr!*('rtrace, fns)$

symbolic macro procedure unrtr fns;
   %% Untrace the procedures underlying the named operators.
   rtr!*('unrtrace, fns)$

symbolic macro procedure rtrst fns;
   %% Traceset the procedures underlying the named operators.
   rtr!*('rtraceset, fns)$

symbolic macro procedure unrtrst fns;
   %% Untrace the procedures underlying the named operators.
   rtr!*('unrtrace, fns)$

flag('(rtr rtrst unrtr unrtrst), 'noform)$
deflist('((rtr rlis) (rtrst rlis) (unrtr rlis) (unrtrst rlis)), 'stat)$

symbolic procedure rtr!*(trfn, fns);
   {trfn, mkquote for each fn in cdr fns collect
      get(fn, 'simpfn) or get(fn, 'psopfn) or fn}$

%% The following are Lisp functions that accept quoted lists of
%% procedure names, cf. traceset in
%% /reduce/lisp/csl/cslbase/compat.lsp:
symbolic procedure rtrace L;
   mapcar(L, function rtrace1)$
symbolic procedure unrtrace L;
   mapcar(L, function unrtrace1)$

fluid '(!*rtrace!-setq)$
% !*comp is pre-declared, to be fluid in CSL and global in PSL!

symbolic procedure rtraceset L;
   mapcar(L, function rtrace1) where !*rtrace!-setq = t$

symbolic procedure rtrace1(name);
   %% Trace or traceset the specified procedure.
   %% name must be quoted when called!
   begin scalar defn, args, !*redefmsg;
      if null(defn := getd name) then return
         write "***** ", name, " not yet defined! ";
      if !*comp then <<
         write "Portable tracing does not work reliably with the";
         write " switch `comp' on, so it has been turned off! ";
         off comp
      >>;
      if eqcar(defn, 'expr) and eqcar(cdr defn, 'lambda) then
         %% cf. traceset in /reduce/lisp/csl/cslbase/compat.lsp
         if eqcar(cadddr defn, 'run!-rtraced!-procedure) then return
            if  flagp(name, 'rtraced!-setq) eq !*rtrace!-setq
               %% i.e. both true or both false
            then write "*** ", name, " already traced! "
            else re!-rtrace1(name)
         else args := caddr defn
      else <<
         if !*rtrace!-setq then <<
            write "*** ", name,
               " must be interpreted for portable assignment tracing! ";
            terpri();
            write "*** Tracing arguments and return value only.";
            terpri();
            !*rtrace!-setq := nil
         >>;
         if (args := get(name, 'number!-of!-args)) then <<
            args := for i := 1 : args collect mkid('!A!r!g, i);
            write "*** ", name, " is compiled: ",
               "portable tracing may not show recursive calls! ";
            terpri();
         >> else <<
            write "***** ", name,
               " must be interpreted for portable tracing! ";
            terpri();
            return
         >>;
      >>;
      if !*rtrace!-setq then <<
         defn := subst('rtraced!-setq, 'setq,
            subst('rtraced!-setk, 'setk, defn));
         flag({name}, 'rtraced!-setq)
      >> else % in case procedure has been redefined:
         remflag({name}, 'rtraced!-setq);
      put(name, 'rtraced!-procedure, defn);
      return eval {'de, name, args,
         {'run!-rtraced!-procedure, mkquote name, mkquote args,
            'list . args}}
   end$

symbolic procedure re!-rtrace1(name);
   %% Toggle trace/traceset of named procedure.
   %% name must be quoted when called!
   begin scalar defn;
      defn := get(name, 'rtraced!-procedure);
      if !*rtrace!-setq then <<
         defn := subst('rtraced!-setq, 'setq,
            subst('rtraced!-setk, 'setk, defn));
         flag({name}, 'rtraced!-setq)
      >> else <<
         defn := subst('setq, 'rtraced!-setq,
            subst('setk, 'rtraced!-setk, defn));
         remflag({name}, 'rtraced!-setq)
      >>;
      put(name, 'rtraced!-procedure, defn);
      write "*** Trace mode of ", name, " changed.";
      return name
   end$

symbolic procedure unrtrace1(name);
   %% Remove all tracing.
   %% name must be quoted when called!
   begin scalar defn, !*redefmsg;
      if (defn := remprop(name, 'rtraced!-procedure)) then <<
         defn := subst('setq, 'rtraced!-setq,
            subst('setk, 'rtraced!-setk, defn));
         putd(name, car defn, cdr defn);
      >>;
      remflag({name}, 'rtraced!-setq);
      return name
   end$

fluid '(rtrace!-depth)$  rtrace!-depth := 0$

global '(rtrout!*)$
% Default is nil, meaning trace to the terminal.

rlistat '(rtrout)$
symbolic procedure rtrout files;
   <<
      if rtrout!* then close(rtrout!*);
      rtrout!* := if car files then open(car files, 'output);
      nil
   >>$

symbolic procedure run!-rtraced!-procedure(name, argnames, args);
   (begin scalar old!-handle, result;
      result := cdr get(name, 'rtraced!-procedure);
      old!-handle := wrs rtrout!*;
      write "Enter (", rtrace!-depth, ") ", name;  terpri();
      for each arg in args do <<
         write "   ", car argnames, ":  ";
         rtrace!-print arg;
         argnames := cdr argnames
      >>;
      wrs old!-handle;
      %% result := apply(cdr get(name, 'rtraced!-procedure), args);
      result :=
         errorset!*({'apply, mkquote result, mkquote args}, nil);
      if errorp result then rederr EMSG!* else result := car result;
      wrs rtrout!*;
      write "Leave (", rtrace!-depth, ") ", name, " = ";
      rtrace!-print result;
      wrs old!-handle;
      return result
   end) where rtrace!-depth = add1 rtrace!-depth$

symbolic procedure rtrace!-print arg;
   if !*rtrace then rdbprint arg else print arg$

symbolic procedure rtrace!-setq!-print arg;
   begin scalar old!-handle;
      old!-handle := wrs rtrout!*;
      rtrace!-print arg;
      wrs old!-handle;
      return arg
   end$

symbolic macro procedure rtraced!-setq u;
   %% For symbolic assignments.
   %% Must avoid evaluating the lhs of the assignment, and evaluate
   %% the rhs only once in case of side effects (such as a gensym).
   begin scalar left, right, old!-handle;
      left := cadr u;
      right := caddr u;
      old!-handle := wrs rtrout!*;
      write left, " := ";
      wrs old!-handle;
      %% Handle nested setq calls carefully:
      return if eqcar(right, 'rtraced!-setq) then
         {'setq, left, right}
      else
         {'rtrace!-setq!-print, {'setq, left, right}}
   end$

symbolic procedure rtraced!-setk(left, right);
   %% For algebraic assignments.
   begin scalar old!-handle;
      old!-handle := wrs rtrout!*;
      write left, " := ";  rtrace!-print right;
      wrs old!-handle;
      return setk(left, right)
   end$

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% The following is based closely on PSL code by
% Herbert Melenk, June 1994

% assgnpri autoloads and is defined in /reduce/src/mathpr/mprint.red
% writepri is defined in terms of assgnpri.

%------------------------------------------------------------------
% Print algebraic expressions by REDUCE printer.

fluid '(trlimit)$
share trlimit$
trlimit := 5$

symbolic procedure rdbprint u;
   % Try to print an expression u as algebraic expression rather than
   % LISP internal style.
   << algpri1(u,0);  assgnpri("",nil,'last) >> where !*nat = nil$

symbolic procedure algpri1(u,n);
   begin scalar r;
      n := n+1;
      if (r := algpriform u) then return algpri2 r;
      algpri2 "[";
      while u do
         if atom u then << algpri2 ".";  algpri2 u;  u := nil >>
         else <<
            algpri1(car u,n);
            u := cdr u;  n := n+1;
            if pairp u then algpri2 ",";
            if n > trlimit then << algpri2 " ...";  u := nil >>
         >>;
      algpri2 "]";
   end$

symbolic procedure algpriform u;
   % is expression printable in algebraic mode?
   if atom u then u else
      if get(car u,'prifn) or get(car u,'pprifn) then u else
         if eqcar(u,'!*sq) then prepsq cadr u else
            if is!-algebraic!? u then u else
               if get(car u,'prepfn) then prepf u else
                  if is!-sform!? u then prepf u else
                     if is!-sfquot!? u then prepsq u$

symbolic procedure is!-algebraic!? u;
   atom u or get(car u,'dname)
      or (get(car u,'simpfn) or get(car u,'psopfn))
         and algebraic!-args cdr u$

symbolic procedure algebraic!-args u;
   null u or is!-algebraic!? car u and algebraic!-args cdr u$

symbolic procedure is!-sform!? u;
   if atom u then t else
      if get(car u,'dname) then t else
         pairp car u and pairp caar u and
            (is!-algebraic!? mvar u or is!-sform!? mvar u)
               and fixp ldeg u and ldeg u>0
                  and is!-sform!? lc u and is!-sform!? red u$

symbolic procedure is!-sfquot!? u;
   pairp u and is!-sform!? numr u and is!-sform!? denr u$

symbolic procedure algpri2 u;
   assgnpri(u,nil,nil)$                 % where !*nat=nil;

%------------------------------------------------------------------
% RULE Trace

symbolic procedure rdbprin2 u;
   algpri1(u,0) where !*nat = nil$

symbolic procedure rule!-trprint!* u;
   begin scalar r;
      rdbprin2 "Rule ";
      rdbprin2 car u; %name
      if cadr u then << rdbprin2 "."; rdbprin2 cadr u >>;
      rdbprin2 ": ";
      rdbprin2 caddr u;
      rdbprin2 " => ";
      rdbprint(r := cadddr u);
      return reval r
   end$

put('rule!-trprint,'psopfn,'rule!-trprint!*)$


%% FJW: Redefine put!-kvalue and put!-avalue in module forall to
%% prevent them detecting spurious recursive simplification errors.
%% Rebind the variable !*recursiveerror to nil to turn off recursive
%% simplification error checking.

fluid '(!*recursiveerror)$
symbolic(!*recursiveerror := t)$

begin scalar !*redefmsg;

   symbolic procedure put!-kvalue(u,v,w,x);
      % This definition is needed to allow p(2) := sqrt(1-p^2).
      if !*recursiveerror and
         (if eqcar(x,'!*sq) then sq_member(w,cadr x) else smember(w,x))
      then recursiveerror w
      else put(u,'kvalue,aconc(v,{w,x}));

   symbolic procedure put!-avalue(u,v,w);
      % This definition allows for an assignment such as a := a 4.
      if v eq 'scalar
      then if eqcar(w,'!*sq) and sq_member(u,cadr w)
      then recursiveerror u
      else if !*reduce4 then putobject(u,w,'generic)
      else put(u,'avalue,{v,w})
      else if !*recursiveerror and smember(u,w) then recursiveerror u
      else put(u,'avalue,{v,w});

end$


fluid '(trace!-rules!*)$

symbolic procedure trrl w;
   for each u in w do
   begin scalar name, rs, rsx, n, !*recursiveerror;
      rs := reval u;
      if idp u then <<
         %% FJW: Take care not to trace a traced rule:
         if assoc(u, trace!-rules!*) then <<
            %% terpri();
            write "*** rules for ", u, " already traced! ";
            terpri();
            return
         >>;
         name := u;
         if rs=u then                   % unassigned operator name?
            rs := showrules u;
         if atom rs or car rs neq 'list or null cdr rs then
            rederr {"could not find rules for", u}
      >> else <<
         name := intern gensym();       % MUST be interned for later use!!!
         prin2 "*** using name ";
         prin2 name;
         prin2t " for rule list"
      >>;
      if eqcar(rs,'list) then
         << rs := cdr rs; n := 1 >>     % rule list
      else
         << rs := {rs}; n := nil >>;    % single rule
      rsx := trrules1(name,n,rs);
      trace!-rules!* := {name,rs,rsx} . trace!-rules!*;
      %% FJW: Should do this only if rules already in effect (?):
      %% algebraic clearrules ('list.rs);
      clearrules ('list . rs);
      %% algebraic let ('list.rsx);
      let ('list . rsx);
      return name
   end$

symbolic procedure trrlid w;
   %% FJW: Trace unset rules assigned to variables.
   for each u in w do
   begin scalar rs, rsx, name, !*recursiveerror;
      if not idp u then typerr(u, "rule list identifier");
      %% Take care not to trace a traced rule:
      if assoc(u, trace!-rules!*) then <<
         %% terpri();
         write "*** rules for ", u, " already traced! ";
         terpri();
         return
      >>;
      rs := reval u;
      if atom rs or car rs neq 'list or null cdr rs then
         typerr(u, "rule list identifier");
      rs := cdr rs;
%%       %% Convert u to string to avoid apparent recursive application
%%       %% of the rule (and prepend "id "):
%%       name := compress(append('(!" i d ! ),append(explode u,'(!"))));
      name := u;
      rsx := trrules1(name, 1, rs);
      trace!-rules!* := {u, rs, rsx} . trace!-rules!*;
      setk0(u, 'list.rsx)  % algebraic assignment to atom u
   end$

put('trrl,'stat,'rlis)$
put('trrlid,'stat,'rlis)$

symbolic procedure trrules1(name, n, rs);
   begin scalar rl, nrl, rh, lh;
      rl := car rs;  rs := cdr rs;
      if atom rl or not memq(car rl, '(replaceby equal)) then
         typerr(rl, 'rule);
      lh := cadr rl;  rh := caddr rl;
      %% Ignore "constant rules" like log(e) => 1:
      if constant_exprp lh then go to a;
      rh := if eqcar(rh, 'when) then
         {'when, {'rule!-trprint, name, n, lh, cadr rh}, caddr rh}
      else {'rule!-trprint,name, n, lh, rh};
   a: nrl := {car rl, lh, rh};
      return if null rs then {nrl} else
         nrl . trrules1(name, n+1, rs)
   end$

symbolic procedure untrrl u;
   begin scalar w, v;
      for each r in u do <<
         w := if idp r then
            assoc(r, trace!-rules!*) or % rule (list) name
            assoc(showrules r, trace!-rules!*) % operator name
         else                           % explicit rule (list)
            assoc!!2(if eqcar(r,'list) then cdr r else r . nil,
               trace!-rules!*);
         if w then <<
            %% The `let' and `clearrules' commands have peculiar
            %% properties, so the following explicit assignments to
            %% `v' are necessary!
            v := 'list . caddr w;  clearrules v;
            v := 'list . cadr w;   let v;
            trace!-rules!* := delete(w, trace!-rules!*)
         >>
         else write "*** rule ", r, " not found"
      >>
   end$

symbolic procedure assoc!!2(u, v);
   %% Finds key U in second element of an element of alist V, and
   %% returns that element or NIL.
   if null v then nil
   else if u = cadar v then car v
   else assoc!!2(u, cdr v)$

symbolic procedure untrrlid u;
   %% FJW: Untrace inactive rules assigned to variables.
   begin scalar w;
      for each r in u do <<
         if not idp r then typerr(r, "rule list identifier");
         w := assoc(r, trace!-rules!*);
         if w then <<
            setk0(r, 'list.cadr w);  % algebraic assignment to atom r
            trace!-rules!* := delete(w, trace!-rules!*)
         >>
      >>
   end$

put('untrrl,'stat,'rlis)$
put('untrrlid,'stat,'rlis)$

% Make 'rule!-trprint invisible when printed.

put('rule!-trprint, 'prifn,
   function(lambda(u); maprin car cddddr u))$

put('rule!-trprint, 'fancy!-prifn,
   function(lambda(u); fancy!-maprin car cddddr u))$

endmodule$

end$
REDUCE Historical
[ REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]