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

;; 11/12/86 DNG - Moved DEFF-MACRO and MACRO to new file FUNCTION-MACROS.
;;  3/02/88 DNG - Modified MACROEXPAND-1 to use SUBST-EXPANDER instead of 
;;		SUBST-EXPAND-1 in order to fix problem with DEFSUBSTs whose
;;		interpreted definition has been deleted.
;;  7/01/88 CLM - Added :TEST #'EQ to call to MEMBER in SUBST-DEF? [spr 7432] 
;;  4/12/89 DNG - Redesigned MACROEXPAND-1 to use compile-file environments 
;;		instead of DECLARED-DEFINITION.

(PROCLAIM '(SPECIAL *INTERPRETER-ENVIRONMENT* *INTERPRETER-FUNCTION-ENVIRONMENT*))

;;  4/18/89 DNG - Fix to include a reference to the DATA expression when there 
;;		are no bindings to be done.  This is to ensure that it is always executed 
;;		if it has side-effects and to avoid compiler warnings about variable bound but not used.
(DEFMACRO DESTRUCTURING-BIND (VARIABLES DATA &BODY BODY)
  1"Bind the VARIABLES to the components of DATA that they match, then execute the BODY.
DATA is evaluated; the VARIABLES list or tree is not evaluated."*
  (declare (:expr-sxhash 266865.))
  (LET (*VARLIST* *VALLIST* *OPTIONAL-SPECIFIED-FLAGS* *DEFMACRO-&BODY-FLAG*
	symbol )
    (IF (SYMBOLP data) (SETF symbol data) (SETF symbol (gensym)))
    (DEFMACRO-&MUMBLE-CHEVEUX VARIABLES symbol 0)
    (if (and (null *VARLIST*) (null *OPTIONAL-SPECIFIED-FLAGS*))
	`(progn ,data (let () . ,body))
      `(LET* (,@(AND (NEQ symbol data) `((,symbol ,data)))
	      ,@*OPTIONAL-SPECIFIED-FLAGS*
	      . ,(MAPCAR 'LIST (NREVERSE *VARLIST*) (NREVERSE *VALLIST*)))
	 . ,BODY))))


(Defun DEFMACRO-SET-INDENTATION-FOR-ZWEI (name number)
  (when (symbolp name)
   (FUNCTION-SPEC-PUTPROP name (LIST number 1) 'zwei:lisp-indent-offset)))


;;;  Copy one macro's indentation to another.

(Defun DEFMACRO-COPY-INDENTATION-FOR-ZWEI (name name1)
   (LET ((y (FUNCTION-SPEC-GET name1 'zwei:lisp-indent-offset)))
     (WHEN (and y (symbolp name))
       (FUNCTION-SPEC-PUTPROP name y 'zwei:lisp-indent-offset))))

;;  4/13/89 DNG - Added optional ENVIRONMENT argument -- this has been 
;;		approved by X3J13 for the ANSI standard.
(DEFUN MACRO-FUNCTION (FSPEC &OPTIONAL ENVIRONMENT)
  1"If FSPEC has a function definition which is a macro, return the expander function; else NIL."*
  (BLOCK LOCAL
    (WHEN (SYMBOLP FSPEC)
      (LET ((LOCAL-DEF (COMPILER:GET-FROM-FRAME-LIST (LOCF (SYMBOL-FUNCTION FSPEC))
						     (COMPILER:ENV-FUNCTIONS ENVIRONMENT)
			 (RETURN-FROM LOCAL))))
	;; defined as a local function or macro
	(RETURN-FROM MACRO-FUNCTION
	  (AND (EQ (CAR-SAFE LOCAL-DEF) 'MACRO)
	       (CDR LOCAL-DEF))))))
  (COND ((FDEFINEDP FSPEC)
	 (LET ((DEF (FDEFINITION FSPEC)))
	   (COND ((EQ (CAR-SAFE DEF) 'MACRO)
		  (CDR DEF))
		 ((AND (SYMBOLP FSPEC)
		       (CDR (GET FSPEC 'ALTERNATE-MACRO-DEFINITION))))
		 ((SYMBOLP DEF)
		  (MACRO-FUNCTION DEF))
		 (T NIL))))
	((SYMBOLP FSPEC)
	 (CDR (GET FSPEC 'ALTERNATE-MACRO-DEFINITION)))
	(T NIL)))

1;; Used by SETF of MACRO-FUNCTION*
(DEFUN SET-MACRO-FUNCTION (FSPEC DEFINITION)
  (FDEFINE FSPEC (CONS 'MACRO DEFINITION) NIL)
   DEFINITION)



1;;; Macro expansion.*

(DEFUN MACROEXPAND (form &OPTIONAL environment)
  "Expand MACRO-CALL repeatedly until the result is not a macrocall."
  (LET (was-a-real-macro-call
	new-form
	expanded-flag)
    (DO-FOREVER
      (MULTIPLE-VALUE-SETQ (new-form expanded-flag) (MACROEXPAND-1 form environment))
      (IF (AND expanded-flag (NOT (EQ new-form form)))
	  (SETQ was-a-real-macro-call t 
		form new-form)
	  (RETURN (VALUES form was-a-real-macro-call))))))

(DEFVAR RECORD-MACROS-EXPANDED NIL
  1"Non-NIL means whenever a macro is expanded, push its name onto MACROS-EXPANDED."*)
(DEFVAR MACROS-EXPANDED NIL
  1"When a macro call is expanded, its name is pushed on here, if RECORD-MACROS-EXPANDED is non-NIL."*)
(DEFVAR *MACROEXPAND-HOOK* 'FUNCALL
  9"The value is a function called to expand a macro call2 and should behave as FUNCALL.The
function should expect three arguments which are:
   1) the expander function (obtained by calling, e.g. MACRO-FUNCTION)
   2) the form to be expanded (ye olde 'macrocall')
   3) an environment argument (usually NIL)**")

(DEFVAR *MACROEXPAND-ENVIRONMENT* NIL
  1"When macro expander functions are called, this is the lexical environment passed to MACROEXPAND-1.
If the expander calls MACROEXPAND itself, it can pass this as a rest arg."*)

;1; Note on 'environment' args*
;1;  Macroexpansion involves passing a form (i.e. a macrocall) and an environment argument.*
;1; Usually, the environment is setup as a stack list as in the following:*
;1;  (with-stack-list (environment nil local-function-environment)*
;1;       (macroexpand-1 form environment))*



;1;; Macroexpand-1 outline
;;;(IF a-local-definition?
;;;    (IF a-macro? (RETURN  expansion)
;;;*	1             (RETURN form))
;;;    (IF declared-definition?
;;;*	1    (IF a-macro? (RETURN expansion)
;;;*	1    (IF (OR (AND (LISTP declared-definition) (MEMQ (CAR declared-definition) '(SUBST named-subst)))
;;;*		1    (AND (TYPEP declared-definition 'compiled-function)
;;;*			1 (SETQ blah (get-interpreted-definition))
;;;*			1 (MEMQ (CAR blah) '(SUBST named-subst))))
;;;*		1(RETURN subst-expansion)
;;;*		1(RETURN form)))))*

(DEFCONSTANT *subst-lambdas* '(named-subst global:named-subst cli:subst global:subst))

(EVAL-WHEN (COMPILE)
  (DEFMACRO MACRO-DEF? (thing)
    `(AND (CONSP ,thing) (EQ (CAR ,thing) 'MACRO)))

  ;;  4/12/89 DNG - New macro FIND-DEFINITION replaces FIND-LOCAL-DEFINITION.
  (defmacro FIND-DEFINITION (symbol environment)
    ;; Return the function definition of SYMBOL in ENVIRONMENT, or NIL if not defined.
    ;; The second value is true if this is a local definition [such as made by FLET or MACROLET].
    (declare (values definition localp))
    (let ((block-name (gensym))
	  (env (gensym))
	  (locv (gensym)))
      `(block ,block-name
	 (let ((,env (compiler:env-functions ,environment)))
	   (unless (null ,env)
	     (LET ((.vcell. (LOCF (SYMBOL-FUNCTION ,symbol))))
	       (DOLIST (.frame. ,env)
		 (LET ((,locv (GET-LOCATION-OR-NIL (LOCF .frame.) .vcell.)))
		   (unless (null ,locv)
		     (return-from ,block-name
		       (values (contents ,locv)
			       (not (member .frame. (compiler:env-functions (compiler:env-global-env ,environment))
					    :test #'eq))
			       ))))))))
	 (values (IF (EQ compiler:TARGET-PROCESSOR compiler:HOST-PROCESSOR)
		     (and (FBOUNDP ,symbol)
			  (FDEFINITION-SAFE ,symbol 'MACRO))
		   (DECLARED-DEFINITION ,symbol (compiler:env-global-env ,environment)))
		 nil))))

 (comment ; old version (release 5)
    ;; the following macro generates code to check the 'local' environment for a macro definition for
    ;; THE SYMBOL <name>. Such a definition would be set up only by a MACROLET. If a macro definition 
    ;; for <name> is found, its expander function is returned.
  (DEFMACRO FIND-LOCAL-DEFINITION (name local-function-environment)
    `(IF ,local-function-environment
	 (LET ((vcell (LOCF (SYMBOL-FUNCTION ,name))))
	   (DOLIST (frame  ,local-function-environment)
	     (LET ((value (GET-LOCATION-OR-NIL (LOCF frame) vcell)))  ;; <value> is nil or a locative
	       (WHEN value (RETURN (CAR value))))))
	 nil))
  )
  
  (DEFMACRO RECORD-EXPANSION-OF-MACRO (name)
    `(WHEN record-macros-expanded (PUSHNEW ,name macros-expanded :test #'EQ)))

  ;;  4/12/89 DNG - Removed setting of subst-interpreted-definition - not needed anymore.
  (DEFMACRO SUBST-DEF? (global-definition)
    `(OR (COMPILED-SUBST? ,global-definition)
	 (And (CONSP ,global-definition) 
	      (MEMBER (CAR ,global-definition) *subst-lambdas* :test #'eq)  ;;07/01/88 clm - added :test
	      t)))
  )


;;  4/12/89 DNG - Redesigned using environments instead of DECLARED-DEFINITION .
(DEFUN MACROEXPAND-1 (form &OPTIONAL environment)
  1"Expand* 1FORM once and return the result.
Macro calls* 2and1 uses of SUBSTs are expanded.
The second value is T if there was something to expand.
If SYS:RECORD-MACROS-EXPANDED is non-NIL,
all macro names are pushed on SYS:MACROS-EXPANDED.
The value of *MACROEXPAND-HOOK* (which should behave like FUNCALL)
is used to invoke the expander function."**
  (DECLARE (VALUES EXPANSION EXPANDED-FLAG))
  (declare (inline compiler:environment-remote-p))
  (if (not (CONSP form))    ;; unless <form> is a list
      (values form nil)
    (LET ((macro-id (CAR form)))
      (TYPECASE macro-id
	(SYMBOL
	 (multiple-value-bind (definition localp)
	     (find-definition macro-id environment)
	   (when (and definition (symbolp definition))
	     (setq definition (declared-definition
				definition
				(compiler:env-global-env environment))))
	   (cond ((null definition) (values form nil))
		 ((macro-def? definition)
		  (unless localp
		    (RECORD-EXPANSION-OF-MACRO macro-id))
		  (LET ((*MACROEXPAND-ENVIRONMENT* environment))
		    (VALUES (FUNCALL *MACROEXPAND-HOOK* (CDR definition) form environment) T)))
		 ((SUBST-DEF? definition)
		  (unless localp
		    (RECORD-EXPANSION-OF-MACRO macro-id))
		  (FUNCALL *MACROEXPAND-HOOK* #'SUBST-EXPANDER form))
		 (T (VALUES form nil)))))
	(CONS
	 (IF (MEMBER (CAR macro-id) *subst-lambdas* :test #'eq)
	     (FUNCALL *MACROEXPAND-HOOK* #'SUBST-EXPANDER form)
	   (VALUES form nil)) )
	(T (VALUES form nil))))))



;1;; displacing macros*
;1;;  a device to avoid having to repeatedly expand a macrocall. This is only*
;1;; advantageous when the same (i.e., EQ) macrocall would be seen more than*
;1;; once , e.g. say in the body of a loop which is being interpreted. Also,*
;1;; once displaced, a macrocall will return the same form even if the macro*
;1;; is changed.*

;1;; displacing works as follows:*
;1;;  Consider the macrocall*
;1;;   1) (when (foo x) form1 form2 ... formN)*
;1;; When the evaluator sees this form, recognized as a macrocall, it calls*
;1;; *MACROEXPAND-AND-MAYBE-DISPLACE1 with the expander function for WHEN and the*
;1;; form 1) as arguments. The macrocall is then expanded and , if certain*
;1;; conditions are met, displaced by destructively replacing the form 1) *
;1;; with the form*
;1;;   2) (si:displaced (when (foo x) form1 form2 ... formN)*
;1;;                    (and (foo x) (progn form1 form2 ... formN)))*
;1;; By "destructively replacing", I mean that if p points to 1) before the*
;1;; displacement, then p now points to 2). When 2) is seen, the evaluator*
;1;; will again call on *MACROEXPAND-AND-MAYBE-DISPLACE 1(since DISPLACED is a macro)*
;1;; with the expander function for DISPLACED and 2) as arguments. This time,*
;1;; *MACROEXPAND-AND-MAYBE-DISPLACE 1will merely extract and return the third item*
;1;; of the list.*

;1;; restrictions
;;; Note that if the original form is not in working-storage-area, don't try
;;; to displace it.  It might be in the compiler temporary area, in which case
;;; there wouldn't be much point to displacing.  It can also be in INIT-LIST-AREA,
;;; in which case attempting to displace would crash the machine.*


;1;;*(defvar *displaced-macros* nil)  ;; debug

(DEFVAR *INHIBIT-DISPLACING-FLAG* nil
  1"Non-NIL makes displacing macros not actually displace."*)

(Defvar inhibit-displacing-flag)
(forward-value-cell 'inhibit-displacing-flag '*inhibit-displacing-flag*)

;;PHD 1/19/87 Redo the macroexpansion if  *INHIBIT-DISPLACING-FLAG* is true instead
;;PHD 2/12/87 call macroexpand instead of calling the macroexpander (bound to displaced).
;;of getting the old macroexpansion.
;;DNG 4/11/89 Add use of *INTERPRETER-EXTRA-ENVIRONMENT* .
(DEFUN MACROEXPAND-AND-MAYBE-DISPLACE (expander-function form)
  (WITHOUT-INTERRUPTS
    (IF (EQ (CAR form) 'displaced)
	(if *INHIBIT-DISPLACING-FLAG*
	    (with-interpreter-environment (*macroexpand-environment* *interpreter-environment*
								     *interpreter-function-environment*
								     *interpreter-extra-environment*)
		  (macroexpand (second form) *macroexpand-environment*))
	    (CADDR form))
	;; let us expand and then determine if <form> is a candidate for displacement
	(LET ((expanded-form
		(with-interpreter-environment (*macroexpand-environment* *interpreter-environment*
									 *interpreter-function-environment*
									 *interpreter-extra-environment*)
		  (FUNCALL expander-function form *macroexpand-environment*))))
	  (IF (OR 
		*INHIBIT-DISPLACING-FLAG*
		(NOT (%POINTERP form))1  ;; form must point to storage*
		(NOT (%POINTERP expanded-form))
		(NOT (= (%AREA-NUMBER form) working-storage-area))
		(NOT (= (%AREA-NUMBER expanded-form) working-storage-area)))
	      expanded-form  ;; if any of the above conditions are met, then DO NOT displace
	      ;;else displace
	      (LET* ((default-cons-area working-storage-area)
		     (displaced-form (LIST (CONS (CAR form) (CDR form)) expanded-form)))
		(RPLACA form 'displaced)
		(RPLACD form displaced-form)
		expanded-form)
	      )))))

(DEFMACRO DISPLACED (original-form expanded-form)
  (if *INHIBIT-DISPLACING-FLAG*
      original-form
    expanded-form))

;1; the following is used only by loop-translate.*

(DEFUN DISPLACE (original-form expanded-form &AUX area tem)
  1"Modify ORIGINAL-FORM so that, when evaluated, it acts like EXPANDED-FORM.
The list structure of ORIGINAL-FORM is altered so that it becomes a
call to SI:DISPLACED, which contains the expanded form and
a copy of the original contents of the expanded form."*
  (WITHOUT-INTERRUPTS
      (COND (*INHIBIT-DISPLACING-FLAG*)
	    ((EQ (CAR original-form) 'displaced)
	     (SETF (CADDR original-form) expanded-form))
	    ((AND (= (SETQ area (%AREA-NUMBER original-form)) working-storage-area)
		  (OR (NULL (%AREA-NUMBER expanded-form))
		      (= (%AREA-NUMBER expanded-form) area)))
	     ;; Above area tests are intended to avoid problems with the compiler
	     ;; temporary area, by not displacing anything with something that was
	     ;; consed in a temporary area.  Note that not only lists are in the
	     ;; temporary area, so are gensyms, strings, and flonums.
	     (LET ((default-cons-area area))
	       (SETQ tem `((,(CAR original-form) . ,(CDR original-form)) ,expanded-form)))
	     (RPLACA original-form 'displaced)
	     (RPLACD original-form tem)))
      expanded-form))


(defprop macro-type-check-warning t :error-reporter)

;;  COMPILER:EVAL-AT-LOAD-TIME-MARKER is defined in the file COMPILER;MINDEFS

(DEFUN MACRO-TYPE-CHECK-WARNING (macro object)
  1"Detect attempts by macros to check type at compile time of an eval-at-load-time.
A macro should call this function with OBJECT being the subexpression whose
type is to be checked and MACRO being the macro name.  If object is an
eval-at-load-time, an error happens."*
  (IF (AND (CONSP object) (EQ (CAR object) compiler:eval-at-load-time-marker))
      (FERROR nil 1"the macro ~s is attempting to check the type of an argument
at compile time, but the argument is #,~s,
whose type is not known until load time"*
	      macro (CDR object))))