Artifact 0dffff4e6f2dad9681d36e5c7d11b24438ba0634c483e78297784a222f405e97:

• File psl-1983/3-1/util/for-macro.sl — 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: 11032) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/util/for-macro.sl — 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: 11032) [annotate] [blame] [check-ins using]

% FOR-MACRO.SL - fancy FOR loop
%
% Author:      Don Morrison
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        Wednesday, 12 May 1982
% Copyright (c) 1981 University of Utah

% <PSL.UTIL>FOR-MACRO.SL.3,  7-Oct-82 15:46:11, Edit by BENSON
% Changed NULL tests to ATOM tests

% Fancy for loop.  Similar to MACLISP and clones' loop function, but with
% LISPier "syntax" and slightly reduced functionality and concommitant hair.

(fluid '(for-vars* for-outside-vars* for-tests* for-prologue* for-conditions*
         for-body* for-epilogue* for-result*))

(dm for (U) (for-build-loop (cdr U) 'do-loop 'let))

(defmacro for* U
  (for-build-loop U 'do-loop* 'let*))

(de for-build-loop (U loop-fn let-fn)
% Simply calls the function stored under the for-function property of the
% keyword at the begining of each clause, and then builds the DO form from
% the fluids below.  These are in TCONC format.  The clause specific
% functions should do their stuff by TCONC/LCONCing onto these variables.
% The clause specific functions take one argument, the list of arguments to
% the clause keyword.
 (let ((for-outside-vars* (list nil))
       (for-vars* (list nil))
       (for-tests* (list nil))
       (for-prologue* (list nil))
       (for-conditions* (list nil))
       (for-body* (list nil))
       (for-epilogue* (list nil))
       (for-result* (list nil)))
  (foreach clause in U do (process-for-clause clause))
  % "UnTCONCify" everybody
  (setf
    for-outside-vars* (car for-outside-vars*)
    for-vars* (car for-vars*)
    for-tests* (car for-tests*)
    for-prologue* (car for-prologue*)
    for-conditions* (car for-conditions*)
    for-body* (car for-body*)
    for-epilogue* (car for-epilogue*)
    for-result* (car for-result*))
  % Now, back to work...
  (if for-tests* (setf for-tests* (if (cdr for-tests*)
				    (cons 'or for-tests*)
				    (car for-tests*))))
  (when for-conditions*
   (setf for-conditions* (if (cdr for-conditions*)
			  (cons 'and for-conditions*)
			  (car for-conditions*)))
   (setf for-body* `((when ,for-conditions* ,.for-body*))))
  (if (and for-result* (cdr for-result*))
   (StdError "For loops may only return one value"))	 % msg needs improving
  % Finally build up the form to return
  (let ((form `(,loop-fn ,for-vars*
		 ,for-prologue*
		 (,for-tests* ,.for-epilogue* ,.for-result*)
		 ,.for-body*)))
    (if for-outside-vars* `(,let-fn ,for-outside-vars* ,form) form))))

(de process-for-clause (clause)
  (let ((op (car clause)) fn)
    (cond
      ((atom clause)
	(process-for-clause
	  (ContinuableError
	    99
	    (BldMsg "For clauses may not be atomic: %r." clause)
	    clause)))
      ((setf fn (get op 'for-function))
	(call fn (cdr clause)))
      (t
	(ContinuableError
	  99
	  (BldMsg "Unknown for clause operator: %r." op)
	  op)))))

(de for-in-function (clause)
 (let ((var (car clause))
       (lst (cadr clause))
       (fn (and (cddr clause) (caddr clause)))
       (dummy (gensym)))
   (tconc for-outside-vars* dummy)
   (tconc for-vars* `(,var
		       (progn
			 (setf ,dummy ,lst)
			 (if (pairp ,dummy)
			   ,(if fn `(,fn (car ,dummy)) `(car ,dummy))
			   ()))
		       (progn
			 (setf ,dummy (cdr ,dummy))
			 (if (pairp ,dummy)
			   ,(if fn `(,fn (car ,dummy)) `(car ,dummy))
			   ()))))
   (tconc for-tests* `(atom ,dummy))))

(de for-on-function (clause)
 (let ((var (car clause))
       (lst (cadr clause)))
   (tconc for-vars* `(,var ,lst (cdr ,var)))
   (tconc for-tests* `(atom ,var))))

(de for-from-function (clause)
 (let* ((var (car clause))
	(var1 (if (pairp var) (car var) var))
	(clause (cdr clause))
	(init (if (pairp clause) (or (pop clause) 1) 1))
	(fin (if (pairp clause) (pop clause) nil))
	(fin-var (if (and fin (not (numberp fin))) (gensym) nil))
	(step (if (pairp clause) (car clause) 1))
	(step-var (if (and step (not (numberp step))) (gensym) nil)))
   (tconc
     for-vars*
     (list* var init (cond
		       (step-var `((plus2 ,var1 ,step-var)))
		       ((zerop step) nil)
		       ((onep step) `((add1 ,var1)))
		       ((eqn step -1) `((sub1 ,var1)))
		       (t `((plus ,var1 ,step))))))
   (if fin-var (tconc for-vars* `(,fin-var ,fin)))
   (if step-var (tconc for-vars* `(,step-var ,step)))
   (cond (step-var
	  (tconc for-tests* `(if (minusp ,step-var)
			      (lessp ,var1 ,(or fin-var fin))
			      (greaterp ,var1 ,(or fin-var fin)))))
         ((null fin))
         ((minusp step) (tconc for-tests* `(lessp ,var1 ,(or fin-var fin))))
	 (t (tconc for-tests* `(greaterp ,var1 ,(or fin-var fin)))))))

(de for-for-function (clause) (tconc for-vars* clause))

(de for-with-function (clause) 
 (lconc for-vars* (append clause nil)))			 % copy it for safety

(de for-initially-function (clause)
 (lconc for-prologue* (append clause nil)))		 % copy it for safety

(de for-finally-function (clause)
 (lconc for-epilogue* (append clause nil)))		 % copy it for safety

(de for-do-function (clause)
 (lconc for-body* (append clause nil)))			 % copy it for safety

(de for-collect-function (clause)
 (let ((tail (gensym))(reslt))
  (if (cdr clause)
    (progn
      (setf reslt (cadr clause))
      (tconc for-prologue* `(setf ,reslt nil)))
    (setf reslt (gensym))
    (tconc for-vars* reslt)
    (tconc for-result* reslt))
  (tconc for-vars* tail)
  (tconc for-body* `(if ,tail
		     (setf ,tail (cdr (rplacd ,tail (ncons ,(car clause)))))
		     (setf ,reslt (setf ,tail (ncons ,(car clause))))))))

(de for-conc-function (clause)
 (let ((reslt)(tail (gensym)))
  (if (cdr clause)
    (progn
      (setf reslt (cadr clause))
      (tconc for-prologue* `(setf ,reslt nil)))
    (setf reslt (gensym))
    (tconc for-vars* reslt)
    (tconc for-result* reslt))
  (tconc for-vars* tail)
  (tconc for-body* `(if ,tail
		     (setf ,tail (LastPair (rplacd ,tail ,(car clause))))
		     (setf ,reslt ,(car clause))
		     (setf ,tail (LastPair ,reslt))))))

(de for-join-function (clause)
 (let ((reslt)(tail (gensym)))
  (if (cdr clause)
    (progn
      (setf reslt (cadr clause))
      (tconc for-prologue* `(setf ,reslt nil)))
    (setf reslt (gensym))
    (tconc for-vars* reslt)
    (tconc for-result* reslt))
  (tconc for-vars* tail)
  (tconc for-body* `(if ,tail
		     (setf
		      ,tail
		      (LastPair (rplacd ,tail (append ,(car clause) nil))))
		     (setf ,reslt (append ,(car clause) nil))
		     (setf ,tail (LastPair ,reslt))))))

(defmacro-no-displace def-for-basic-return-function (name var init exp bod)
  `(de ,name (clause)
     (let ((reslt))
       (if (cdr clause)
	 (progn
	   (setf reslt (cadr clause))
	   (tconc for-prologue* `(setf ,reslt ,,init)))
	 (setf reslt (gensym))
	 (tconc for-vars* `(,reslt ,,init))
	 (tconc for-result* reslt))
       (tconc for-body* ,(subst 'reslt var (subst '(car clause) exp bod))))))

(def-for-basic-return-function for-union-function
  reslt nil exp `(setf ,reslt (union ,reslt ,exp)))

(def-for-basic-return-function for-unionq-function
  reslt nil exp `(setf ,reslt (unionq ,reslt ,exp)))

(de for-intersection-function (clause)
 (let ((reslt)(flg (gensym)))
  (if (cdr clause)
    (progn
      (setf reslt (cadr clause))
      (tconc for-prologue* `(setf ,reslt nil)))
    (setf reslt (gensym))
    (tconc for-vars* reslt)
    (tconc for-result* reslt))
  (tconc for-vars* flg)
  (tconc for-body* `(setf ,reslt (if ,flg
				   (intersection ,reslt ,(car clause))
				   (setf ,flg t)
				   ,(car clause))))))

(de for-intersectionq-function (clause)
 (let ((reslt)(flg (gensym)))
  (if (cdr clause)
    (progn
      (setf reslt (cadr clause))
      (tconc for-prologue* `(setf ,reslt nil)))
    (setf reslt (gensym))
    (tconc for-vars* reslt)
    (tconc for-result* reslt))
  (tconc for-vars* flg)
  (tconc for-body* `(setf ,reslt (if ,flg
				   (intersectionq ,reslt ,(car clause))
				   (setf ,flg t)
				   ,(car clause))))))

(def-for-basic-return-function for-adjoin-function
  reslt nil exp `(setf ,reslt (adjoin ,exp ,reslt)))

(def-for-basic-return-function for-adjoinq-function
  reslt nil exp `(setf ,reslt (adjoinq ,exp ,reslt)))

(def-for-basic-return-function for-count-function
  reslt 0 exp `(if ,exp (incr ,reslt)))

(def-for-basic-return-function for-sum-function
  reslt 0 exp `(incr ,reslt ,exp))

(def-for-basic-return-function for-product-function
  reslt 1 exp `(setf ,reslt (times ,reslt ,exp)))

(def-for-basic-return-function for-maximize-function
  reslt nil exp `(setf ,reslt (if ,reslt
				(max ,reslt ,(car clause))
				,(car clause))))

(def-for-basic-return-function for-minimize-function
  reslt nil exp `(setf ,reslt (if ,reslt
				(min ,reslt ,(car clause))
				,(car clause))))


(de for-always-function (clause)
 (tconc for-body*
   `(if (null ,(if (cdr clause) `(and ,@clause) (car clause))) (return nil)))
 (tconc for-result* t))

(de for-never-function (clause)
 (tconc for-body*
   `(if ,(if (cdr clause) `(or ,@clause) (car clause)) (return nil)))
 (tconc for-result* t))

(de for-thereis-function (clause)
 (let ((temp (gensym)))
  (tconc for-result* nil)
  (tconc for-vars* temp)
  (tconc for-body* `(if (setf ,temp ,(car clause)) (return ,temp)))))

(de for-returns-function (clause)
 (tconc for-result* (if (cdr clause) (cons 'progn clause) (car clause))))

(de for-while-function (clause)
 (lconc for-tests* (foreach u in clause collect `(null ,u))))

(de for-until-function (clause)
 (lconc for-tests* (append clause nil)))		 % copy for safety

(de for-when-function (clause)
 (lconc for-conditions* (append clause nil)))	 % copy for safety

(de for-unless-function (clause)
 (lconc for-conditions* (foreach u in clause collect `(not ,u))))

(deflist `(
  (in ,#'for-in-function)
  (on ,#'for-on-function)
  (from ,#'for-from-function)
  (for ,#'for-for-function)
  (as ,#'for-for-function)
  (with ,#'for-with-function)
  (initially ,#'for-initially-function)
  (finally ,#'for-finally-function)
  (do ,#'for-do-function)
  (doing ,#'for-do-function)
  (collect ,#'for-collect-function)
  (collecting ,#'for-collect-function)
  (conc ,#'for-conc-function)
  (concing ,#'for-conc-function)
  (join ,#'for-join-function)
  (joining ,#'for-join-function)
  (count ,#'for-count-function)
  (counting ,#'for-count-function)
  (sum ,#'for-sum-function)
  (summing ,#'for-sum-function)
  (product ,#'for-product-function)
  (maximize ,#'for-maximize-function)
  (maximizing ,#'for-maximize-function)
  (minimize ,#'for-minimize-function)
  (minimizing ,#'for-minimize-function)
  (union ,#'for-union-function)
  (unionq ,#'for-unionq-function)
  (intersection ,#'for-intersection-function)
  (intersectionq ,#'for-intersectionq-function)
  (adjoin ,#'for-adjoin-function)
  (adjoinq ,#'for-adjoinq-function)  
  (always ,#'for-always-function)
  (never ,#'for-never-function)
  (thereis ,#'for-thereis-function)
  (returns ,#'for-returns-function)
  (returning ,#'for-returns-function)
  (while ,#'for-while-function)
  (until ,#'for-until-function)
  (when ,#'for-when-function)
  (unless ,#'for-unless-function)
     ) 'for-function)