Artifact df6c762d15746d3eb9f30c27fb2fcf513a914e43d4ab7c2303209502195bf72a:

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

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

%
% PROG-AND-FRIENDS.RED - PROG, GO, and RETURN
% 
% Author:      Eric Benson
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        20 August 1981
% Copyright (c) 1981 University of Utah
%

%  <PSL.KERNEL>PROG-AND-FRIENDS.RED.2, 11-Oct-82 17:55:57, Edit by BENSON
%  Changed CATCH/THROW to *CATCH/*THROW

% Error numbers:
% 3000 - Unknown label
% 3100 - outside the scope of a PROG
% +1 in GO
% +2 in RETURN

fluid '(ProgJumpTable!*			% A-List of labels and expressions
	ProgBody!*);			% Tail of the current PROG

fexpr procedure Prog ProgBody!*;	%. Program feature function
begin scalar ProgJumpTable!*, N, Result;
    if not PairP ProgBody!* then return NIL;
    N := 0;
    for each X in car ProgBody!* do
    <<  PBind1 X;
	N := N + 1 >>;
    ProgBody!* := cdr ProgBody!*;
    for each X on ProgBody!* do
	if IDP car X then
	    ProgJumpTable!* := X . ProgJumpTable!*;
    while << while PairP ProgBody!* and IDP car ProgBody!* do
		ProgBody!* := cdr ProgBody!*;	% skip over labels
	     PairP ProgBody!* >> do	% eval the expression
    <<  Result := !*Catch('!$Prog!$, Eval car ProgBody!*);
	if not ThrowSignal!* then
	<<  Result := NIL;
	    ProgBody!* := cdr ProgBody!* >> >>;
    UnBindN N;
    return Result;
end;

lisp fexpr procedure GO U;		%. Goto label within PROG
begin scalar NewProgBody;
    return if ProgBody!* then
    <<  NewProgBody := Atsoc(car U, ProgJumpTable!*);
	if null NewProgBody then
	    ContinuableError(3001,
			     BldMsg(
		"%r is not a label within the current scope", car U),
			     'GO . U)
	else
	<<  ProgBody!* := NewProgBody;
	    !*Throw('!$Prog!$, NIL) >> >>
    else ContinuableError(3101,
			  "GO attempted outside the scope of a PROG",
			  'GO . U);
end;

lisp procedure Return U;		%. Return value from PROG
    if ProgBody!* then
    <<  ProgBody!* := NIL;
	!*Throw('!$Prog!$, U) >>
    else ContError(3102, "RETURN attempted outside the scope of a PROG",
			Return U);

END;