Artifact 5020e3ca8e5919f57659fa3bd2c80d7b79356d8ea0b2bf77a6df6a1079553f71:

• File psl-1983/3-1/util/debug.red — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 50141) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/util/debug.red — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 50141) [annotate] [blame] [check-ins using]

% DEBUG.RED - General tracing capabilities
%             Norman and Morisson
%---------
% Revision History:
%  <PSL.UTIL>DEBUG.RED.21,  4-Feb-83 13:01:05, Edit by OTHMER
%  Added Br - UnBr from Mini-Trace.Red
%  Added functions UnBrAll, UnTrAll
%  Added globals TracedFns!*, BrokenFns!*
%  Changed Restr to be a macro that can take a list of file names
%  as argument
%  Removed many lines of code that had been commented out
%  <PSL.UTIL>DEBUG.RED.20,  3-Feb-83 11:00:06, Edit by KESSLER
%  Remove fluid defintion of !*mode
%  Edit by Griss, 25 January 1983, fix !*MODE and DEFINEROP
%  for REDUCE
%  <PSL.NEW>DEBUG.RED.2, 29-Dec-82 15:28:13, Edit by PERDUE
%  In the fix of 12-december, changed > to !-greaterp
%  Also added a << >> pair to !-findentries
%  <PSL.UTIL>DEBUG.RED.16, 28-Dec-82 13:50:19, Edit by PERDUE
%  Added !-TRSTCOND to handle COND correctly
%  <PSL.UTIL>DEBUG.RED,  12-Dec-82 15:59:45, Edit by GRISS
%    Fixed printx to handle 0 SIZE (i.e. one-element) vectors

CompileTime flag('(!-LPRIE !-LPRIM
		   !-PAD !-IDLISTP !-CIRLIST !-FIRSTN !-LISTOFATOMS !-!-PUTD
		   !-LABELNAME !-FINDENTRIES !-PRINTPASS !-PRINS
		   !-TRGET !-TRGETX !-TRFLAGP !-TRPUT !-TRPUTX !-TRPUTX1
		   !-TRFLAG !-TRFLAG1 !-TRREMPROP !-TRREMPROPX
		   !-TRREMFLAG !-TRREMFLAG1
		   !-TRINSTALL !-ARGNAMES
		   !-TRRESTORE !-OUTRACE1 !-DUMPTRACEBUFF
		   !-ERRAPPLY
		   !-ENTERPRI !-EXITPRI !-TRINDENT !-TRACEPRI1
		   !-TRACENTRYPRI1 !-TRACEXPANDPRI
		   !-MKTRST !-MKTRST1
		   !-BTRPUSH !-BTRPOP !-BTRDUMP
		   !-EMBSUBST
		   !-TR1 !-MKSTUB
		   !-PLIST1 !-PPF1 !-GETC),
		 'InternalFunction);

%********************* Implementation dependent procedures ***********

fluid '(IgnoredInBacktrace!*);

IgnoredInBacktrace!* := Append('(!-TRACEDCALL !-APPLY !-GET),
			       IgnoredInBacktrace!*);

%ON NOUUO; % Slow links 

PUTD('!-!%PROP,'EXPR,CDR GETD 'PROP);

SYMBOLIC PROCEDURE !-GETPROPERTYLIST U;
% U is an  id.  Returns  a list  of all  the flags  (id's) and  property-values
% (dotted pairs) of U.
 !-!%PROP U;

%DEFINE !-GETPROPERTYLIST=!-!%CDR;
%
%PUTD('!-ATOM,'EXPR,CDR GETD 'ATOM);
%
% SYMBOLIC PROCEDURE !-ATOM U;
% A safe version of ATOM.
% !-!%PATOM U;
%
%DEFINE !-ATOM=!-!%PATOM;
%
%GLOBAL '(!*NOUUO);
%
CompileTime <<
SYMBOLIC SMACRO PROCEDURE !-SLOWLINKS;
% Suppresses creation of fast-links
% No-op in PSL
 NIL;
>>;
%******************************************************************

% Needs REDIO for sorting routine.  If compiled without it only
% the printing under the influence of COUNT will be affected.

% I systematically use names starting with a '-' within this
% package for internal routines that must not interfere with the
% user. This means that the debug package may behave incorrectly
% if user functions or variables have names starting with a '-';

%******************** Globals declarations ************************

GLOBAL '(
% Boolean valued flags
  !*BTR			 % T -> stack traced function calls for backtrace
  !*BTRSAVE		 % T -> bactrace things which fail in errorsets
  !*INSTALL		 % T -> "install" trace info on all PUTD'd functions
  !*SAVENAMES		 % controlls saving of substructure names in PRINTX
  !*TRACE		 % T -> print trace information at run time
  !*TRACEALL		 % T -> trace all functions defined with PUTD
  !*TRSTEXPANDMACROS	 % T -> expand macros before embedding SETQs to print
  !*TRUNKNOWN		 % T -> never ask for the number of args
  !*TRCOUNT		 % T -> count # of invocations of traced functions
% Other globals intended to be accessed outside of DEBUG
  !*MSG			 % 
  BROKENFNS!*            % List of functions that have been broken
  TRACEDFNS!*            % List of functions that have been traced
  EMSG!*		 %
  ERFG!*		 % Reduce flag
  MSGCHNL!*		 % Channel to output trace information
  PPFPRINTER!*		 % Used by PPF to print function bodies 
  PROPERTYPRINTER!*	 % Used by PLIST to print property values
  PUTDHOOK!*		 % User hook run after a successful PUTD
  STUBPRINTER!*		 % For printing arguments in calls on stubs
  STUBREADER!*		 % For reading the return value in calls on stubs
  TRACEMINLEVEL!*	 % Minimum recursive depth at which to trace
  TRACEMAXLEVEL!*	 % Maximum     "       "   "	"   "	 "
  TRACENTRYHOOK!*	 % User hook into traced functions
  TRACEXITHOOK!*	 %  "	 "    "     "	     "
  TRACEXPANDHOOK!*	 %  "	 "    "     "	     "
  TREXPRINTER!*		 % Function used to print args/values in traced fns
  TRINSTALLHOOK!*	 % User hook called when a function is first traced
  TRPRINTER!*		 % Function used to print macro expansions
% Globals principally for internal use
  !-ARBARGNAMES!*	 % List of ids to be used for unspecified names
  !-ARGINDENT!*		 % Number of spaces to indent when printing args
  !-BTRSAVEDINTERVALS!*	 % Saved BTR frames from within errorsets
  !-BTRSTK!*		 % Stack for bactrace info
%  !-COLONERRNUM!*	 % Error number used by failing :CAR,:CDR, etc.
  !-FUNCTIONFLAGS!*	 % Flags which PPF considers printing
  !-GLOBALNAMES!*	 % Used by PRINTX to store common substructure names
  !-INDENTCUTOFF!*	 % Furthest right to indent trace output
  !-INDENTDEPTH!*	 % Number of spaces to indent each level trace output
  !-INVISIBLEPROPS!*	 % Properties which PLIST should ignore
  !-INVISIBLEFLAGS!*	 % Flags which PLIST should ignore
  !-INSTALLEDFNS!*	 % Functions which have had information installed
  !-NONSTANDARDFNS!*	 % Properties under which special MACRO's are stored
%  !-SAFEFNSINSTALLED!*	 % T -> :CAR, etc have replaced CAR, etc
  !-TRACEBUFF!*		 % Ringbuffer to save recent trace output
  !-TRACECOUNT!*	 % Decremented -- if >0 it may suppresses tracing
  !-TRACEFLAG!*		 % Enables tracing
	);

FLUID '(
  !*COMP		 % Standard Lisp flag
  !*BACKTRACE		 % Reduce flag
  !*DEFN		 % Reduce flag
  !-ENTRYPOINTS!*	 % for PRINTX
  !-ORIGINALFN!*	 % fluid argument in EMBed function calls
  !-PRINTXCOUNT!*	 % Used by PRINTX for making up names for EQ structures
  !-TRINDENT!*		 % Current level of indentation of trace output
  !-VISITED!*		 % for PRINTX
	);

!*BTR		  := T;
!*BTRSAVE	  := T;
!*TRACE           := T;
!*TRCOUNT	  := T;
!*TRSTEXPANDMACROS := T;
!-ARBARGNAMES!*   := '(A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15);
!-ARGINDENT!*     := 3;
%!-COLONERRNUM!*   := 993; % Any ideas of anything particularly appropriate?
!-FUNCTIONFLAGS!* := '(EVAL IGNORE LOSE NOCHANGE EXPAND NOEXPAND OPFN DIRECT);
!-INDENTCUTOFF!*  := 12;
!-INDENTDEPTH!*	  := 2;
!-INVISIBLEPROPS!*:= '(TYPE !*LAMBDALINK);
!-NONSTANDARDFNS!*:= '(SMACRO NMACRO CMACRO);
!-TRACECOUNT!*	  := 0;
!-TRINDENT!*	  := -1;	 % It's always incremented BEFORE use
!-TRACEFLAG!*	  := T;
!*MSG := T;
PPFPRINTER!*      := IF GETD 'RPRINT THEN 'RPRINT ELSE 'PRETTYPRINT;
PROPERTYPRINTER!* := IF GETD 'PRETTYPRINT THEN 'PRETTYPRINT ELSE 'PRINT;
STUBPRINTER!*     := 'PRINTX;
STUBREADER!*      := IF GETD 'XREAD THEN '!-REDREADER ELSE '!-READ;
TRACEMAXLEVEL!*   := 10000;	 % Essentially no limit
TRACEMINLEVEL!*	  := 0;
TREXPRINTER!*	  := IF GETD 'RPRINT THEN 'RPRINT ELSE 'PRETTYPRINT;
TRPRINTER!*	  := 'PRINTX;
BrokenFns!*       := Nil;
TracedFns!*       := Nil;

% Let TRST know about the behaviour of some common FEXPRs

FLAG('(	% common FEXPRs which never pass back an unEVALed argument
  AND
  LIST
  MAX
  MIN
  OR
  PLUS
  PROGN
  REPEAT
  TIMES
  WHILE
     ),'TRSTINSIDE);

DEFLIST ('( % special sorts of FEXPRs
  (LAMBDA !-TRSTPROG)	% Not really a function, but handled by TRST as such
  (PROG !-TRSTPROG)
  (SETQ !-TRSTSETQ)
  (COND !-TRSTCOND)
	 ),'TRSTINSIDEFN);

%****************** Utility functions ********************************

% Copy the entrypoints of various key functions so that
% nobody gets muddled by trying to trace or redefine them;

PUTD('!-APPEND,'EXPR,CDR GETD 'APPEND);
PUTD('!-APPLY,'EXPR,CDR GETD 'APPLY);
PUTD('!-ATSOC,'EXPR,CDR GETD 'ATSOC);
%PUTD('!-CAR,'EXPR,CDR GETD 'CAR);
%PUTD('!-CDR,'EXPR,CDR GETD 'CDR);
%PUTD('!-CODEP,'EXPR,CDR GETD 'CODEP);
PUTD('!-COMPRESS,'EXPR,CDR GETD 'COMPRESS);
%PUTD('!-CONS,'EXPR,CDR GETD 'CONS);
PUTD('!-EQUAL,'EXPR,CDR GETD 'EQUAL);
PUTD('!-ERRORSET,'EXPR,CDR GETD 'ERRORSET);
PUTD('!-EVAL,'EXPR,CDR GETD 'EVAL);
%PUTD('!-EVLIS,'EXPR,CDR GETD 'EVLIS);
PUTD('!-EXPLODE,'EXPR,CDR GETD 'EXPLODE);
PUTD('!-FLAG,'EXPR,CDR GETD 'FLAG);
PUTD('!-FLAGP,'EXPR,CDR GETD 'FLAGP);
PUTD('!-FLUID,'EXPR,CDR GETD 'FLUID);
PUTD('!-GET,'EXPR,CDR GETD 'GET);
PUTD('!-GETD,'EXPR,CDR GETD 'GETD);
%PUTD('!-IDP,'EXPR,CDR GETD 'IDP);
PUTD('!-INTERN,'EXPR,CDR GETD 'INTERN);
PUTD('!-LENGTH,'EXPR,CDR GETD 'LENGTH);
PUTD('!-MAX2,'EXPR,CDR GETD 'MAX2);
PUTD('!-MEMQ,'EXPR,CDR GETD 'MEMQ);
PUTD('!-MIN2,'EXPR,CDR GETD 'MIN2);
PUTD('!-OPEN,'EXPR,CDR GETD 'OPEN);
%PUTD('!-PATOM,'EXPR,CDR GETD 'PATOM);
PUTD('!-PLUS2,'EXPR,CDR GETD 'PLUS2);
PUTD('!-POSN,'EXPR,CDR GETD 'POSN);
PUTD('!-PRIN1,'EXPR,CDR GETD 'PRIN1);
PUTD('!-PRIN2,'EXPR,CDR GETD 'PRIN2);
PUTD('!-PRINC,'EXPR,CDR GETD 'PRINC);
PUTD('!-PRINT,'EXPR,CDR GETD 'PRINT);
%PUTD('!-PROG,'FEXPR,CDR GETD 'PROG);
PUTD('!-PUT,'EXPR,CDR GETD 'PUT);
PUTD('!-PUTD,'EXPR,CDR GETD 'PUTD);
PUTD('!-READ,'EXPR,CDR GETD 'READ);
PUTD('!-REMD,'EXPR,CDR GETD 'REMD);
PUTD('!-REMPROP,'EXPR,CDR GETD 'REMPROP);
%PUTD('!-RETURN,'EXPR,CDR GETD 'RETURN);
PUTD('!-REVERSE,'EXPR,CDR GETD 'REVERSE);
%PUTD('!-RPLACA,'EXPR,CDR GETD 'RPLACA);
%PUTD('!-RPLACD,'EXPR,CDR GETD 'RPLACD);
PUTD('!-SET,'EXPR,CDR GETD 'SET);
PUTD('!-TERPRI,'EXPR,CDR GETD 'TERPRI);
PUTD('!-WRS,'EXPR,CDR GETD 'WRS);
%PUTD('!-ZEROP,'EXPR,CDR GETD 'ZEROP);



CompileTime <<

smacro procedure alias(x, y);
    macro procedure x u; 'y . cdr u;

alias(!-DIFFERENCE, IDifference);
alias(!-GREATERP, IGreaterP);
alias(!-LESSP, ILessP);
alias(!-SUB1, ISub1);
alias(!-TIMES2, ITimes2);

load Fast!-Vector;
alias(!-GETV, IGetV);
alias(!-UPBV, ISizeV);

%alias(!-ADD1, IAdd1);
put('!-add1, 'cmacro , '(lambda (x) (iadd1 x)));
>>;

lisp procedure !-ADD1 X;		% because it gets called from EVAL
    IAdd1 X;

SYMBOLIC PROCEDURE !-LPRIE U;
<<  ERRORPRINTF("***** %L", U);
    ERFG!* := T >>;

SYMBOLIC PROCEDURE !-LPRIM U; 
    !*MSG AND ERRORPRINTF("*** %L", U);


PUTD('!-REVERSIP, 'EXPR, CDR GETD 'REVERSIP);
PUTD('!-MKQUOTE, 'EXPR, CDR GETD 'MKQUOTE);
PUTD('!-EQCAR, 'EXPR, CDR GETD 'EQCAR);
PUTD('!-SPACES, 'EXPR, CDR GETD 'SPACES);
PUTD('!-SPACES2, 'EXPR, CDR GETD 'SPACES2);
PUTD('!-PRIN2T, 'EXPR, CDR GETD 'PRIN2T);

SYMBOLIC PROCEDURE !-PAD(L, N);
IF FIXP N THEN
   IF N < !-LENGTH L THEN
      !-PAD(!-REVERSIP CDR !-REVERSE L, N)
   ELSE IF N > !-LENGTH L THEN
      !-PAD(!-APPEND(L, LIST NIL), N)
   ELSE
      L
ELSE
   REDERR "!-PAD given nonintegral second arg";

SYMBOLIC PROCEDURE !-IDLISTP L;
NULL L OR IDP CAR L  AND !-IDLISTP CDR L;

SYMBOLIC PROCEDURE !-CIRLIST(U,N);
% Returns a circular list consisting of N U's.
BEGIN SCALAR A,B;
  IF NOT !-GREATERP(N,0) THEN
    RETURN NIL;
  B := A := U . NIL;
  FOR I := 2:N DO
    B := U . B;
  RETURN RPLACD(A,B)
END !-CIRCLIST;

SYMBOLIC PROCEDURE !-FIRSTN(N,L);
    IF N=0 THEN NIL
    ELSE IF NULL L THEN !-FIRSTN(N,LIST GENSYM())
    ELSE CAR L . !-FIRSTN(!-DIFFERENCE(N,1),CDR L);

SYMBOLIC PROCEDURE !-LISTOFATOMS L;
    IF NULL L THEN T
    ELSE IF IDP CAR L THEN !-LISTOFATOMS CDR L
    ELSE NIL;

SYMBOLIC PROCEDURE !-!-PUTD(NAME,TYPE,BODY);
% as PUTD but never compiles, and preserves TRACE property;
  BEGIN
    SCALAR COMP,SAVER,BOL;
    COMP:=!*COMP; % REMEMBER STATE OF !*COMP FLAG;
    !*COMP:=NIL; % TURN OFF COMPILATION;
    SAVER:=!-GET(NAME,'TRACE);
    BOL:=FLAGP(NAME,'LOSE);
    REMFLAG(LIST NAME,'LOSE);	% IGNORE LOSE FLAG;
    !-REMD NAME; % TO MAKE THE NEXT PUTD QUIET EVEN IF I AM REDEFINING;
    BODY:=!-PUTD(NAME,TYPE,BODY);
    IF NOT NULL SAVER THEN !-PUT(NAME,'TRACE,SAVER);
    !*COMP:=COMP; % RESTORE COMPILATION FLAG;
    IF BOL THEN FLAG(LIST NAME,'LOSE);
    RETURN BODY
  END;


%******* Routines for printing looped and shared structures ******
%
% MAIN ENTRYPOINT:
%
%    PRINTX (A)
%
% !-PRINTS THE LIST A. IF !*SAVENAMES IS TRUE CYCLES ARE PRESERVED
% BETWEEN CALLS TO !-PRINTS;
% PRINTX RETURNS NIL;

%VARIABLES USED -
%
% !-ENTRYPOINTS!*   ASSOCIATION LIST OF POINTS WHERE THE LIST
%		RE-ENTERS ITSELF. VALUE PART OF A-LIST ENTRY
%		IS NIL IF NODE HAS NOT YET BEEN GIVEN A NAME,
%		OTHERWISE IT IS THE NAME USED.
%
% !-VISITED!*	    LIST OF NODES THAT HAVE BEEN ENCOUNTERED DURING
%		CURRENT SCAN OF LIST
%
% !-GLOBALNAMES!*   LIKE !-ENTRYPOINTS!*, BUT STAYS ACTIVE BETWEEN CALLS
%		TO PRINTX
%
% !-PRINTXCOUNT!* USED TO DECIDE ON A NAME FOR THE NEXT NODE;


SYMBOLIC PROCEDURE !-LABELNAME();
    BldMsg("%%L%W", !-PRINTXCOUNT!* := !-PLUS2(!-PRINTXCOUNT!*,1));

SYMBOLIC PROCEDURE !-FINDENTRIES A;
    IF NOT (PAIRP A OR VECTORP A) THEN NIL
    ELSE IF !-ATSOC(A,!-ENTRYPOINTS!*) THEN NIL
    ELSE IF !-MEMQ(A,!-VISITED!*) THEN
	!-ENTRYPOINTS!*:=(A . NIL) . !-ENTRYPOINTS!*
    ELSE
    <<	!-VISITED!*:=A . !-VISITED!*;
	IF VECTORP A THEN
	BEGIN SCALAR N, I;
	    I := 0;
	    N := !-UPBV A;
	    WHILE NOT !-GREATERP(I, N) DO
	    <<  !-FINDENTRIES !-GETV(A,I);
		I := !-ADD1 I >>;
	END ELSE
	<< !-FINDENTRIES CAR A;
	!-FINDENTRIES CDR A >> >>;

SYMBOLIC PROCEDURE !-PRINTPASS A;
    IF NOT (PAIRP A OR VECTORP A) THEN !-PRIN1 A
    ELSE BEGIN SCALAR W, N, I;
	IF !-GREATERP(!-POSN(),50) THEN !-TERPRI();
	W:=!-ATSOC(A,!-ENTRYPOINTS!*);
	IF NULL W THEN GO TO ORDINARY;
	IF CDR W THEN RETURN !-PRIN2 CDR W;
	RPLACD(W,!-PRIN2 !-LABELNAME());
	!-PRIN2 ": ";
ORDINARY:
	IF VECTORP A THEN RETURN
	<<  N := !-UPBV A;
	    !-PRINC '![;
              IF !-GREATERP(N,-1) THEN  % perdue fix
	    <<  !-PRINTPASS !-GETV(A, 0);
		I := 1;
		WHILE NOT !-GREATERP(I, N) DO
		<<  !-PRINC '! ;
		    !-PRINTPASS !-GETV(A, I);
		    I := !-ADD1 I >> >>;
	    !-PRINC '!] >>;
	!-PRINC '!(;
LOOP:
	!-PRINTPASS CAR A;
	A:=CDR A;
	IF NULL A THEN GOTO NILEND
	ELSE IF ATOM A THEN GO TO ATOMEND
	ELSE IF (W:=!-ATSOC(A,!-ENTRYPOINTS!*)) THEN GOTO LABELED;
BLANKIT:
	!-PRINC '! ;
	GO TO LOOP;
LABELED:
	IF CDR W THEN GOTO REFER;
	!-PRINC '! ;
	RPLACD(W,!-PRIN2 !-LABELNAME());
	!-PRIN2 ", ";
	GO TO LOOP;
REFER:
	!-PRIN2 " . ";
	!-PRIN2 CDR W;
	GO TO NILEND;
ATOMEND:
	!-PRIN2 " . ";
	!-PRIN1 A;
NILEND:
	!-PRINC '!);
	RETURN NIL
  END;

SYMBOLIC PROCEDURE !-PRINS(A,L);
  BEGIN
    SCALAR !-VISITED!*,!-ENTRYPOINTS!*,!-PRINTXCOUNT!*;
    IF ATOM L THEN !-PRINTXCOUNT!*:=0
    ELSE << !-PRINTXCOUNT!*:=CAR L; !-ENTRYPOINTS!*:=CDR L >>;
    !-FINDENTRIES A;
    !-PRINTPASS A;
    RETURN (!-PRINTXCOUNT!* . !-ENTRYPOINTS!*)
  END;

SYMBOLIC PROCEDURE PRINTX A;
    <<IF !*SAVENAMES THEN !-GLOBALNAMES!*:=!-PRINS(A,!-GLOBALNAMES!*)
       ELSE !-PRINS(A,NIL);
      !-TERPRI();
      NIL >>;


%****************** Trace sub-property-list functions ******************

% The property TRACE is removed from any function that is subject
% to definition or redefinition by PUTD, and so it represents
% a good place to hide information about the function. The following
% set of functions run a sub-property-list stored under this
% indicator;

SYMBOLIC PROCEDURE !-TRGET(ID,IND);
    !-TRGETX(!-GET(ID,'TRACE),IND);

SYMBOLIC PROCEDURE !-TRGETX(L,IND);
% L IS A 'PROPERTY LIST' AND IND IS AN INDICATOR;
    IF NULL L THEN NIL
    ELSE IF !-EQCAR(CAR L,IND) THEN CDAR L
    ELSE !-TRGETX(CDR L,IND);

SYMBOLIC PROCEDURE !-TRFLAGP(ID,IND);
    !-MEMQ(IND,!-GET(ID,'TRACE));

SYMBOLIC PROCEDURE !-TRPUT(ID,IND,VAL);
    !-PUT(ID,'TRACE,!-TRPUTX(!-GET(ID,'TRACE),IND,VAL));

SYMBOLIC PROCEDURE !-TRPUTX(L,IND,VAL);
IF !-TRPUTX1(L,IND,VAL) THEN L
ELSE (IND . VAL) . L;

SYMBOLIC PROCEDURE !-TRPUTX1(L,IND,VAL);
BEGIN
 L: IF NULL L THEN
      RETURN NIL;
    IF !-EQCAR(CAR L,IND) THEN <<
      RPLACD(CAR L,VAL);
      RETURN T >>;
    L := CDR L;
    GO TO L
END;

SYMBOLIC PROCEDURE !-TRFLAG(L,IND);
FOR EACH ID IN L DO
  !-TRFLAG1(ID,IND);

SYMBOLIC PROCEDURE !-TRFLAG1(ID,IND);
BEGIN SCALAR A;
 A:=!-GET(ID,'TRACE);
 IF NOT !-MEMQ(IND,A) THEN
   !-PUT(ID,'TRACE,IND . A)
END;

SYMBOLIC PROCEDURE !-TRREMPROP(ID,IND);
 << IND:=!-TRREMPROPX(!-GET(ID,'TRACE),IND);
    IF NULL IND THEN !-REMPROP(ID,'TRACE)
    ELSE !-PUT(ID,'TRACE,IND) >>;

SYMBOLIC PROCEDURE !-TRREMPROPX(L,IND);
    IF NULL L THEN NIL
    ELSE IF !-EQCAR(CAR L,IND) THEN CDR L
    ELSE CAR L . !-TRREMPROPX(CDR L,IND);

SYMBOLIC PROCEDURE !-TRREMFLAG(L,IND);
    FOR EACH ID IN L DO !-TRREMFLAG1(ID,IND);

SYMBOLIC PROCEDURE !-TRREMFLAG1(ID,IND);
 << IND:=DELETE(IND,!-GET(ID,'TRACE));
    IF NULL IND THEN !-REMPROP(ID,'TRACE)
    ELSE !-PUT(ID,'TRACE,IND) >>;


%******************* Basic functions for TRACE and friends ***********

SYMBOLIC PROCEDURE !-TRINSTALL(NAM,ARGNUM);
% Sets up TRACE properties for function NAM.  This is common to all  TRACE-like
% actions.  Function NAM  is redefined to  dispatch through !-TRACEDCALL  which
% takes various actions  (which may simply  be to run  the original  function).
% Important items stored under the TRACE property include ORIGINALFN, which  is
% the original definition,  FNTYPE, the original  function "type" (e.g.   EXPR,
% MACRO ...),  and ARGNAMES,  a list  of the  names of	the arguments  to  NAM.
% arguments to the function.  Runs TRINSTALLHOOK!* if non-nil.	Returns non-nil
% if it succeeds, nil if for some reason it fails.
BEGIN SCALAR DEFN,CNTR,ARGS,TYP;
  if Memq (Nam,BrokenFns!*) then
     << EvUnBr List Nam;
        BrokenFns!* := DelQ(Nam,BrokenFns!*) >>;
  DEFN := !-GETD NAM;
  IF NULL DEFN THEN <<
    !-LPRIM LIST("Function",NAM,"is not defined.");
    RETURN NIL >>;
  TYP  := CAR DEFN;
  DEFN := CDR DEFN;
  IF !-GET(NAM,'TRACE) THEN
    IF NUMBERP ARGNUM AND TYP EQ 'FEXPR AND
       !-TRGET(NAM,'FNTYPE) EQ 'EXPR THEN <<
	 TYP := 'EXPR;
	 !-TRREMFLAG(LIST NAM,'UNKNOWNARGS);
	 DEFN := !-TRGET(NAM,'ORIGINALFN) >>
    ELSE
      RETURN T
  ELSE IF TRINSTALLHOOK!* AND
	  NOT !-ERRAPPLY(TRINSTALLHOOK!*,LIST NAM,'TRINSTALLHOOK) THEN
	    RETURN NIL;
  !-TRPUT(NAM,'ORIGINALFN,DEFN);
  !-TRPUT(NAM,'FNTYPE,TYP);
  ARGS := !-ARGNAMES(NAM,DEFN,TYP,ARGNUM);
  IF ARGS EQ 'UNKNOWN THEN <<
    !-TRPUT(NAM,'ARGNAMES,!-ARBARGNAMES!*);
    !-TRFLAG(LIST NAM,'UNKNOWNARGS) >>
  ELSE
    !-TRPUT(NAM,'ARGNAMES,ARGS);
  CNTR := GENSYM();
  !-FLUID LIST CNTR;
  !-TRPUT(NAM,'LEVELVAR,CNTR);
  !-SET(CNTR,0);
  !-TRPUT(NAM,'COUNTER,0);
  IF ARGS EQ 'UNKNOWN THEN
    !-!-PUTD(NAM,
	     'FEXPR,
	     LIST('LAMBDA,
		    '(!-L),
		    LIST(LIST('LAMBDA,
				  LIST(CNTR,'!-TRINDENT!*),
				  LIST('!-TRACEDCALL,
					 !-MKQUOTE NAM,
					 '(!-EVLIS !-L) ) ),
 			   LIST('!-ADD1,CNTR),
			   '!-TRINDENT!*) ) )
  ELSE
    !-!-PUTD(NAM,
	     TYP,
	     LIST('LAMBDA,
		    ARGS,
		    LIST(LIST('LAMBDA,
				  LIST(CNTR,'!-TRINDENT!*),
				  LIST('!-TRACEDCALL,
					 !-MKQUOTE NAM,
					 'LIST . ARGS) ),
			   LIST('!-ADD1,CNTR),
			   '!-TRINDENT!*) ) );
  IF NOT !-MEMQ(NAM,!-INSTALLEDFNS!*) THEN
    !-INSTALLEDFNS!* := NAM . !-INSTALLEDFNS!*;
  RETURN T
END !-TRINSTALL;

SYMBOLIC PROCEDURE !-TRINSTALLIST U;
FOR EACH V IN U DO !-TRINSTALL(V,NIL);

SYMBOLIC PROCEDURE !-ARGNAMES(FN,DEFN,TYPE,NM);
% Tries to discover the names of the arguments	of FN.	NM is a good guess,  as
% for instance based on the arguments to an EMB procedure.  Returns UNKNOWN  if
% it can't find out.  ON TRUNKNOWN will cause it to return UNKNOWN rather  than
% asking the user.
IF !-EQCAR(DEFN,'LAMBDA) THEN		% otherwise it must be a code pointer
  CADR DEFN
ELSE IF NOT TYPE EQ 'EXPR THEN
  LIST CAR !-ARBARGNAMES!*
ELSE IF (TYPE:=!-GET(FN,'ARGUMENTS!*))
	or (TYPE := code!-number!-of!-arguments DEFN) THEN
  IF NUMBERP TYPE THEN
    !-FIRSTN(TYPE,!-ARBARGNAMES!*)
  ELSE
    CAR TYPE
ELSE IF NUMBERP NM THEN
  !-FIRSTN(NM,!-ARBARGNAMES!*)
ELSE IF !*TRUNKNOWN THEN
  'UNKNOWN
ELSE !-ARGNAMES1 FN;
%  BEGIN SCALAR RESULT;
%    RESULT := ERRORSET(LIST('!-ARGNAMES1,!-MKQUOTE FN),NIL,NIL);
%    IF PAIRP RESULT THEN
%      RETURN CAR RESULT
%    ELSE
%      ERROR(RESULT,EMSG!*)
%  END;

FLUID '(PROMPTSTRING!*);

SYMBOLIC PROCEDURE !-ARGNAMES1 FN;
BEGIN SCALAR N, PROMPTSTRING!*;
  PROMPTSTRING!* := BLDMSG("How many arguments does %r take? ", FN);
AGAIN:
  N:=READ();
  IF N='!? THEN <<
    !-TERPRI(); %EXPLAIN OPTIONS;
    !-PRIN2 "Give a number, a list of atoms (for the names of";
    !-TERPRI();
    !-PRIN2 "the arguments) or the word 'UNKNOWN'. System security";
    !-TERPRI();
    !-PRIN2 "will not be good if you say UNKNOWN, but LISP will";
    !-TERPRI();
    !-PRIN2 "at least try to help you";
    !-TERPRI();
%   !-PRIN2 "Number of arguments";
    GO TO AGAIN >>
  ELSE IF N='UNKNOWN THEN
    RETURN N
  ELSE IF FIXP N AND NOT !-LESSP(N,0) THEN
    RETURN !-FIRSTN(N,!-ARBARGNAMES!*)
  ELSE IF !-LISTOFATOMS N THEN
    RETURN N;
  !-TERPRI();
  !-PRIN2 "*** Please try again, ? will explain options ";
  GO TO AGAIN
END !-ARGNAMES1;

SYMBOLIC PROCEDURE !-TRRESTORE U;
BEGIN SCALAR BOD,TYP;
  IF NOT !-GET(U,'TRACE) THEN
    RETURN;
  BOD := !-TRGET(U,'ORIGINALFN);
  TYP := !-TRGET(U,'FNTYPE);
  IF NULL BOD OR NULL TYP THEN <<
    !-LPRIM LIST("Can't restore",U);
    RETURN >>;
  !-REMD U;
  !-PUTD(U,TYP,BOD);
  !-REMPROP(U,'TRACE)
END !-TRRESTORE;

SYMBOLIC PROCEDURE REDEFINED!-PUTD(NAM,TYP,BOD);
BEGIN SCALAR ANSWER;
  REMPROP(NAM,'TRACE);
  ANSWER := !-PUTD(NAM,TYP,BOD);
  IF NULL ANSWER THEN
    RETURN NIL;
  IF !*TRACEALL OR !*INSTALL THEN
    !-TRINSTALL(NAM,NIL);
  IF !*TRACEALL THEN
     << !-TRFLAG(LIST NAM,'TRPRINT);
      If Not Memq (NAM, TracedFns!*) then
         TracedFns!* := NAM . TracedFns!*>>;
  IF PUTDHOOK!* THEN
    APPLY(PUTDHOOK!*,LIST NAM);
  RETURN ANSWER
END;

PUTD('PUTD, 'EXPR, CDR GETD 'REDEFINED!-PUTD);

%FEXPR PROCEDURE DE U;
%PUTD(CAR U,'EXPR,'LAMBDA . CADR U . CDDR U);
%
%FEXPR PROCEDURE DF U;
%PUTD(CAR U,'FEXPR,'LAMBDA . CADR U . CDDR U);
%
%FEXPR PROCEDURE DM U;
%PUTD(CAR U,'MACRO,'LAMBDA . CADR U . CDDR U);

PUT('TRACEALL,'SIMPFG,'((T (SETQ !*INSTALL T))(NIL (SETQ !*INSTALL NIL))));
PUT('INSTALL,'SIMPFG,'((NIL (SETQ !*TRACEALL NIL))));

%*********************************************************************

SYMBOLIC PROCEDURE TROUT U;
% U is a filename.  Redirects trace output there. 
<< IF MSGCHNL!* THEN
    CLOSE MSGCHNL!*;
   MSGCHNL!* := !-OPEN(U,'OUTPUT) >>;

SYMBOLIC PROCEDURE STDTRACE;
<< IF MSGCHNL!* THEN
    CLOSE MSGCHNL!*;
   MSGCHNL!* := NIL >>;

CompileTime <<
SYMBOLIC MACRO PROCEDURE !-OUTRACE U;
% Main trace output handler.  !-OUTRACE(fn,arg1,...argn) calls fn(arg1,...argn)
% as appropriate to print trace information.
LIST('!-OUTRACE1,
     'LIST . MKQUOTE CADR U . FOR EACH V IN CDDR U COLLECT
				                         LIST('!-MKQUOTE,V) );
>>;

SYMBOLIC PROCEDURE !-OUTRACE1 !-U;
BEGIN SCALAR !-STATE;
  IF !-TRACEBUFF!* THEN <<
    RPLACA(!-TRACEBUFF!*,!-U);
    !-TRACEBUFF!* := CDR !-TRACEBUFF!* >>;
  IF !*TRACE THEN <<
    !-STATE := !-ENTERPRI();
    !-EVAL !-U;
    !-EXITPRI !-STATE >>
END !-OUTRACE;

SYMBOLIC PROCEDURE !-DUMPTRACEBUFF DELFLG;
% Prints the ring buffer of saved trace output stored by OUTRACE.
% DELFLG non-nil wipes it clean as well.
BEGIN SCALAR PTR;
  IF NOT !-EQUAL(!-POSN(),0) THEN
    !-TERPRI();
  IF NULL !-TRACEBUFF!* THEN <<
    !-PRIN2T "*** No trace information has been saved ***";
    RETURN >>;
  !-PRIN2T "*** Start of saved trace information ***";
  PTR := !-TRACEBUFF!*;
  REPEAT <<
    !-EVAL CAR PTR;
    IF DELFLG THEN
      RPLACA(PTR,NIL);
    PTR := CDR PTR >>
  UNTIL PTR EQ !-TRACEBUFF!*;
  !-PRIN2T "*** End of saved trace information ***";
END !-DUMPTRACEBUFF;

SYMBOLIC PROCEDURE NEWTRBUFF N;
% Makes a new ring buffer for trace output with N entries.
<< !-TRACEBUFF!* := !-CIRLIST(NIL,N);
   NIL >>;

!-FLAG('(NEWTRBUFF),'OPFN);

NEWTRBUFF 5;

SYMBOLIC PROCEDURE !-TRACEDCALL(!-NAM,!-ARGS);
% Main routine for handling  traced functions.	Currently  saves the number  of
% invocations of the function,	prints trace information,  causes EMB and  TRST
% functions to	be  handled correctly,	calls  several hooks,  and  stacks  and
% unstacks  information in  the BTR  stack, if	appropriate.  Examines	several
% state variables and  a number of  function specific flags  to determine  what
% must be done.
BEGIN SCALAR !-A,!-BOD,!-VAL,!-FLG,!-LOCAL,!-STATE,!-BTRTOP,!-TYP,!-LEV,!-EMB;
  IF !*TRCOUNT THEN
    IF !-A := !-TRGET(!-NAM,'COUNTER) THEN
      !-TRPUT(!-NAM,'COUNTER,!-ADD1 !-A);
  !-TRACECOUNT!* := !-SUB1 !-TRACECOUNT!*;
  IF !-LESSP(!-TRACECOUNT!*,1) THEN <<
    !-TRACEFLAG!* := T;
    IF !-EQUAL(!-TRACECOUNT!*,0) THEN <<
      !-STATE := !-ENTERPRI();
      !-PRIN2 "*** TRACECOUNT reached ***";
      !-EXITPRI !-STATE >> >>;
  IF NOT !-TRACEFLAG!* AND !-TRFLAGP(!-NAM,'TRACEWITHIN) THEN <<
    !-TRACEFLAG!* := !-LOCAL := T;
    !-STATE := !-ENTERPRI();
    !-LPRIM LIST("TRACECOUNT =",!-TRACECOUNT!*);
    !-EXITPRI !-STATE >>;
  IF TRACENTRYHOOK!* THEN
    !-FLG := !-ERRAPPLY(TRACENTRYHOOK!*,
			LIST(!-NAM,!-ARGS),
			'TRACENTRYHOOK)
  ELSE
    !-FLG := T;
  !-LEV := !-EVAL !-TRGET(!-NAM,'LEVELVAR);
  !-FLG := !-FLG AND !-TRACEFLAG!* AND !-TRFLAGP(!-NAM,'TRPRINT) AND
	   NOT(!-LESSP(!-LEV,TRACEMINLEVEL!*) OR
	       !-GREATERP(!-LEV,TRACEMAXLEVEL!*) );
  IF !-FLG AND !-TRFLAGP(!-NAM,'TRST) THEN
    !-BOD := !-TRGET(!-NAM,'TRSTFN) OR !-TRGET(!-NAM,'ORIGINALFN)
  ELSE
    !-BOD := !-TRGET(!-NAM,'ORIGINALFN);
  IF !-FLG THEN <<
    !-TRINDENT!* := !-ADD1 !-TRINDENT!*;
    !-OUTRACE(!-TRACENTRYPRI,!-NAM,!-ARGS,!-LEV,!-TRINDENT!*) >>;
  IF !*BTR THEN
    !-BTRTOP := !-BTRPUSH(!-NAM,!-ARGS);
  !-TYP := !-TRGET(!-NAM,'FNTYPE);
  IF NOT(!-TYP EQ 'EXPR) THEN
    !-ARGS := LIST CAR !-ARGS;
  IF !-TRFLAGP(!-NAM,'EMB) AND (!-EMB := !-TRGET(!-NAM,'EMBFN)) THEN
    !-VAL := !-APPLY(!-EMB,!-BOD . !-ARGS)
  ELSE
    !-VAL := !-APPLY(!-BOD,!-ARGS);
  IF !-TYP EQ 'MACRO THEN <<
    IF TRACEXPANDHOOK!* THEN
      !-ERRAPPLY(TRACEXPANDHOOK!*,
		 LIST(!-NAM,!-VAL),
		 'TRACEXPANDHOOK);
%    IF !-FLG THEN
%      !-OUTRACE(!-TRACEXPANDPRI,!-NAM,!-VAL,!-LEV,!-TRINDENT!*);
%    !-VAL := !-EVAL !-VAL
    >>;
  IF !*BTR THEN
    !-BTRPOP !-BTRTOP;
  IF !-FLG THEN
    !-OUTRACE(!-TRACEXITPRI,!-NAM,!-VAL,!-LEV,!-TRINDENT!*);
  IF !-LOCAL AND !-GREATERP(!-TRACECOUNT!*,0) THEN
    !-TRACEFLAG!* := NIL;
  IF TRACEXITHOOK!* THEN
    !-ERRAPPLY(TRACEXITHOOK!*,LIST(!-NAM,!-VAL),'TRACEXITHOOK);
  RETURN !-VAL
END !-TRACEDCALL;

SYMBOLIC PROCEDURE !-ERRAPPLY(!-FN,!-ARGS,!-NAM);
BEGIN SCALAR !-ANS,!-CHN;
  !-ANS := !-ERRORSET(LIST('!-APPLY,!-FN,!-ARGS),T,!*BACKTRACE);
  IF ATOM !-ANS THEN <<
    !-CHN := !-WRS MSGCHNL!*;
    !-PRIN2 "***** Error occured evaluating ";
    !-PRIN2 !-NAM;
    !-PRIN2 " *****";
    !-TERPRI();
    !-WRS !-CHN;
    RETURN !-ANS >>
  ELSE
    RETURN CAR !-ANS
END !-ERRAPPLY;

%************ Routines for printing trace information ***************

SYMBOLIC PROCEDURE TRACECOUNT N;
% Suppresses TRACE output until N traced function invocations have passed.
BEGIN
  SCALAR OLD;
  OLD:=!-TRACECOUNT!*;
  IF NUMBERP N THEN <<
    !-TRACECOUNT!*:=N;
    IF !-GREATERP(N,0) THEN
      !-TRACEFLAG!*:=NIL
    ELSE
      !-TRACEFLAG!*:=T >>;
  RETURN OLD
END;

!-FLAG('(TRACECOUNT),'OPFN);

SYMBOLIC PROCEDURE TRACEWITHIN L;
% L is a list of function names.  Forces tracing to be enabled within them.
<< !-TRFLAG(L,'TRACEWITHIN);
   IF NOT !-GREATERP(!-TRACECOUNT!*,0) THEN <<
     !-TRACECOUNT!*:=100000;
     !-TRACEFLAG!*:=NIL;
     !-LPRIM "TRACECOUNT set to 100000" >>;
   FOR EACH U IN L CONC
     IF !-TRINSTALL(U,NIL) THEN
       LIST U >>;

SYMBOLIC PROCEDURE TRACE L;
% Enables tracing on each function in the list L.
FOR EACH FN IN L CONC
  IF !-TRINSTALL(FN,NIL) THEN <<
    !-TRFLAG(LIST FN,'TRPRINT);
    If Not Memq (FN, TracedFns!*) then
       TracedFns!* := FN . TracedFns!*;
    LIST FN >>;

SYMBOLIC PROCEDURE UNTRACE L;
% Disables tracing for each function in the list L.
FOR EACH FN IN L CONC <<
  !-TRREMFLAG(LIST FN,'TRACEWITHIN);
  !-TRREMFLAG(LIST FN,'TRST);
  IF !-TRFLAGP(FN,'TRPRINT) THEN <<
    !-TRREMFLAG(LIST FN,'TRPRINT);
    FN >>
  ELSE <<
    !-LPRIM LIST("Function",FN,"was not traced.");
    NIL >> >>;

SYMBOLIC PROCEDURE !-ENTERPRI;
BEGIN SCALAR !-CHN,!-PSN;
  !-CHN := !-WRS MSGCHNL!*;
  !-PSN := !-POSN();
  IF !-GREATERP(!-PSN,0) THEN <<
    !-PRIN2 '!< ;
    !-TERPRI() >>;
  RETURN !-CHN . !-PSN
END !-ENTERPRI;

SYMBOLIC PROCEDURE !-EXITPRI !-STATE;
BEGIN SCALAR !-PSN;
  !-PSN := CDR !-STATE;
  IF !-GREATERP(!-PSN,0) THEN <<
    IF NOT !-LESSP(!-POSN(),!-PSN) THEN
      !-TERPRI();
    !-SPACES2 !-SUB1 !-PSN;
    !-PRIN2 '!> >>
  ELSE IF !-GREATERP(!-POSN(),0) THEN
    !-TERPRI();
  !-WRS CAR !-STATE
END;

SYMBOLIC PROCEDURE !-TRINDENT !-INDNT;
BEGIN SCALAR !-N;
  !-N := !-TIMES2(!-INDNT,!-INDENTDEPTH!*);
  IF NOT !-GREATERP(!-N,!-INDENTCUTOFF!*) THEN
    !-SPACES2 !-N
  ELSE <<
    !-SPACES2 !-INDENTCUTOFF!*;
    !-PRIN2 '!* >>
END !-TRINDENT;

SYMBOLIC PROCEDURE !-TRACEPRI1(!-NAM,!-LEV,!-INDNT);
<< !-TRINDENT !-INDNT;
   !-PRIN1 !-NAM;
   IF !-GREATERP(!-LEV,1) THEN <<
     !-PRIN2 " (level ";
     !-PRIN2 !-LEV;
     !-PRIN2 '!) >> >>;

SYMBOLIC PROCEDURE !-TRACENTRYPRI(!-NAM,!-ARGS,!-LEV,!-INDNT);
% Handles printing trace information at entry to a function.
!-TRACENTRYPRI1(!-NAM,!-ARGS,!-LEV,!-INDNT," being entered");

SYMBOLIC PROCEDURE !-TRACENTRYPRI1(!-NAM,!-ARGS,!-LEV,!-INDNT,!-S);
BEGIN SCALAR !-ARGNAMS;
  !-TRACEPRI1(!-NAM,!-LEV,!-INDNT);
  !-PRIN2 !-S;
  !-TERPRI();
  !-ARGNAMS := !-TRGET(!-NAM,'ARGNAMES);
  WHILE !-ARGS DO <<
    !-TRINDENT !-INDNT;
    !-SPACES !-ARGINDENT!*;
    IF !-ARGNAMS THEN <<
      !-PRIN2 CAR !-ARGNAMS;
      !-ARGNAMS := CDR !-ARGNAMS >>
    ELSE
      !-PRIN2 '!?!?!?!? ;
    !-PRIN2 ":	";
    APPLY(TRPRINTER!*,LIST CAR !-ARGS);
    !-ARGS := CDR !-ARGS;
    IF !-ARGS AND NOT !-POSN() = 0 THEN
      !-TERPRI() >>;
END !-TRACENTRYPRI;

SYMBOLIC PROCEDURE !-TRACEXPANDPRI(!-NAM,!-EXP,!-LEV,!-INDNT);
% Prints macro expansions.
<< !-TRACEPRI1(!-NAM,!-LEV,!-INDNT);
   !-PRIN2 " MACRO expansion = ";
   APPLY(TREXPRINTER!*,LIST !-EXP) >>;

SYMBOLIC PROCEDURE !-TRACEXITPRI(!-NAM,!-VAL,!-LEV,!-INDNT);
% Prints information upon exiting a function.
<< !-TRACEPRI1(!-NAM,!-LEV,!-INDNT);
   !-PRIN2 " = ";
   APPLY(TRPRINTER!*,LIST !-VAL) >>;

%*************** TRST functions ***********************************

SYMBOLIC PROCEDURE TRACESET L;
BEGIN SCALAR DFN;
  RETURN FOR EACH FN IN L CONC
    IF !-TRINSTALL(FN,NIL) THEN <<
      !-TRFLAG(LIST FN,'TRPRINT);
      If Not Memq (FN, TracedFns!*) then
         TracedFns!* := FN . TracedFns!*;
      DFN := !-TRGET(FN,'ORIGINALFN);
      IF CODEP DFN THEN <<
	!-LPRIM LIST("Function",FN,"is compiled.  It cannot be traceset.");
	NIL >>
      ELSE <<
	!-TRFLAG(LIST FN,'TRST);
        IF NOT !-TRGET(FN,'TRSTFN) THEN
	  !-TRPUT(FN,'TRSTFN,!-MKTRST DFN);
	LIST FN >> >>
END TRACESET;

SYMBOLIC PROCEDURE UNTRACESET L;
FOR EACH FN IN L CONC
  IF !-TRFLAGP(FN,'TRST) THEN <<
    !-TRREMFLAG(LIST FN,'TRST);
    LIST FN >>
  ELSE <<
    !-LPRIM LIST("Function",FN,"was not traceset.");
    NIL >>;

SYMBOLIC PROCEDURE !-TRSTPRI(!-NAM,!-VAL);
<< !-OUTRACE(!-TRSTPRI1,!-NAM,!-VAL,!-TRINDENT!*);
   !-VAL >>;

SYMBOLIC PROCEDURE !-TRSTPRI1(!-NAM,!-VAL,!-INDNT);
BEGIN SCALAR !-STATE;
  !-STATE := !-ENTERPRI();
  !-TRINDENT !-INDNT;
  !-PRIN2 !-NAM;
  !-PRIN2 " := ";
  APPLY(TRPRINTER!*,LIST !-VAL);
  !-EXITPRI !-STATE;
END !-TRSTPRI;

SYMBOLIC PROCEDURE !-MKTRST U;
BEGIN SCALAR V;
  IF ATOM U THEN
    RETURN U;
  IF !-FLAGP(CAR U,'TRSTINSIDE) THEN
    RETURN !-MKTRST1 U;
  IF V := !-GET(CAR U,'TRSTINSIDEFN) THEN
    RETURN APPLY(V,LIST U);
  IF IDP CAR U AND (V := !-GETD CAR U) THEN <<
    V := CAR V;
    IF V EQ 'FEXPR THEN
      RETURN U;
    IF V EQ 'MACRO THEN
      IF !*TRSTEXPANDMACROS THEN
	RETURN !-MKTRST APPLY(CAR U,LIST U)
      ELSE
	RETURN U >>;
  RETURN !-MKTRST1 U
END;

SYMBOLIC PROCEDURE !-MKTRST1 U;
FOR EACH V IN U COLLECT !-MKTRST V;

% Functions for TRSTing certain special functions

SYMBOLIC PROCEDURE !-TRSTSETQ U;
IF ATOM CDR U OR ATOM CDDR U THEN
  !-LPRIE LIST("Malformed expression",U)
ELSE
  LIST(CAR U,CADR U,LIST('!-TRSTPRI,!-MKQUOTE CADR U,!-MKTRST CADDR U));

symbolic procedure !-TrstCond u;
cons(car u,
    for each v in cdr u collect !-MkTrST1 v);

SYMBOLIC PROCEDURE !-TRSTPROG U;
IF ATOM CDR U THEN
  !-LPRIE LIST("Malformed expression",U)
ELSE
  CAR U . CADR U . !-MKTRST1 CDDR U;

%****************** Heavy handed backtrace routines *******************

SYMBOLIC PROCEDURE !-BTRPUSH(!-NAM,!-ARGS);
BEGIN SCALAR !-OSTK;
  !-OSTK := !-BTRSTK!*;
  !-BTRSTK!* := (!-NAM . !-ARGS) . !-OSTK;
  RETURN !-OSTK
END !-BTRPUSH;

SYMBOLIC PROCEDURE !-BTRPOP !-PTR;
BEGIN SCALAR !-A;
  IF !*BTRSAVE AND NOT(!-PTR EQ CDR !-BTRSTK!*) THEN <<
    WHILE !-BTRSTK!* AND NOT(!-PTR EQ !-BTRSTK!*) DO <<
      !-A := CAR !-BTRSTK!* . !-A;
      !-BTRSTK!* := CDR !-BTRSTK!* >>;
    IF NOT(!-PTR EQ !-BTRSTK!*) THEN <<
      !-TERPRI();
      !-PRIN2 "***** Internal error in DEBUG: BTR stack underflow *****";
      !-TERPRI() >>;
    !-BTRSAVEDINTERVALS!* := !-A . !-BTRSAVEDINTERVALS!* >>
  ELSE
    !-BTRSTK!* := !-PTR
END !-BTRPOP;

SYMBOLIC PROCEDURE !-BTRDUMP;
BEGIN SCALAR STK;
  STK := !-BTRSTK!*;
  IF NOT (!-POSN() = 0) THEN
    !-TERPRI();
  IF NULL STK AND NOT(!*BTRSAVE AND !-BTRSAVEDINTERVALS!*) THEN <<
    !-PRIN2T "*** No traced functions were left abnormally ***";
    RETURN >>;
  !-PRIN2T "*** Backtrace: ***";
  IF STK THEN <<
    !-PRIN2T "These functions were left abnormally:";
    REPEAT <<
      !-TRACENTRYPRI1(CAAR STK,CDAR STK,1,1,"");
      STK := CDR STK >>
    UNTIL NULL STK >>;
  IF !*BTRSAVE THEN
    FOR EACH U IN !-BTRSAVEDINTERVALS!* DO <<
      !-PRIN2T "These functions were left abnormally, but without";
      !-PRIN2T "returning to top level:";
      FOR EACH V IN U DO
	!-TRACENTRYPRI1(CAR V,CDR V,1,1,"") >>;
  !-PRIN2T "*** End of backtrace ***"
END !-BTRDUMP;

SYMBOLIC PROCEDURE BTRACE L;
<< !*BTR := T;
   !-BTRNEWSTK();
   FOR EACH U IN L CONC
     IF !-TRINSTALL(U,NIL) THEN LIST U >>;

SYMBOLIC PROCEDURE !-BTRNEWSTK;
!-BTRSTK!* := !-BTRSAVEDINTERVALS!* := NIL;

!-BTRNEWSTK();

PUT('BTR,'SIMPFG,'((NIL (!-BTRNEWSTK))(T (!-BTRNEWSTK))));

%********************* Embed functions ****************************

SYMBOLIC PROCEDURE !-EMBSUBST(NAM,FN,NEW);
IF ATOM FN OR CAR FN EQ 'QUOTE THEN
  FN
ELSE IF CAR FN EQ NAM THEN
  NEW . '!-ORIGINALFN!* . CDR FN
ELSE
  FOR EACH U IN FN COLLECT !-EMBSUBST(NAM,U,NEW);

SYMBOLIC MACRO PROCEDURE !-EMBCALL !-U;
LIST('!-APPLY,CADR !-U,'LIST . CDDR !-U);

SYMBOLIC PROCEDURE EMBFN(NAM,VARS,BOD);
BEGIN SCALAR EMBF;
  IF !*DEFN THEN << % For REDUCE;
    OUTDEF LIST('EMBFN,!-MKQUOTE NAM,!-MKQUOTE VARS,!-MKQUOTE BOD);
    RETURN >>;
  IF !-TRINSTALL(NAM,!-LENGTH VARS) THEN <<
    EMBF := !-TRGET(NAM,'EMBFN);
    EMBF := LIST('LAMBDA,
		   '!-ORIGINALFN!* . VARS,
		   !-EMBSUBST(NAM,BOD,IF EMBF THEN EMBF ELSE '!-EMBCALL) );
    !-TRPUT(NAM,'EMBFN,EMBF);
    !-TRFLAG(LIST NAM,'EMB);
    RETURN !-MKQUOTE NAM >>
END;

SYMBOLIC PROCEDURE EMBEDFNS U;
FOR EACH X IN U CONC
  IF !-TRGET(X,'EMBFN) THEN <<
    X := LIST X;
    !-TRFLAG(X,'EMB);
    X >>
  ELSE <<
    !-LPRIM LIST("Procedure",X,"has no EMB definition");
    NIL >>;

SYMBOLIC PROCEDURE UNEMBEDFNS U;
FOR EACH X IN U CONC
  IF !-TRFLAGP(X,'EMB) THEN <<
    X := LIST X;
    !-TRREMFLAG(X,'EMB);
    X >>;

%***************** Function call histogram routines *************

SYMBOLIC PROCEDURE !-HISTOGRAM;
% Simplistic histogram routine for number of function calls.
BEGIN INTEGER M,N,NM; SCALAR NAM,NMS,NEW;
  IF !-GETD 'TREESORT THEN % If REDIO is available
    !-INSTALLEDFNS!* := MSORT !-INSTALLEDFNS!*;
  !-TERPRI();
  !-TERPRI();
  N := 0;
  FOR EACH U IN !-INSTALLEDFNS!* DO
    IF !-GET(U,'TRACE) THEN <<
      N := !-MAX2(!-TRGET(U,'COUNTER),N);
      NEW := U . NEW >>;
  !-INSTALLEDFNS!* := NEW;
  N := FLOAT(LINELENGTH NIL - 21) / FLOAT N;
  FOR EACH U IN !-INSTALLEDFNS!* DO <<
    NAM :=  !-EXPLODE U;
    NM := !-TRGET(U,'COUNTER);
    NMS := !-EXPLODE NM;
    M := !-MIN2(LENGTH NAM,17-LENGTH NMS);
    FOR I := 1:M DO <<
      !-PRINC CAR NAM;
      NAM := CDR NAM >>;
    !-PRINC '!( ;
    WHILE NMS DO <<
      !-PRINC CAR NMS;
      NMS := CDR NMS >>;
    !-PRINC '!) ;
    !-SPACES2 20;
    FOR I := FIX(NM*N) STEP -1 UNTIL 1 DO
      !-PRINC '!* ;
    !-TERPRI() >>;
  !-TERPRI();
  !-TERPRI()
END !-HISTOGRAM;

SYMBOLIC PROCEDURE !-CLEARCOUNT;
BEGIN SCALAR NEWVAL;
  FOR EACH U IN !-INSTALLEDFNS!* DO
    IF !-GET(U,'TRACE) THEN <<
      !-TRPUT(U,'COUNTER,0);
      NEWVAL := U . NEWVAL >>;
  !-INSTALLEDFNS!* := NEWVAL
END !-CLEARCOUNT;

% SIMPFG so ON/OFF TRCOUNT will do a histogram

PUT('TRCOUNT,'SIMPFG,'((T (!-CLEARCOUNT)) (NIL (!-HISTOGRAM))));


%************************ TRACE related statements *********************

%SYMBOLIC PROCEDURE TRSTAT;
%% Nearly the same as RLIS2, but allows zero or more args rather than one or 
%% more.
%BEGIN SCALAR NAM,ARGS;
%  NAM := CURSYM!*;
%  IF FLAGP!*!*(SCAN(),'DELIM) THEN
%    RETURN LIST(NAM,NIL);
%  RETURN LOOP <<
%    ARGS := MKQUOTE CURSYM!* . ARGS;
%    IF FLAGP!*!*(SCAN(),'DELIM) THEN
%      EXIT LIST(NAM,'LIST . REVERSIP ARGS)
%    ELSE IF CURSYM!* NEQ '!*COMMA!* THEN
%      SYMERR("Syntax Error",NIL);
%    SCAN() >>
%END TRSTAT;

SYMBOLIC PROCEDURE !-TR1(L,FN);
BEGIN SCALAR X;
  !-SLOWLINKS();
  X := APPLY(FN,LIST L);
  IF !*MODE EQ 'ALGEBRAIC THEN << % For REDUCE;
    !-TERPRI();
    !-PRINT X >>
  ELSE
    RETURN X
END;

MACRO PROCEDURE TR U;
    LIST('EVTR, MKQUOTE CDR U);

SYMBOLIC PROCEDURE EVTR U;
IF U THEN
  !-TR1(U,'TRACE)
ELSE
  !-DUMPTRACEBUFF NIL;

MACRO PROCEDURE UNTR U;
    LIST('EVUNTR, MKQUOTE CDR U);

procedure UnTrAll();
    <<EvUnTr TracedFns!*;
      TracedFns!* := Nil>>;

SYMBOLIC PROCEDURE EVUNTR U;
BEGIN SCALAR L;
IF U THEN
  <<!-TR1(U,'UNTRACE);
    Foreach L in U do
       TracedFns!*:=DelQ(L,TracedFns!*)>>
ELSE <<
  !-TRACEFLAG!* := NIL;
  !-LPRIM "TRACECOUNT set to 10000";
  !-TRACECOUNT!* := 10000 >>;
END;

MACRO PROCEDURE RESTR U;
  LIST ('EVRESTR, MKQUOTE CDR U);

SYMBOLIC PROCEDURE EVRESTR U;
BEGIN SCALAR L;
   IF U THEN
      <<FOR EACH L IN U DO
          !-TRRESTORE L;
        !-INSTALLEDFNS!* := DELQ (L,!-INSTALLEDFNS!*);
        TRACEDFNS!* := DELQ (L,TRACEDFNS!*)>>
   ELSE
      << FOR EACH U IN !-INSTALLEDFNS!* DO
           !-TRRESTORE U;
         !-INSTALLEDFNS!* := NIL;
         TRACEDFNS!* := NIL>>;
END;

MACRO PROCEDURE TRIN U;
    LIST('EVTRIN, MKQUOTE CDR U);

SYMBOLIC PROCEDURE EVTRIN U; !-TR1(U,'TRACEWITHIN);

MACRO PROCEDURE TRST U;
    LIST('EVTRST, MKQUOTE CDR U);

SYMBOLIC PROCEDURE EVTRST U; !-TR1(U,'TRACESET);

MACRO PROCEDURE UNTRST U;
    LIST('EVUNTRST, MKQUOTE CDR U);

SYMBOLIC PROCEDURE EVUNTRST U; !-TR1(U,'UNTRACESET);

MACRO PROCEDURE BTR U;
    LIST('EVBTR, MKQUOTE CDR U);

SYMBOLIC PROCEDURE EVBTR U;
IF U THEN
  !-TR1(U,'BTRACE)
ELSE
  !-BTRDUMP();

SYMBOLIC PROCEDURE RESBTR; !-BTRNEWSTK();

MACRO PROCEDURE EMBED U;
    LIST('EVEMBED, MKQUOTE CDR U);

SYMBOLIC PROCEDURE EVEMBED U; !-TR1(U,'EMBEDFNS);

MACRO PROCEDURE UNEMBED U;
    LIST('EVUNEMBED, MKQUOTE CDR U);

SYMBOLIC PROCEDURE EVUNEMBED U; !-TR1(U,'UNEMBEDFNS);

MACRO PROCEDURE TRCNT U;
    LIST('EVTRCNT, MKQUOTE CDR U);

SYMBOLIC PROCEDURE EVTRCNT U; !-TR1(U,'!-TRINSTALLIST);

IF NOT FUNBOUNDP 'DEFINEROP THEN <<
RLISTAT('(TR UNTR TRIN TRST UNTRST BTR
	EMBED UNEMBED TRCNT RESTR FSTUB STUB PLIST PPF), 'NOQUOTE);
RLISTAT('(TROUT), 'NOQUOTE);
DEFINEROP('RESBTR,NIL,ESTAT('RESBTR));
DEFINEROP('STDTRACE,NIL,ESTAT('STDTRACE));
>>;

%DEFLIST('(
%  (TR TRSTAT)
%  (UNTR RLIS2)
%  (TRIN RLIS2)
%  (TRST RLIS2)
%  (UNTRST RLIS2)
%  (BTR TRSTAT)
%  (EMBED RLIS2)
%  (UNEMBED RLIS2)
%  (TRCNT RLIS2)
%  (RESBTR ENDSTAT)
%  (RESTR RLIS2)
%  (STDTRACE ENDSTAT)
%  (TROUT IOSTAT)
%         ), 'STAT);

FLAG('(TR UNTR BTR),'GO);

FLAG('(TR TRIN UNTR TRST UNTRST BTR EMBED UNEMBED RESBTR RESTR TRCNT 
       TROUT STDTRACE),
     'IGNORE);

%******************Break Functions***********************************

fluid '(ArgLst!*			% Default names for args in traced code
	TrSpace!*			% Number spaces to indent
	!*NoTrArgs			% Control arg-trace
);

CompileTime flag('(TrMakeArgList), 'InternalFunction);

lisp procedure TrMakeArgList N;		% Get Arglist for N args
    cdr Assoc(N, ArgLst!*);
LoadTime
<<  ArgLst!* := '((0 . ())
		  (1 . (X1))
		  (2 . (X1 X2))
		  (3 . (X1 X2 X3))
		  (4 . (X1 X2 X3 X4))
		  (5 . (X1 X2 X3 X4 X5))
		  (6 . (X1 X2 X3 X4 X5 X6))
		  (7 . (X1 X2 X3 X4 X5 X6 X7))
		  (8 . (X1 X2 X3 X4 X5 X6 X7 X8))
		  (9 . (X1 X2 X3 X4 X5 X6 X7 X8 X9))
		  (10 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10))
		  (11 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11))
		  (12 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12))
		  (13 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13))
		  (14 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14))
		  (15 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15)));
    TrSpace!* := 0;
    !*NoTrArgs := NIL >>;

Fluid '(ErrorForm!* !*ContinuableError);

lisp procedure Br!.Prc(PN, B, A); 	% Called in place of "Broken" code
%
% Called by BREAKFN for proc nam PN, body B, args A;
%
begin scalar K, SvArgs, VV, Numb, Result;
    TrSpace!* := TrSpace!* + 1;
    Numb := Min(TrSpace!*, 15);
    Tab Numb;
    PrintF("%p %w:", PN, TrSpace!*);
    if not !*NoTrArgs then
    <<  SvArgs := A;
	K := 1;
	while SvArgs do
	<<  PrintF(" Arg%w:=%p, ", K, car SvArgs);
	    SvArgs := cdr SvArgs;
	    K := K + 1 >> >>;
    TerPri();
    ErrorForm!* := NIL;
    PrintF(" BREAK before entering %r%n",PN);
    !*ContinuableError:=T;
    Break();
    VV := Apply(B, A);
    PrintF(" BREAK after call %r, value %r%n",PN,VV);
    ErrorForm!* := MkQuote VV;
    !*ContinuableError:=T;
    Result:=Break();
    Tab Numb;
    PrintF("%p %w:=%p%n", PN, TrSpace!*, Result);
    TrSpace!* := TrSpace!* - 1;
    return Result
end;

fluid '(!*Comp PromptString!*);

lisp procedure Br!.1 Nam; 		% Called To Break a single function
begin scalar PN, X, Y, Bod, Args, N, OldIn, OldPrompt, !*Comp;
    if not (Y:=GetD Nam) then
    <<  ErrorPrintF("*** %r is not a defined function and cannot be BROKEN",
			Nam);
	return >>;
    if Memq (Nam,TracedFns!*) or Memq (Nam,!-InstalledFns!*) then
        <<!-TrRestore Nam;
          Y:=GetD Nam;
          !-InstalledFns!*:=DelQ(Nam,!-InstalledFns!*);
          TracedFns!*:=DelQ(Nam,TracedFns!*)>>;
    if Not Memq (Nam,BrokenFns!*) then
        BrokenFns!*:=Cons(Nam, BrokenFns!*);
    PN := GenSym();
    !-!-PutD(PN, car Y, cdr Y);
    put(Nam, 'OldCod, Y . get(Nam, 'OldCod));
    if EqCar(cdr Y, 'LAMBDA) then
       Args := cadr cdr Y
    else if (N:=Code!-Number!-Of!-Arguments Cdr Y) then
       Args := TrMakeArgList N
    else
    <<  OldPrompt := PromptString!*;
	PromptString!* := BldMsg("How many arguments for %r?", Nam);
	OldIn := RDS NIL;
	while not NumberP(N := Read()) or N < 0 or N > 15 do ;
	PromptString!* := OldPrompt;
	RDS OldIn;
	Args := TrMakeArgList N >>;
    Bod:= list('LAMBDA, Args,
			list('Br!.prc, MkQuote Nam,
				       MkQuote PN, 'LIST . Args));
    !-!-PutD(Nam, car Y, Bod);
    put(Nam, 'BreakCode, cdr GetD Nam);
end;

lisp procedure UnBr!.1 Nam;
begin scalar X, Y, !*Comp;
   if not IDP Nam or not PairP(X := get(Nam, 'OldCod))
	    or not PairP(Y := GetD Nam)
	    or not (cdr Y eq get(Nam, 'BreakCode)) then
    <<  ErrorPrintF("*** %r cannot be unbroken", Nam);
	return >>;
    !-!-PutD(Nam, caar X, cdar X);
    RemProp(Nam, 'OldCod);
    RemProp(Nam, 'Breakcode);
    BrokenFns!*:=DelQ(Nam,BrokenFns!*);
end;

macro procedure Br L;			%. Break functions in L
    list('EvBr, MkQuote cdr L);

expr procedure EvBr L;
    Begin;
      for each X in L do Br!.1 X;
      Return L
    end;

macro procedure UnBr L;			%. Unbreak functions in L
    list('EvUnBr, MkQuote cdr L);

expr procedure EvUnBr L;
    for each X in L do UnBr!.1 X;

expr procedure UnBrAll();
    <<EvUnBr BrokenFns!*;
      BrokenFns!* := Nil>>;

%************************ Stubs *************************************

% These procedures implement  stubs for Rlisp/Reduce.   Usage is  "STUB
% <model   function   invocation>   [,<model   function   invocation>]*
% <semicol>".  For example,  to declare function  FOO, BAR, and  BLETCH
% with formal parameters X,Y,Z for FOO, U for BAR, and none for  BLETCH
% do "STUB FOO(X,Y,Z),BAR U,  BLETCH();".  When a  stub is executed  it
% announces its invocation,  prettyprints its arguments,  and asks  for
% the value to return.  Fexpr stubs may be declared with the  analogous
% statement FSTUB.

MACRO PROCEDURE STUB U;
    LIST('EVSTUB, MKQUOTE CDR U);

SYMBOLIC PROCEDURE EVSTUB FNLIS;
FOR EACH Y IN FNLIS DO
  IF NOT PAIRP Y THEN
    IF NOT IDP Y THEN
      !-LPRIE "Function name must be an ID"
    ELSE <<
      !-LPRIM LIST("Stub",Y,"declared as a function of zero arguments");
      !-MKSTUB(Y,NIL,'EXPR) >>
  ELSE IF NOT IDP CAR Y THEN
    !-LPRIE "Function name must be an ID"
  ELSE IF NOT !-IDLISTP CDR Y THEN
    !-LPRIE "Formal parameter must be an ID"
  ELSE
    !-MKSTUB(CAR Y,CDR Y,'EXPR);

MACRO PROCEDURE FSTUB U;
    LIST('EVFSTUB, MKQUOTE CDR U);

SYMBOLIC PROCEDURE EVFSTUB FNLIS;
FOR EACH Y IN FNLIS DO
   IF NOT PAIRP Y THEN
      !-LPRIE "Arguments to FSTUB must be model function calls"
   ELSE IF NOT IDP CAR Y THEN
      !-LPRIE "Function name must be an ID"
   ELSE IF NOT !-IDLISTP CDR Y THEN
      !-LPRIE "Formal parameter must be an ID"
   ELSE IF !-LENGTH CDR Y NEQ 1 THEN
      !-LPRIE "An FEXPR must have exactly one formal parameter"
   ELSE
      !-MKSTUB(CAR Y, CDR Y, 'FEXPR);


SYMBOLIC PROCEDURE !-MKSTUB(NAME, VARLIS, TYPE);
PUTD(NAME,
     TYPE,
     LIST('LAMBDA,
	  VARLIS,
	  LIST('!-STUB1,
	       !-MKQUOTE NAME,
	       !-MKQUOTE VARLIS,
	       'LIST . VARLIS,
	       !-MKQUOTE TYPE) ) );

SYMBOLIC PROCEDURE !-STUB1(!-PNAME, !-ANAMES, !-AVALS, !-TYPE);
% Weird variable names because of call to EVAL.
BEGIN INTEGER !-I;
   IF !-TYPE NEQ 'EXPR THEN
      !-PRIN2 !-TYPE;
   !-PRIN2 " Stub ";
   !-PRIN2 !-PNAME;
   !-PRIN2 " called";
   !-TERPRI();
   !-TERPRI();
   !-I := 1;
   FOR EACH !-U IN PAIR(!-PAD(!-ANAMES,!-LENGTH !-AVALS),!-AVALS) DO <<
      IF CAR !-U THEN
	 !-PRIN2 CAR !-U
      ELSE <<
	 !-SET(!-INTERN !-COMPRESS !-APPEND('(A R G),!-EXPLODE !-I),
	     CDR !-U);
	 !-PRIN2 "Arg #";
	 !-PRIN2 !-I >>;
      !-PRIN2 ": ";
      APPLY(STUBPRINTER!*, LIST CDR !-U);
      !-I := !-I + 1 >>;
   !-PRIN2T "Return? :";
   RETURN !-EVAL APPLY(STUBREADER!*,NIL)
END;

SYMBOLIC PROCEDURE !-REDREADER;
XREAD NIL;

%*************** Functions for printing useful information *************

MACRO PROCEDURE PLIST U;
    LIST('EVPLIST, MKQUOTE CDR U);

SYMBOLIC PROCEDURE EVPLIST U;
% Prints the  property	list and  flags  of  U in  a  descent  format,
% prettyprinting nasty	things.   Does	not print  properties  in  the
% global list !-INVISIBLEPROPS!* or flags in !-INVISIBLEFLAGS!*.  Usage is
% "PLIST <id> [,<id>]* <semicol>".
<< !-TERPRI();
   FOR EACH V IN U CONC
     IF V := !-PLIST1 V THEN
       LIST V >>;


SYMBOLIC PROCEDURE !-PLIST1 U;
BEGIN SCALAR PLST,FLGS,HASPROPS;
  !-TERPRI();
  IF NOT IDP U THEN <<
    !-LPRIE LIST(U,"is not an ID");
    RETURN NIL >>;
  PLST := !-GETPROPERTYLIST U; % System dependent kludge
  FOR EACH V IN PLST DO
    IF ATOM V AND NOT !-MEMQ(V,!-INVISIBLEFLAGS!*) THEN
      FLGS := V . FLGS
    ELSE IF NOT !-MEMQ(CAR V,!-INVISIBLEPROPS!*) THEN <<
      IF NOT HASPROPS THEN <<
	HASPROPS := T;
	!-PRIN2 "Properties for ";
	!-PRIN1 U;
	!-PRIN2T ":";
	!-TERPRI() >>;
      !-SPACES 4;
      !-PRIN1 CAR V;
      !-PRIN2 ":";
      !-SPACES 2;
      !-SPACES2 15;
      APPLY(PROPERTYPRINTER!*,LIST CDR V) >>;
  IF FLGS THEN <<
    IF HASPROPS THEN
      !-PRIN2 "Flags:  "
    ELSE <<
      !-PRIN2 "Flags for ";
      !-PRIN1 U;
      !-PRIN2 ":	" >>;
    FOR EACH V IN FLGS DO <<
      !-PRIN1 V;
      !-SPACES 1 >>;
    !-TERPRI();
    !-TERPRI() >>
  ELSE IF NOT HASPROPS THEN <<
    !-PRIN2 "No Flags or Properties for ";
    !-PRINT U;
    !-TERPRI() >>;
  IF HASPROPS OR FLGS THEN
    RETURN U
END !-PLIST1;

MACRO PROCEDURE PPF U;
    LIST('EVPPF, MKQUOTE CDR U);

SYMBOLIC PROCEDURE EVPPF FLIS; 
% Pretty prints one or more function definitions, from their
% names.  Usage is "PPF <name> [,<name>]* <semicol>".
<< !-TERPRI();
   FOR EACH FN IN FLIS CONC
     IF FN := !-PPF1 FN THEN
       LIST FN >>;

SYMBOLIC PROCEDURE !-PPF1 FN;
BEGIN SCALAR BOD,TYP,ARGS,TRC,FLGS;
  IF !-GET(FN,'TRACE) THEN <<
    BOD := !-TRGET(FN,'ORIGINALFN);
    IF NOT CODEP BOD THEN
      BOD := CADDR BOD;
    TYP := !-TRGET(FN,'FNTYPE);
    IF NOT !-TRFLAGP(FN,'UNKNOWNARGS) THEN 
      ARGS := !-TRGET(FN,'ARGNAMES);
    IF !-TRFLAGP(FN,'TRST) THEN
      TRC := 'TraceSet . TRC
    ELSE IF !-TRFLAGP(FN,'TRPRINT) THEN
      TRC := 'Traced . TRC;
    IF !-TRFLAGP(FN,'TRACEWITHIN) THEN
      TRC := 'TracedWithin . TRC;
    IF !-TRFLAGP(FN,'EMB) THEN
      TRC := 'Embeded . TRC;
    IF NULL TRC THEN
      TRC := '(Installed) >>
  ELSE IF BOD := !-GETC FN THEN <<
    TYP := CAR BOD;
    BOD := CDR BOD;
    IF NOT CODEP BOD THEN <<
      ARGS := CADR BOD;
      BOD := CDDR BOD >> >>
  ELSE <<
    !-LPRIE LIST("Procedure",FN,"is not defined.");
    RETURN NIL >>;
  FOR EACH U IN !-FUNCTIONFLAGS!* DO
    IF !-FLAGP(FN,U) THEN
      FLGS := U . FLGS;
  IF NOT (!-POSN() = 0) THEN
    !-TERPRI();
  !-TERPRI();
  !-PRIN2 TYP;
  !-PRIN2 " procedure ";
  !-PRIN1 FN;
  IF ARGS THEN <<
    !-PRIN2 '!( ;
    FOR EACH U ON ARGS DO <<
      !-PRIN1 CAR U;
      IF CDR U THEN
	!-PRIN2 '!, >>;
    !-PRIN2 '!) >>;
  IF TRC OR FLGS THEN <<
    !-PRIN2 " [";
    FOR EACH U IN !-REVERSIP TRC DO <<
      !-PRIN2 U;
      !-PRIN2 '!; >>;
    IF TRC THEN <<
      !-PRIN2 "Invoked ";
      !-PRIN2 !-TRGET(FN,'COUNTER);
      !-PRIN2 " times";
      IF FLGS THEN
	!-PRIN2 '!; >>;
    IF FLGS THEN <<
      !-PRIN2 "Flagged: ";
      FOR EACH U ON FLGS DO <<
	!-PRIN1 CAR U;
	IF CDR U THEN
	  !-PRIN2 '!, >> >>;
    !-PRIN2 '!] >>;
  IF CODEP BOD THEN <<
    !-PRIN2 " is compiled (";
    !-PRIN2 BOD;
    !-PRIN2T ")." >>
  ELSE <<
    !-PRIN2T '!: ;
    FOR EACH FORM IN BOD DO APPLY(PPFPRINTER!*,LIST FORM);
    !-TERPRI() >>;
  RETURN FN  
END !-PPF1;


SYMBOLIC PROCEDURE !-GETC U;
% Like GETD,  but  also  looks for  non-standard  functions,  such  as
% SMACROs.  The only non-standard functions looked for are those whose
% tags appear in the list NONSTANDARDFNS!*.
BEGIN SCALAR X,Y;
  X := !-NONSTANDARDFNS!*;
  Y := !-GETD U;
  WHILE X AND NOT Y DO <<
    Y := !-GET(U,CAR X);
    IF Y THEN
      Y := CAR X . Y;
    X := CDR X >>;
  RETURN Y
END !-GETC;

FLAG('(PPF PLIST), 'IGNORE);

END;