Artifact 970f71f38a29bdf6f045c825fc507dce0c63ecbb62a75a1567f1e7d85f7ca4b5:

• File psl-1983/3-1/kernel/backtrace.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: 2134) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/kernel/backtrace.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: 2134) [annotate] [blame] [check-ins using]

%  <PSL.KERNEL>BACKTRACE.RED.3, 20-Sep-82 10:21:41, Edit by BENSON
%  Attempt to make output easier to read

CompileTime flag('(Backtrace1 BacktraceRange), 'InternalFunction);

fluid '(IgnoredInBacktrace!* Options!* InterpreterFunctions!*);

IgnoredInBacktrace!* := '(Eval Apply FastApply CodeApply CodeEvalApply
    			  Catch ErrorSet EvProgN TopLoop BreakEval
			  BindEval
			  Break Main);

InterpreterFunctions!* := '(Cond Prog And Or ProgN SetQ);

on SysLisp;

external WVar StackLowerBound, HeapUpperBound;

syslsp procedure InterpBacktrace();
begin scalar Here;
    Here := &Here;
    PrintF "Backtrace, including interpreter functions, from top of stack:%n";
    return BacktraceRange(Here, StackLowerBound, 1);
end;

syslsp procedure Backtrace();
begin scalar Here, X;
    Here := &Here;
    PrintF "Backtrace from top of stack:%n";
    return BacktraceRange(Here, StackLowerBound, 0);
end;

syslsp procedure BacktraceRange(Starting, Ending, InterpFlag);
begin scalar X;
    for I := Starting step -(AddressingUnitsPerItem*StackDirection)
		until Ending do
	if Tag @I eq BtrTag then
	    Backtrace1(MkID Inf @I, InterpFlag)
	else if (X := ReturnAddressP @I) then
	    Backtrace1(X, InterpFlag);
    return TerPri();
end;

syslsp procedure VerboseBacktrace();
begin scalar Here, X;
    if not 'addr2id member options!* then load addr2id;
    Here := &Here;			% start a little before here
    for I := Here step -(AddressingUnitsPerItem*StackDirection)
		until StackLowerBound do
	if CodeP @I and Inf @I > HeapUpperBound then
	<<  WriteChar char TAB;
	    ChannelWriteUnknownItem(LispVar OUT!*, @I);
	    TerPri() >>
	else if Tag @I eq BtrTag then
	    PrintF("	%r%n", MkID Inf @I)
	else if (X := ReturnAddressP @I) then
	    PrintF("%p -> %p:%n", code!-address!-to!-symbol Inf @I, X)
	else PrintF("	%p%n", @I);
    return TerPri();
end;

off SysLisp;

lisp procedure Backtrace1(Item, Code);
%
% Code is 1 if Interpreter functions should be printed, 0 if not.
%
    if not (Item memq IgnoredInBacktrace!*) then
	if not (Code = 0 and Item memq InterpreterFunctions!*) then
	<<  Prin1 Item;
	    WriteChar char BLANK >>;

END;