Artifact e9e3eff7a0b35be2f86ee6779f574426bd5c6e9e59c8d2e39b5cb7f25c8e8a5a:

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

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

%
% LISP-MACROS.RED - Various macros to make pure Lisp more tolerable
% 
% Author:      Eric Benson
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        5 October 1981
% Copyright (c) 1981 University of Utah
%

%  <PSL.INTERP>LISP-MACROS.RED.4, 22-Jul-82 10:51:11, Edit by BENSON
%  Added CASE, removed IF
% still to come: Do, Let
%  <PSL.INTERP>LISP-MACROS.RED.5, 28-Dec-81 14:43:39, Edit by BENSON
%  Added SetF

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

% Not a macro, but it belongs with these

SYMBOLIC FEXPR PROCEDURE CASE U;
%U is of form (CASE <integer exp> (<case-1> <exp-1>) . . .(<case-n> <exp-n>)).
% If <case-i> is NIL it is default,
%   else is list of INT or (RANGE int int)
 BEGIN SCALAR CaseExpr,DEF,CaseLst,BOD;
	CaseExpr:=EVAL CAR U;
  L:	IF NOT PAIRP(U:=CDR U) THEN RETURN EVAL DEF;
	CaseLst:=CAAR U; BOD:=CADAR U;
	IF NOT PAIRP CaseLst
	    OR CAR CaseLst MEMQ '(OTHERWISE DEFAULT) THEN
	  <<DEF:=BOD; GOTO L>>;
	IF InThisCase(CaseExpr,CaseLst) THEN RETURN EVAL BOD;
	GOTO L
  END;

SYMBOLIC PROCEDURE InThisCase(CaseExpr,Cases);
 IF NOT PAIRP Cases Then NIL
  ELSE IF PAIRP Car Cases and Caar Cases EQ 'RANGE
   and CaseExpr>=Cadar Cases and CaseExpr<=Caddar Cases then T
  ELSE IF CaseExpr = Car Cases then T
  ELSE InThisCase(CaseExpr,Cdr Cases);


macro procedure SetF U;			%. General assignment macro
    ExpandSetF(cadr U, caddr U);

lisp procedure ExpandSetF(LHS, RHS);
begin scalar LHSOp;
    return if atom LHS then list('setq, LHS, RHS)
    else if (LHSOp := get(car LHS, 'Assign!-Op)) then
	LHSOp . Append(cdr LHS, list RHS)	% simple substitution case
    else if (LHSOp := get(car LHS, 'SetF!-Expand)) then
	Apply(LHSOp, list(LHS, RHS))		% more complex transformation
    else if (LHSOp := GetD car LHS) and car LHSOp = 'MACRO then
	ExpandSetF(Apply(cdr LHSOp, list LHS), RHS)
    else StdError BldMsg("%r is not a known form for assignment",
			 list('SetF, LHS, RHS));
end;

LoadTime DefList('((GetV PutV)
		   (car RplacA)
		   (cdr RplacD)
		   (Indx SetIndx)
		   (Sub SetSub)
		   (Nth (lambda (L I X) (rplaca (PNTH L I) X) X))
		   (Eval Set)
		   (Value Set)), 'Assign!-Op);

END;