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

1;;;                           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.*

;;; 4/13/89 jlm	 Changed PROG-GENERATOR to NOT use the value returned by NREVERSE

(PROCLAIM '(INLINE ZETALISP-ON-P COMMON-LISP-ON-P))


(DEFUN LET (&QUOTE varlist &REST body)
  1"COMMON LISP SYNTAX: (LET ( { (var exp) | var }* ) [(DECLARE ...)] body)
 ZETALISP SYNTAX: (LET ( {(var exp) | var}* ) body)
 Binds the variables to their values as per the varlist and evaluates 
 the body as a PROGN"* 

  (IF (ZETALISP-ON-P) (ZL-WITH-PARALLEL-BASIC-FRAME (varlist) (EVAL-BODY-AS-PROGN body))
      (LET ((specials (EXTRACT-SPECIAL-DECLARATIONS)))
	(WITH-PARALLEL-BASIC-FRAME (varlist specials) (EVAL-BODY-AS-PROGN body)))))

(DEFUN LET* (&QUOTE varlist &REST body)
  1"COMMON LISP SYNTAX: (LET* ( { (var exp) | var }* ) [(DECLARE ...)] body)
 ZETALISP SYNTAX: (LET* ( {(var exp) | var}* ) body)
 Binds the variables to their values as per the varlist, allowing
 each to refer to the preceeding variables, and evaluates the body 
 as a PROGN"*

  (IF (ZETALISP-ON-P) (ZL-WITH-SERIAL-BASIC-FRAME (varlist) (EVAL-BODY-AS-PROGN body))
      (LET ((specials (EXTRACT-SPECIAL-DECLARATIONS)))
	(WITH-SERIAL-BASIC-FRAME (varlist specials) (EVAL-BODY-AS-PROGN body)))))

1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; BLOCK, RETURN-FROM, RETURN, RETURN-LIST (obsolete)
;;
;; The macro ENTER-BLOCK enters a block name into the lexical environment. The entry
;; is a frame of 3 words (block name-of-block pdl-address-of-this-frame). The first
;; is used to identify block frames. The second entry is used to identify the block.
;; The last entry , the frame address, is used to identify a particular instance of
;; the block. The latter is actually necessary since the dynamic constructs CATCH-THROW
;; are used to simulate lexical constructs such as BLOCK,RETURN-FROM,etc. *


(DEFUN BLOCK (&QUOTE name &REST body)
  1"SYNTAX: (BLOCK name {form}*)
 BLOCK establishes a block with name  NAME which is not evaluated and
 must be a symbol. The forms are executed as a PROGN with one important
 exception. If one of the forms is (RETURN-FROM name result), then the
 innermost block having name NAME is exited and the value(s) of RESULT are
 returned as the value of the block. NOTE: (DEFUN foo...) creates a block
 named FOO while (PROG...) and (DO...) create blocks named NIL."*
  
  (UNLESS (SYMBOLP name) (FERROR nil 1"~s is an invalid block name"* name))
  (ENTER-BLOCK name (EVAL-BODY-AS-PROGN body)))


(DEFUN DO (&QUOTE &REST body)
 1"COMMON-LISP & ZETALISP SYNTAX:
     (DO ( { var | (var initial) | (var initial next) }*)
         ( exitcond [exitforms] )
         [(declare...)]
         body)
 Equivalent in functionality to
     (BLOCK nil 
       (LET ( { var | (var initial) }* ) [(declare...)]
         (LOOP (WHEN exitcond (RETURN (PROGN exitforms)))
            (TAGBODY  body)
            (PSETQ {var next}*))))
 Note RETURN can be used in BODY."*

 (DO-PARALLEL body))

(DEFUN DO* (&QUOTE &REST body)
 1"COMMON-LISP & ZETALISP SYNTAX:
     (DO* ( { var | (var initial) | (var initial next) }*)
          ( exitcond [exitforms] )
          [(declare...)]
          body)
 Equivalent in functionality to
     (BLOCK nil 
       (LET* ( { var | (var initial) }* ) [(declare...)]
         (LOOP (WHEN exitcond (RETURN (PROGN exitforms)))
            (TAGBODY  body)
            (SETQ {var next}*))))
 Note RETURN can be used in BODY."*

 (DO-SERIAL body))





(DEFUN DO-PARALLEL (body)
;1; this handles initialization for DO and DO-NAMED*

  (LET* ((varlist (CAR body)) 
	 (exitcond (IF (CADR body) (CAADR body)
		       (FERROR nil "ill-formed exit test ~s in DO" (CADR body))))
	 (exitforms (CDADR body))
	 (specials)
	 (stepper))  ;1; the stepper is the form which increments the values of the loop variables*
    (SETQ body (CDDR body))
    (SETQ specials (EXTRACT-SPECIAL-DECLARATIONS))
    (DO ((x varlist (CDR x))
	 (z))
	((ATOM x) (IF z (SETQ stepper (MACROEXPAND (CONS 'PSETQ (NREVERSE z))))))
      (WHEN (AND (CONSP (CAR x))(NTHCDR 2 (CAR x)))
	(SETQ z (CONS (CADDAR x)(CONS (CAAR x) z)))))
    (ENTER-BLOCK nil
      (COND ((ZETALISP-ON-P)
	     (ZL-WITH-PARALLEL-BASIC-FRAME (varlist) 
	       (DO-DO*-INTERNAL stepper body exitcond exitforms)))
	    (T
	     (WITH-PARALLEL-BASIC-FRAME (varlist specials)
	       (DO-DO*-INTERNAL stepper body exitcond exitforms)))))))

(DEFUN DO-SERIAL (body)
;1; this handles initialization for DO* and DO-NAMED**

  (LET* ((varlist (CAR body))
	 (exitcond (IF (CADR body) (CAADR body)
		       (FERROR nil "ill-formed exit test ~s in DO*" (CADR body))))
	 (exitforms (CDADR body))
	 (specials)
	 (stepper))
    (SETQ body (CDDR body))
    (SETQ specials (EXTRACT-SPECIAL-DECLARATIONS))
    (DO ((x varlist (CDR x))
	 (z))
	((ATOM x) (IF z (SETQ stepper (CONS 'SETQ (NREVERSE z)))))
      (WHEN (AND (CONSP (CAR x))(NTHCDR 2 (CAR x)))
	(SETQ z (CONS (CADDAR x)(CONS (CAAR x) z)))))
    (ENTER-BLOCK nil
      (COND ((ZETALISP-ON-P)
	     (ZL-WITH-SERIAL-BASIC-FRAME (varlist) 
	       (DO-DO*-INTERNAL stepper body exitcond exitforms)))
	    (T
	     (WITH-SERIAL-BASIC-FRAME (varlist specials)
	       (DO-DO*-INTERNAL stepper body exitcond exitforms)))))))


;;AB 7-28-87.  Fixed UNWIND-PROTECT to contain (SETF (SECOND bindframe) nil) as unwind protect form. [SPR 5775]
(DEFUN DO-DO*-INTERNAL (stepper body exitcond exitforms)
  ;1; process the body of a DO or DO* loop*
  
  (LET* ((bindframe (%MAKE-STACK-LIST 2))1      ;; (TAGBODY...*
	 (current-list bindframe)
	 (current-last (CDR bindframe)))
    (SETF (FIRST bindframe) 'tag)
    (SETF (SECOND bindframe) (LOCF bindframe))
    (DO ((restforms body (CDR restforms)))
	((ATOM restforms))
      (WHEN (ATOM (CAR restforms))
	(SETQ current-list (%MAKE-STACK-LIST 2))
	(%P-STORE-CDR-CODE (%POINTER current-last) CDR-NEXT) 
	(SETQ current-last (CDR current-list))
	(SETF (FIRST current-list) (CAR restforms)) 
	(SETF (SECOND current-list) (CDR restforms))))
    (UNWIND-PROTECT
	(WITH-STACK-LIST* (*INTERPRETER-ENVIRONMENT* bindframe *INTERPRETER-ENVIRONMENT*)
	  (PROG ((savedbody body))
		(GO TEST-EXIT)
	     LOOP
		(SETQ body 
		      (CATCH (LOCF bindframe)
			(DO ((restforms body (CDR restforms)))
			    ((ATOM restforms))
			  (WHEN (CONSP (CAR restforms))
			    (*EVAL (CAR restforms))))))
		(WHEN body (GO LOOP))
		(*EVAL stepper)1      ;; compute the new values of the DO variables *
	     TEST-EXIT
		(IF (*EVAL exitcond)1 ;; test the exit condition - if satisfied, evaluate exit forms *
		    (RETURN-FROM DO-DO*-INTERNAL (EVAL-BODY-AS-PROGN exitforms)) 
		    (SETQ body savedbody)1 ;; else restore the original body of the do-loop*
		    (GO LOOP))))1         ;; and evaluate it again.*
      (SETF (SECOND bindframe) nil))))





(DEFUN RETURN-FROM (&QUOTE name &REST vals)
  1"SYNTAX:(RETURN-FROM name {form}* )
 The first argument names a lexically surrounding block, possibly created
 implicitly by DEFUN. Concerning the second argument:
  *) if not specified, NIL is returned in Common Lisp
     and nothing is returned in Zetalisp.
  *) if there is one form, ALL values it returns are returned as the
     values of the block.
  *) when more than one form, one value for each form is returned
     as the values of the block."*
  
  (DO ((restframes *INTERPRETER-ENVIRONMENT* (CDR restframes)))
      ((ATOM restframes))
    (LET ((bindframe (CAR restframes)))
      (WHEN (AND (EQ (CAR bindframe) 'block) (EQ (CADR bindframe) name) (CADDR bindframe))
	(THROW (CADDR bindframe)
	       (COND ((ATOM vals) (IF (COMMON-LISP-ON-P) nil (VALUES-LIST vals)))
		     ((ATOM (CDR vals)) (*EVAL (CAR vals)))
		     (t (VALUES-LIST (MAPCAR #'*EVAL vals))))))))
  (FERROR nil 1"no lexically-visible ACTIVE block named ~s"* name))

(DEFUN RETURN (&QUOTE &REST vals)
  1"SYNTAX:(RETURN result)
 Exit a block named NIL or from the innermost PROG or DO. Has the
 Same meaning as (RETURN-FROM nil RESULT)."*
  
  (DO ((restframes *INTERPRETER-ENVIRONMENT* (CDR restframes)))
      ((ATOM restframes))
    (LET ((bindframe (CAR restframes)))  
      (WHEN (AND (EQ (CAR bindframe) 'block) (NULL (CADR bindframe)) (CADDR bindframe))
	(THROW (CADDR bindframe) 
		   (COND ((ATOM vals) (IF (COMMON-LISP-ON-P) nil (VALUES-LIST vals)))
			 ((ATOM (CDR vals)) (*EVAL (CAR vals)))
			 (t (VALUES-LIST (MAPCAR #'*EVAL vals)))))))) 
  (FERROR nil 1"no lexically-visible active block named NIL"*))


1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; TAGBODY & GO
;;*

;; PHD 3/2/87 worked around stack-list-eq problem by setting catch tag as a locative.
(DEFUN TAGBODY (&QUOTE &REST body)
  1"SYNTAX:(TAGBODY {tag | statements }*)
  Each expression comprising the body is examined. Numbers and symbols
  represent tags. Lists represent expressions. Each element of the body
  is processed left-to-right. Tags are ignored but remembered - statements
  are evaluated and their values ignored. If some statement has the form
  (GO tagid), control is transferred to the statements following TAGID
  which must be lexically visible to the statement."*

  (LET* ((bindframe (%MAKE-STACK-LIST 2))
	 (current-list bindframe)
	 (current-last (CDR bindframe)))
    (SETF (FIRST bindframe) 'tag)
    (SETF (SECOND bindframe) (locf bindframe))
    (DO ((restforms body (CDR restforms)))
	((ATOM restforms))
      (WHEN (ATOM (CAR restforms))
	1;; make a list containing tag and body*
	(SETQ current-list (%MAKE-STACK-LIST 2))1 *
	(%P-STORE-CDR-CODE (%POINTER current-last) CDR-NEXT) ;;append to previous list
	(SETQ current-last (CDR current-list))
	(SETF (FIRST current-list) (CAR restforms)) ;; insert tag
	(SETF (SECOND current-list) (CDR restforms))))
    
    (UNWIND-PROTECT
	(WITH-STACK-LIST* (*INTERPRETER-ENVIRONMENT* bindframe *INTERPRETER-ENVIRONMENT*)
	  (PROG ()
	     LOOP
		(comment (print (list "before:body" body)))
		1;; if all forms in BODY are evaluated by the following DO, then DO returns*
		1;; NIL and we fall through the (WHEN..) below. If, on the other hand, some*
		1;; form is (GO tag) a throw will be executed to a catcher for the tag. If this*
		1;; is the tag defined in the catcher below, then the value of the catcher*
		1;; will be the sequence of forms associated with TAG. Thus BODY will be*
		1;; this sequence of forms and the (WHEN ...) will cause the forms to be*
		1;; evaluated.*
		(SETQ body 
		      (CATCH (locf bindframe)
				 (DO ((restforms body (CDR restforms)))
				     ((ATOM restforms) nil)
				   (WHEN (CONSP (CAR restforms))
				     (*EVAL (CAR restforms))))))
		(comment (print (list "after:body" body)))
		(WHEN body (GO LOOP))))
      (SETF (SECOND bindframe) nil))))

(DEFUN GO (&QUOTE tagid)
 1"SYNTAX:(GO tag) 
 Transfers control to tag TAGID within a PROG,DO or TAGBODY. TAGID is not evaluated."*

 (DO ((restframes *INTERPRETER-ENVIRONMENT* (CDR restframes))
      (bindframe))
     ((ATOM restframes)
      (FERROR nil 1"GO tag ~s is not defined or is no longer valid"* tagid))
   (SETQ bindframe (CAR restframes))
   (WHEN (AND (EQ (CAR bindframe) 'tag) (CADR bindframe))
     (DO ((restb (CDDR bindframe) (CDDR restb)))
	 ((ATOM restb))
1       ;; when the tags match using EQL, execute a throw to a particular instantiation
       ;; of the tag. The throw returns the sequence of forms associated with the tag.*
       (WHEN (EQL tagid (CAR restb)) 
	 (THROW (CADR bindframe) (CADR restb)))))))




;;PAD-PHD 2/2/87 Turned locally into a macro.
(defmacro locally (&body body)
  "Used to make local pervasive declarations.
SYNTAX: (LOCALLY {declaration}* {form}*)
Identical to Zetalisp PROGN."
  `(let ()
     . ,body))


(DEFUN PROGN (&QUOTE &REST body)
  1"SYNTAX: (PROGN {form}*)
 Evaluates all forms in a sequence of forms ignoring the values
 returned by each except for the last. Returns ALL values
 returned by the last form."*
  (EVAL-BODY-AS-PROGN body))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; PROGV, PROGW
;;
;; 

(defun progv (vars vals &quote &rest body)
  "Bind the VARS to the VALS and then execute the BODY.
Note that the expressions you write for VARS and VALS
are evaluated on each entry to PROGV,
so the variables bound may be different each time.
The variables are always bound as specials if they are bound;
therefore, strictly speaking only variables declared special should be used."
  ;; This still always binds them as specials!
  ;; This function has to work that way.
  (do
	((vars vars (cdr vars))
	 (vals vals (cdr vals)))
	((null vars)
	 (EVAL-BODY-AS-PROGN body))
    (bind (value-cell-location (car vars)) (car vals))))

;;; (PROGW '((VAR-1 VAL-1) (VAR-2 VAL-2) ... (VAR-N VAL-N)) &BODY BODY)
;;; Binds VAR-I to VAL-I (evaluated) during execution of BODY
(defun progw (vars-and-vals &quote &rest body)
  "Perform bindings from a list of variables and expressions, then execute the BODY.
VARS-AND-VALS is a list of elements like (VARIABLE VALUE-FORM).
The VALUE-FORMs are all evaluated by PROGW, even when compiled.
Note that the value of VARS-AND-VALS is computed each time.
The variables are always bound as specials if they are bound;
therefore, strictly speaking only variables declared special should be used."
  (do ((vars-and-vals vars-and-vals (cdr vars-and-vals)))
      ((null vars-and-vals)
       (EVAL-BODY-AS-PROGN body))
    (bind (value-cell-location (caar vars-and-vals))
	  (*EVAL (cadar vars-and-vals)))))


1;;; (LET-IF <COND> ((VAR-1 VAL-1) (VAR-2 VAL-2) ... (VAR-N VAL-N)) &BODY BODY)
;;; If <COND> is not nil, binds VAR-I to VAL-I (evaluated) during execution of BODY,
;;; otherwise just evaluates BODY.*
(DEFUN LET-IF (cond &QUOTE var-list &REST body)
  1"Perform the bindings in VAR-LIST only if COND is non-NIL; the execute the BODY.
Aside from the presence of COND, LET-IF is just like LET.
The variables are always bound as specials if they are bound;
therefore, strictly speaking only variables declared special should be used."*
  (PROGW (AND cond var-list)
    (EVAL-BODY-AS-PROGN body)))

;This is not a macro, for the sake of the compiler's definition of it,
;and for the sake of COMPILE-DRIVER.
(DEFUN COMPILER-LET (&QUOTE BINDLIST &REST BODY)
  1"Perform bindings in BINDLIST at evaluation or compilation time.
In interpreted code, this is the same as LET.
When found in code being compiled, the bindings are done at compile time,
and are not done when the compiled code is run."*
  (PROGV (MAPCAR #'(LAMBDA (X) (IF (ATOM X) X (CAR X))) bindlist)
         (MAPCAR #'(LAMBDA (X) (IF (ATOM X) NIL (EVAL (CADR X)))) bindlist)
    (*EVAL (IF (CDR body) (CONS 'PROGN body) (CAR body)))))

(DEFUN PROG1 (values &REST ignored)
  1"SYNTAX: (PROG1 form {form}* )
 Evaluates all forms in a sequence of forms ignoring the values
 returned by each except for the first which is returned as the
 value of the PROG1. (See MULTIPLE-VALUE-PROG1)."*
  
  values)

;;; This is the generator for prog and prog* macros
;;; If the prog has the name "t", then generate only one block and name it "t".
;;; If the prog has a name other than t then generate blocks named nil and <name>.
;;; If searching the body reveals no tags, then don't generate the tagbody.

(Defun PROG-GENERATOR (let-or-let* body)
  (MULTIPLE-VALUE-BIND (name vars body+decs)
      (IF (LISTP (CAR body)) 
	  (VALUES nil (CAR body) (CDR body))
	  (VALUES (CAR body) (CADR body) (CDDR body)))
    (MULTIPLE-VALUE-BIND (body-decs decs)
	(SI:PARSE-BODY body+decs nil nil)
      (LET ((tagbody-form (IF (DOLIST (form body-decs nil)  ;; search for tags
				(WHEN (TYPEP form '(OR symbol integer))
				  (RETURN t)))
			      `((TAGBODY . ,body-decs))
			      (APPEND body-decs (LIST nil)))))
	(WHEN decs
	  (DOLIST (d decs (setf decs (NREVERSE (The list decs))))	; jlm 4/13/89
	    (PUSH d tagbody-form)))
	(IF name
	    (IF (EQ name t)
		`(BLOCK ,name
		     (,let-or-let* ,vars . ,tagbody-form))
		`(BLOCK nil
		   (BLOCK ,name
		     (,let-or-let* ,vars . ,tagbody-form))))
	    `(BLOCK nil
	       (,let-or-let* ,vars . ,tagbody-form)))))))