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
;;;*
;1;; Copyright (C) 1986-1989 Texas Instruments Incorporated.  All rights reserved.*

;;  6/03/87 DNG - Fixed EVAL-WHEN to call *EVAL instead of EVAL. [SPR  5624]

(DEFUN IGNORE (&REST rest)
  1"Discard any number of arguments and return NIL."*
  (DECLARE (IGNORE rest))
  NIL)

;This definition assumes we are evalling.
;COMPILE-DRIVER takes care of compiling and loading.
(DEFUN EVAL-WHEN (&QUOTE TIMES &REST FORMS &AUX VAL)
  1"Process the FORMS only at the specified TIMES.
TIMES is a list which may include COMPILE, EVAL or LOAD.
EVAL means to eval the FORMS if the EVAL-WHEN is processed by the interpreter,
 or to compile and eval them when compiling to core.
LOAD means the compiler when compiling to a file should compile the FORMS
 if appropriate and then make them be executed when the XLD file is loaded.
COMPILE means the compiler should execute the forms
 at compile time.*
\1(EVAL LOAD) is equivalent to the normal state of affairs."*
    (OR (AND (LISTP TIMES)
	     (LOOP FOR TIME IN TIMES ALWAYS (MEMBER TIME '(GLOBAL:EVAL LOAD COMPILE CLI:EVAL) :TEST #'EQ)))
	(FERROR NIL 1"~S invalid EVAL-WHEN times;*
	1must be a list of EVAL, LOAD, and/or COMPILE."*
		    TIMES))
    (COND ((OR (MEMBER 'GLOBAL:EVAL TIMES :TEST #'EQ) (MEMBER 'CLI:EVAL TIMES :TEST #'EQ))
	   (DOLIST (FORM FORMS) (SETQ VAL (*EVAL FORM)))
	   VAL)))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
1;; WITH-STACK-LIST & WITH-STACK-LIST*
;;
;;  (WITH-STACK-LIST (var exp1 ... expN) body) does the following
;;
;;   1) Evaluates exp1 exp2,...expN creating a list of values L :=: (v1 ... vN)
;;      on the stack.
;;   2) Binds var to L and adds the binding as a frame to the lexical environment.
;;   3) Evaluates body in the new environment
;;
;;  WITH-STACK-LIST* does essentially the same except the list created on the
;;  stack terminates with a dotted-pair. This requires hacking CDR-codes.*


(DEFUN WITH-STACK-LIST (&QUOTE var-expressions &REST body)
  1"SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body)
  Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body)
  except that the list produced by MAPCAR resides on the stack and
  therefore DISAPPEARS when WITH-STACK-LIST is exited."*
  
  (IF (ZETALISP-ON-P)
      (PROGN
	(BIND (VALUE-CELL-LOCATION (CAR var-expressions))
	      (MAPCAR #'*EVAL (CDR var-expressions)))
	(EVAL-BODY-AS-PROGN body))
      (LET* ((specials (EXTRACT-SPECIAL-DECLARATIONS))
	     (list-of-values (%MAKE-STACK-LIST (LENGTH (CDR var-expressions))))
	     (symbol (CAR var-expressions)))
	(UNLESS (VARIABLE-P symbol) (BINDING-ERROR symbol))
	(DO ((nextstackpos list-of-values (CDR nextstackpos))
	     (restexps (CDR var-expressions) (CDR restexps)))
	    ((ATOM restexps)
	     (WITH-STACK-LIST (newframe (VALUE-CELL-LOCATION symbol) list-of-values)
	       (WHEN (SPECIAL-VAR-P symbol specials)
		 (BIND (VALUE-CELL-LOCATION symbol) list-of-values)
;; TGC		 (%P-STORE-DATA-TYPE (LOCF (CADR newframe)) DTP-EXTERNAL-VALUE-CELL-POINTER)
;;		 (%P-STORE-POINTER (LOCF (CADR newframe)) (VALUE-CELL-LOCATION symbol))
		 (%p-store-data-type-and-pointer
		   (LOCF (CADR newframe)) DTP-EXTERNAL-VALUE-CELL-POINTER (VALUE-CELL-LOCATION symbol)))
	       (WITH-STACK-LIST* (*INTERPRETER-ENVIRONMENT* newframe *INTERPRETER-ENVIRONMENT*)
		 (EVAL-BODY-AS-PROGN body))))
	  (SETF (CAR nextstackpos) (*EVAL (CAR restexps)))))))
      
(DEFUN WITH-STACK-LIST* (&QUOTE var-expressions &REST body)
  1"SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body)
  Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body)
  except that the list produced by MAPCAR resides on the stack and
  therefore DISAPPEARS when WITH-STACK-LIST is exited."*
  
  (IF (ZETALISP-ON-P)
      (PROGN
	(BIND (VALUE-CELL-LOCATION (CAR var-expressions))
	      (APPLY 'LIST* (MAPCAR '*EVAL (CDR var-expressions))))
	(EVAL-BODY-AS-PROGN body))
      (LET* ((len (LENGTH (CDR var-expressions)))
	     (list-of-values (%MAKE-STACK-LIST len))
	     (last-of-list (LAST list-of-values))
	     (symbol (CAR var-expressions))
	     (specials (EXTRACT-SPECIAL-DECLARATIONS)))
	(UNLESS (VARIABLE-P symbol) (BINDING-ERROR symbol))
	(DO ((nextstackpos list-of-values (CDR nextstackpos))
	     (restexps (CDR var-expressions) (CDR restexps)))
	    ((ATOM nextstackpos)
	     (IF (>= len 2)
		 (WITHOUT-INTERRUPTS 
		   1(%P-STORE-CDR-CODE (%POINTER last-of-list) CDR-ERROR)*
		   1(%P-STORE-CDR-CODE (1- (%POINTER last-of-list)) CDR-NORMAL)*))
;; TGC		   (%P-DPB CDR-ERROR %%Q-CDR-CODE (%POINTER last-of-list))
;;		   (%P-DPB CDR-NORMAL %%Q-CDR-CODE (1- (%POINTER last-of-list)))))
	     (WITH-STACK-LIST (newframe (VALUE-CELL-LOCATION symbol) list-of-values)
	       (WHEN (SPECIAL-VAR-P symbol specials)
		 (BIND (VALUE-CELL-LOCATION symbol) list-of-values)
;; TGC		 (%P-STORE-DATA-TYPE (LOCF (CADR newframe)) DTP-EXTERNAL-VALUE-CELL-POINTER)
;;		 (%P-STORE-POINTER (LOCF (CADR newframe)) (VALUE-CELL-LOCATION symbol))
		 (%p-store-data-type-and-pointer
		   (LOCF (CADR newframe)) DTP-EXTERNAL-VALUE-CELL-POINTER (VALUE-CELL-LOCATION symbol)))
	       (WITH-STACK-LIST* (*INTERPRETER-ENVIRONMENT* 
				   newframe *INTERPRETER-ENVIRONMENT*)
		 (EVAL-BODY-AS-PROGN body))))
	  (SETF (CAR nextstackpos) (*EVAL (CAR restexps)))))))



1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; COMMENT, DONT-OPTIMIZE, QUOTE & CONSTANTP
;;
;;  CONSTANTP is defined incorrectly in the COMMON LISP manual. It implies that quoted
;;  expressions are constants presumably with respect to evaluation. However evaluating
;;  a quoted expression strips the quote.
;;  QUOTE - despite the fact *EVAL and the compiler treat this specially (so that the
;;  following function is never entered by them) , it is necessary to keep this around.*


(DEFMACRO COMMENT (&REST ignored) ''COMMENT)

(DEFUN DONT-OPTIMIZE (&QUOTE &REST body)
  1"Prevents compiler optimization or open coding of its arguments.
  Aside from that effect, it is equivalent to PROGN."*
  
  (EVAL-BODY-AS-PROGN body))

(DEFUN QUOTE (&QUOTE x) x)

(DEFUN CONSTANTP (form)
  1"T if FORM always evaluates to the same thing.
This includes keyword symbols, and lists starting with QUOTE."*
  (COND ((CONSP form)
	 (EQ (CAR form) 'quote))
	((SYMBOLP form)
	 (OR (MEMBER form '(t nil) :TEST #'EQ) (KEYWORDP form) (GET form 'COMPILER:SYSTEM-CONSTANT)))
	(t t)))