Artifact a174933a908e8010b653660c86748b72fe61d95474a81ed4607e24f0fd891f7b:

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

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

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

% Edit by MLG,9:35am  Tuesday, 29 December 1981
% Add EXIT, NEXT, REPEAT, add 'Join, improve FOR

macro procedure ForEach U;		%. Macro for MAP functions
%
% From RLISP
%
% Possible forms are:
% (foreach x in u do (foo x))	   --> (mapc u (function (lambda (x) (foo x))))
% (foreach x in u collect (foo x)) --> (mapcar u ...)
% (foreach x in u conc (foo x))	   --> (mapcan u ...)
% (foreach x in u join (foo x))	   --> (mapcan u ...)
% (foreach x on u do (foo x))	   --> (map u ...)
% (foreach x on u collect (foo u)) --> (maplist u ...)
% (foreach x on u conc (foo x))	   --> (mapcon u ...)
% (foreach x on u join (foo x))	   --> (mapcon u ...)
%
begin scalar Action, Body, Fn, Lst, Mod, Var;
    Var := cadr U;
    U := cddr U;
    Mod := car U;
    U := cdr U;
    Lst := car U;
    U := cdr U;
    Action := car U;
    Body := cdr U;
    Fn := if Action eq 'DO then
	      if Mod eq 'IN then 'MAPC else 'MAP
	  else if Action eq 'CONC or Action eq 'JOIN then
	      if Mod eq 'IN then 'MAPCAN else 'MAPCON
	  else if Action eq 'COLLECT then
	      if Mod eq 'IN then 'MAPCAR else 'MAPLIST
	  else StdError BldMsg("%r is an illegal action in ForEach", Action);
    return list(Fn, Lst,
		    list('FUNCTION, 'LAMBDA . list Var . Body))
end;

macro procedure Exit U;                 %. To leave current Iteration
    if null cdr U then
	'(return NIL)
    else if cddr U then
	list('return, 'progn . cdr U)
    else
	'return . cdr U;

macro procedure Next U;                 %. Continue Loop
    '(go !$Loop!$);			% no named DO's yet (no DO at all)

macro procedure While U;		%. Iteration macro
%
% From RLISP
% 
% Form is (while bool exp1 ... expN)
%
    'prog . '()
	. '!$Loop!$
	    . list('Cond, list(list('not, cadr U),
			       '(return NIL)))
	    . Append(cddr U, '((go !$Loop!$)));

macro procedure Repeat U;
%
% From RLISP
% Form is (repeat exp1 ... expN bool)
% Repeat until bool is true, similar to Pascal, etc.
%
       'prog . '() .
	  '!$Loop!$.
		for each X on cdr U collect
		    if null cdr X then
			list('Cond, list(list('not, car X),'(go !$Loop!$)))
		    else car X;

MACRO PROCEDURE FOR U;
%
% From RLISP
% 
% Form is (FOR (FROM var init final step) (key form))
%/ Limited right now to key=DO
   BEGIN SCALAR ACTION,BODY,EXP,INCR,RESULT,TAIL,VAR,X;
      VAR := second second U;
      INCR := cddr second U;  %(init final step)
      ACTION := first third U;
      BODY := second third U;
      RESULT := LIST LIST('SETQ,VAR,CAR INCR);
      INCR := CDR INCR;
      X := LIST('DIFFERENCE,first INCR,VAR);
      IF second INCR NEQ 1 THEN X := LIST('TIMES,second INCR,X);
      TAIL :='(RETURN NIL);
      IF NOT ACTION EQ 'DO
	THEN <<ACTION := GET(ACTION,'BIN);
		EXP := GENSYM();
		BODY := LIST('SETQ,EXP,
			      LIST(CAR ACTION,LIST('SIMP,BODY),EXP));
		RESULT := LIST('SETQ,EXP,MKQUOTE CDR ACTION) . RESULT;
		TAIL := LIST('RETURN, LIST('MK!*SQ,EXP));
		EXP := LIST EXP>>;
      RETURN ('PROG . 
              (VAR . EXP) .
                  NCONC(RESULT,
		'!$LOOP!$ .
		LIST('COND,LIST(LIST('MINUSP,X), TAIL)) .
		BODY .
		LIST('SETQ,VAR,LIST('PLUS2,VAR,second INCR)) .
		'((GO !$LOOP!$))
              ));
   END;


END;