1;-*- *cold-load:t; 1Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB); Base:10. -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.

;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151

;;; Copyright (C) 1986-1989 Texas Instruments Incorporated. All rights reserved.*

(Defmacro DOLIST ((var list resultform) &BODY body)
  1"Iterate BODY with VAR bound to successive elements of the value of LIST.
If LIST is exhausted, RESULTFORM is executed and returned.
RETURN and GO can be used inside the BODY."*
  (LET ((iteration-var (GENSYM)))
    `(DO ((,iteration-var ,list (CDR ,iteration-var))
	  (,var ))
	 ((NULL ,iteration-var) ,resultform)
       (SETQ ,var (CAR ,iteration-var))
       . ,body)))

(Defmacro DOTIMES ((var limit resultform) &BODY body)
  1"Iterate BODY with VAR bound to successive integers from 0 up to LIMIT's value.
LIMIT is evaluated only once.  When it is reached, RESULTFORM is executed and returned.
RETURN and GO can be used inside the BODY."*
  (COND ((FIXNUMP limit)
	 `(DO ((,var 0 (1+ ,var)))
	      ((>= ,var ,limit) ,resultform)
	    . ,body))
	(T (LET ((iteration-var (GENSYM)))
	     `(DO ((,var 0 (1+ ,var))
		   (,iteration-var ,limit))
		  ((>= ,var ,iteration-var) ,resultform)
		. ,body)))))

(Defmacro DO-FOREVER (&BODY body)
  1"Execute BODY until it does a RETURN or a THROW."*
  `(DO () (()) . ,body))

(Defmacro LET-GLOBALLY-IF (cond-form varlist &BODY body)
  1"Like LET-IF, but sets the variables on entry and sets them back on exit.
No new binding is created.  As a result, the changed values are visible
in other stack groups while this frame is dynamically active."*
  (LET ((VARS (MAPCAR '(LAMBDA (V) (COND ((ATOM V) V) (T (CAR V)))) VARLIST))
	(VALS (MAPCAR '(LAMBDA (V) (COND ((ATOM V) NIL) (T (CADR V)))) VARLIST))
	(GENVARS (MAPCAR '(LAMBDA (IGNORE) (GENSYM)) VARLIST))
	(CONDVAR (GENSYM)))
    `(LET ((,CONDVAR ,COND-FORM) . ,GENVARS)
       (UNWIND-PROTECT (PROGN (WHEN ,CONDVAR
				,@(MAPCAR #'(LAMBDA (GENVAR VAR)
					      `(COPY-VALUE (LOCF ,GENVAR) (LOCF ,VAR)))
					  GENVARS VARS)
				(SETQ . ,(MAPCAN 'LIST VARS VALS)))
			      . ,BODY)
		       (WHEN ,CONDVAR
			 . ,(MAPCAR #'(LAMBDA (VAR GENVAR)
				      `(COPY-VALUE (LOCF ,VAR) (LOCF ,GENVAR)))
				  VARS GENVARS))))))

(Defmacro LET-GLOBALLY (varlist &BODY body)
  1"Like LET, but sets the variables on entry and sets them back on exit.
No new binding is created.  As a result, the changed values are visible
in other stack groups while this frame is dynamically active."*
  (LET ((VARS (MAPCAR #'(LAMBDA (V) (COND ((ATOM V) V) (T (CAR V)))) VARLIST))
	(VALS (MAPCAR #'(LAMBDA (V) (COND ((ATOM V) NIL) (T (CADR V)))) VARLIST))
	(GENVARS (MAPCAR '(LAMBDA (IGNORE) (GENSYM)) VARLIST)))
     `(LET ,GENVARS
        (UNWIND-PROTECT (PROGN ,@(MAPCAR #'(LAMBDA (GENVAR VAR)
					     `(COPY-VALUE (LOCF ,GENVAR) (LOCF ,VAR)))
					 GENVARS VARS)
			       (SETQ . ,(MAPCAN 'LIST VARS VALS))
			       . ,BODY)
			. ,(MAPCAR #'(LAMBDA (VAR GENVAR)
				       `(COPY-VALUE (LOCF ,VAR) (LOCF ,GENVAR)))
				   VARS GENVARS)))))

(DEFMACRO letf-globally (varlist &body body &aux saved-values)
  "2Like LET-GLOBALLY, but VARLIST can contain accessor macros that are SETFed.
Saves1 values, SETF*s1 new values, *executes BODY 1then restor*es1 *values1 within an
unwind-protect.* 1This is good for temporarily changing values within a structure.**"
  `(LET ,(LOOP for (var value) in varlist
	       for gen = (gensym)
	       collect gen into saved
	       collect `(,gen ,var) into bindings
	       finally (SETQ saved-values saved) (RETURN bindings))
     (UNWIND-PROTECT
       (PROGN ,@(LOOP for (var value) in varlist
		      collect `(SETF ,var ,value) into SET
		      finally (RETURN (NCONC SET body))))
       ,@(LOOP for (var) in varlist
	       for saved in saved-values collecting
	       `(SETF ,var ,saved)))))

1;;; (LOCAL-DECLARE ((SPECIAL FOO) (UNSPECIAL BAR)) code)
;;; declares FOO and BAR locally within <code>.
;;; LOCAL-DECLARE can also be used by macros to pass information down
;;; to other macros that expand inside the code they produce.
;;; The list of declarations (in this case, ((MUMBLE FOO BAR))) is appended
;;; onto the front of LOCAL-DECLARATIONS, which can be searched by
;;; macros expending inside of <code>.*
(Defmacro zlc:LOCAL-DECLARE (DECLARATIONS &BODY BODY)
  1"Evaluates or compiles BODY with DECLARATIONS in effect.
DECLARATIONS is a list of declarations, each of which is a list.
Declarations include (SPECIAL variables...), (ARGLIST argument-names...),
(RETURN-LIST value-names...), (:SELF-FLAVOR flavorname)."*
  `(COMPILER-LET ((LOCAL-DECLARATIONS (APPEND ',DECLARATIONS LOCAL-DECLARATIONS)))
     . ,BODY))

(Defmacro PROG2 (form result &BODY body)
  1"SYNTAX: (PROG2 form1 form2 { form }*)
 Evaluates all forms in a sequence of forms ignoring the values
 returned by each except for the second which is returned as the 
 value of the PROG2. Note no multiple-value analogue exists for
 PROG2."*
  `(PROGN
     ,form
     (PROG1
       ,result
       ,@body)))

;;;(Defmacro LOCALLY (&BODY BODY)
;;;  1"Used to make local pervasive declarations.*
;;;1SYNTAX: (LOCALLY {declaration}* {form}*)*
;;;1Identical to Zetalisp PROGN."*
;;;  `(PROGN . ,BODY))

(Defsubst IDENTITY (X) 1"Return the argument."* X)

;1 do-do*-named are Zetalisp holdovers*
(Defmacro ZLC:DO-NAMED (name . body)
  `(BLOCK ,name (DO .,body)))

;;AB 7-28-87.  Rename this zlc:do*-named instead of zlc:do-named* (!!).  [SPR 5433]
(Defmacro ZLC:DO*-NAMED (name . body)
  `(BLOCK ,name (DO* .,body)))


(Defmacro PROG (&REST body)
 1"COMMON-LISP & ZETALISP SYNTAX:(PROG [name]( { var|(var exp) }*) [(declare...)] . body)
  where NAME denotes a symbol other than NIL. If NAME is specified, (RETURN-FROM name)
  may be used. PROG is functionally equivalent to the following:
   (BLOCK nil (BLOCK name (LET varlist (TAGBODY . body))))"*

  (PROG-GENERATOR 'let body))

(Defmacro PROG* (&REST body)
 1"COMMON-LISP & ZETALISP SYNTAX:(PROG* [name]( { var|(var exp) }*) [(declare...)] . body)
  where NAME denotes a symbol other than NIL. If NAME is specified, (RETURN-FROM name)
  may be used. PROG**1 is functionally equivalent to the following:
   (BLOCK nil (BLOCK name (LET* varlist (TAGBODY . body))))"*

  (PROG-GENERATOR 'let* body))

(Defmacro ZLC:RETURN-LIST (values)
;; a Zetalisp holdover
  `(RETURN (VALUES-LIST ,values)))