Artifact 01ad24d69a596f9087865a36f70c28720398085e10e74b219c61730b411ab4ac:

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

%
% CATCH-THROW.RED - Common Lisp dynamic non-local exits
% 
% Author:      Eric Benson
%              Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        12 October 1982
% Copyright (c) 1982 University of Utah
%

% Edit by Cris Perdue, 23 Feb 1983 1624-PST
% Modified the stack overflow warning message
% Edit by Cris Perdue, 16 Feb 1983 1032-PST
% Changed catch stack overflow checking to give a continuable error
%  when stack gets low, Reset when all out.
% Edit by Cris Perdue,  4 Feb 1983 1209-PST
% Moved ERRSET to ERROR-ERRORSET from here.
% Edit by Cris Perdue,  3 Feb 1983 1520-PST
% Changed catch stack overflow to talk about the CATCH stack. (!)
% Deleted definition of "errset".
%  <PSL.KERNEL>CATCH-THROW.RED.13, 21-Dec-82 15:55:26, Edit by BENSON
%  Added %clear-catch-stack
%  <PSL.KERNEL>CATCH-THROW.RED.13, 16-Dec-82 09:58:59, Edit by BENSON
%  Error not within ErrorSet now causes fatal error, not infinite loop


fluid '(ThrowSignal!*
	EMSG!*
	ThrowTag!*);

macro procedure catch!-all u;
(lambda(fn, forms);
    list(list('lambda, '(!&!&Value!&!&),
		   list('cond, list('ThrowSignal!*,
				    list('Apply,
					 fn,
					 '(list ThrowTag!* !&!&Value!&!&))),
			       '(t !&!&Value!&!&))),
	 'catch . nil . forms))(cadr U, cddr U);

macro procedure unwind!-all u;
(lambda(fn, forms);
    list(list('lambda, '(!&!&Value!&!&),
		   list('Apply,
			fn,
			'(list (and ThrowSignal!* ThrowTag!*)
			       !&!&Value!&!&))),
	 'catch . nil . forms))(cadr U, cddr U);

macro procedure unwind!-protect u;
(lambda(protected_form, cleanup_forms);
    list(list('lambda, '(!&!&Value!&!&),
		   list('lambda, '(!&!&Thrown!&!& !&!&Tag!&!&),
				  'progn . cleanup_forms,
				  '(cond (!&!&Thrown!&!&
					  (!%Throw !&!&Tag!&!& !&!&Value!&!&))
					 (t !&!&Value!&!&)))
		   . '(ThrowSignal!* ThrowTag!*)),
	 list('catch, ''!$unwind!-protect!$, protected_form)))(cadr U,cddr U);

off R2I;

% This funny definition is due to a PA1FN for CATCH

fexpr procedure Catch U;
(lambda(Tag, Forms);
    Catch(Eval Tag, EvProgN Forms))(car U, cdr U);

on R2I;

% Temporary compatibility package.

macro procedure !*Catch U;
    'Catch . cdr U;

expr procedure !*Throw(x,y);
    throw(x,y);

on Syslisp;

% Size is in terms of number of frames
internal WConst CatchStackSize = 400;

internal WArray CatchStack[CatchStackSize*4];

internal WVar CatchStackPtr = &CatchStack[0];

CompileTime <<

smacro procedure CatchPop();
    CatchStackPtr := &CatchStackPtr[-4];

smacro procedure CatchStackDecrement X;
    &X[-4];

% Rather large for a smacro, used only from CatchSetupAux /csp
% Tests structured for fast usual execution /csp
% Random constant 5 for "reserve" catch stack frames /csp
smacro procedure CatchPush(Tag, PC, SP, Env);
<<  CatchStackPtr := &CatchStackPtr[4];
    if CatchStackPtr >= &CatchStack[(CatchStackSize-5)*4] then
    <<  if CatchStackPtr = &CatchStack[(CatchStackSize-5)*4] then
	    ContinuableError(99,"Catch-throw stack overflow (warning)", NIL);
	if CatchStackPtr >= &CatchStack[CatchStackSize*4] then
	<<  (LispVar EMSG!*) := "Catch stack overflow";
	    reset() >> >>;
    CatchStackPtr[0] := Tag;
    CatchStackPtr[1] := PC;
    CatchStackPtr[2] := SP;
    CatchStackPtr[3] := Env >>;

smacro procedure CatchTopTag();
    CatchStackPtr[0];

smacro procedure CatchTagAt X;
    X[0];

smacro procedure CatchTopPC();
    CatchStackPtr[1];

smacro procedure CatchTopSP();
    CatchStackPtr[2];

smacro procedure CatchTopEnv();
    CatchStackPtr[3];

flag('(CatchSetupAux ThrowAux FindCatchMarkAndThrow), 'InternalFunction);

>>;

% CatchSetup puts the return address in reg 2, the stack pointer in reg 3
% and calls CatchSetupAux

lap '((!*entry CatchSetup expr 1)	%. CatchSetup(Tag)
      (!*MOVE (MEMORY (reg st) (WConst 0)) (reg 2))
      (!*MOVE (reg st) (reg 3))
      (!*JCALL CatchSetupAux)
);

syslsp procedure CatchSetupAux(Tag, PC, SP);
begin scalar Previous;
    Previous := CatchStackPtr;
    CatchPush(Tag, PC, SP, CaptureEnvironment());
    LispVar ThrowSignal!* := NIL;
    return Previous;
end;

syslsp procedure !%UnCatch Previous;
<<  CatchStackPtr := Previous;
    LispVar ThrowSignal!* := NIL >>;

syslsp procedure !%clear!-catch!-stack();
    CatchStackPtr := &CatchStack[0];

syslsp procedure !%Throw(Tag, Value);
begin scalar TopTag;
    TopTag := CatchTopTag();
    return if not (null TopTag
		       or TopTag eq '!$unwind!-protect!$
		       or Tag eq TopTag) then
    <<  CatchPop();
	!%Throw(Tag, Value) >>
    else begin scalar PC, SP;
	PC := CatchTopPC();
	SP := CatchTopSP();
	RestoreEnvironment CatchTopEnv();
	CatchPop();
	LispVar ThrowSignal!* := T;
	LispVar ThrowTag!* := Tag;
	return ThrowAux(Value, PC, SP);
    end;
end;

lap '((!*entry ThrowAux expr 3)
      (!*MOVE (reg 3) (reg st))
      (!*MOVE (reg 2) (MEMORY (reg st) (WConst 0)))
      (!*EXIT 0)
);

syslsp procedure Throw(Tag, Value);
    FindCatchMarkAndThrow(Tag, Value, CatchStackPtr);

% Throw to $Error$ that doesn't have a catch can't cause a normal error
% else an infinite loop will result.  Changed to use FatalError instead.

syslsp procedure FindCatchMarkAndThrow(Tag, Value, P);
    if P = &CatchStack[0] then
	if not (Tag eq '!$Error!$) then
	ContError(99,
		  "Catch tag %r not found in Throw",
		  Tag,
		  Throw(Tag, Value))
	else FatalError "Error not within ErrorSet"
    else if null CatchTagAt P or Tag eq CatchTagAt P then
	!%Throw(Tag, Value)
    else FindCatchMarkAndThrow(Tag, Value, CatchStackDecrement P);

off Syslisp;

END;