;;;    -*- Mode:Common-Lisp; Package:Compiler; 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) 1985-1989 Texas Instruments Incorporated. All rights reserved.

;;;;   *-----------------------------------------------------------*
;;;;   |           --  TI Explorer Lisp Compiler  --               |
;;;;   |  This file defines the facilities used for defining the   |
;;;;   |  instruction set -- building the tables used by the       |
;;;;   |  compiler and disassembler from the DEFOP file.           |
;;;;   |  It also contains LOAD-FOR-TARGET and EVAL-FOR-TARGET     |
;;;;   |  which are used for manipulating cross-compilation target |
;;;;   |  environments.						   | 
;;;;   *-----------------------------------------------------------*

;;; Note: in release 1 and 2, this was part of the file "SYS;QCDEFS".
;;; 11/15/84 DNG - Add HOST-PROCESSOR, TARGET-PROCESSOR, COMPILING-FOR-EXPLORER-P .
;;; 12/07/84 DNG - Add LOAD-FOR-TARGET and EVAL-FOR-TARGET.
;;;  1/16/85 DNG - Define :CROSS-LOAD transformation for DEFSYSTEM.
;;;  2/05/85 DNG - Modify package handling in LOAD-FOR-TARGET.
;;;  2/08/85 DNG - New function INIT-SYSTEM-VAR-PROPERTIES .
;;;  3/08/85 DNG - SYMEVAL-FOR-TARGET and EVAL-FOR-TARGET check FILE-CONSTANTS-LIST.
;;;  7/10/85 DNG - Began changes for release 3; split file SYS;QCDEFS into
;;;		   COMPILER;DEFS and COMPILER;TARGET.
;;;  9/23/85 DNG -
;;; 10/02/85 DNG - New function LAP-VALUE.
;;; 11/23/85 DNG - Added support for module-op instructions.
;;;  1/15/86 DNG - Cross-compile for Cadr or Lambda not supported in release 3.
;;;  1/20/86 DNG - Updates to DEF-MISC-OP and DEF-AUX-OP.
;;;  2/17/86 DNG - Support cross-loading of macro definitions.
;;;  2/19/86 DNG - Enhancements to EVAL-FOR-TARGET.
;;;  3/04/86 DNG -
;;;  3/06/86 DNG - Moved some definitions from here to new file MINDEFS.
;;;  4/02/86 DNG - Converted from Zetalisp to Common Lisp.
;;;  5/07/86 DNG - Added LET-UNLESS-CONSTANT.
;;;  8/19/86 DNG - Compiler2 version 9.0.
;;; 10/20/86 DNG - Compiler2 version 11.0.
;;; 11/10/86 DNG - Add EVAL-FOR-TARGET property for SI:BOOTSTRAP-EXPORT.
;;; 11/24/86 DNG - Add optimizer for SYMEVAL-FOR-TARGET.
;;;  3/07/87 DNG - Updates to EVAL-FOR-TARGET and DEF-UCODE-ENTRY .
;;;------------------ The following done after Explorer release 3.0 ------
;;;  6/30/87 DNG - Fix EVAL-FOR-TARGET for local macros. [SPR 4655]
;;;------------------ The following done for Explorer release 5.0 ------
;;;  7/26/88 JHO - Added support for FILE-LOCAL-DECLARATIONS-DEF-ALIST
;;;  8/04/88 DNG - Update INIT-SYSTEM-VAR-PROPERTIES for ARRAY-FIELDS.
;;;  8/19/88 clm - Made minor modifications to JHOs support for
;;;                FILE-LOCAL-DECLARATIONS-DEF-ALIST.
;;;  8/29/88 clm - Added support for FILE-LOCAL-DECLARATIONS-DEF-ALIST
;;;                to EVAL-FOR-TARGET.
;;;------------------ The following done for Explorer release 6.0 ------
;;;  3/17/89 DNG - Removed some obsolete code for #-Elroy.
;;;  4/12/89 JLM - Changed (putprop ... usage to (setf (get ...
;;;  4/17/89 DNG - Comment out code for changing instruction set instead of 
;;;		being conditionalized on #+compiler:debug.


;;; ====  CROSS-COMPILATION SUPPORT  ====
;;;
;;;  Currently, three machine types are defined:
;;;    :CADR	 represents an LMI Cadr, Lambda, or Lambda/E.
;;;    :EXPLORER represents a TI Explorer using release 1 or 2 microcode.
;;;    :ELROY	 represents a TI Compact Lisp Machine or an Explorer
;;;		  running release 3 microcode.
;;;
;;;  Only the third one is actually supported by release 3 and later.

(DEFSUBST COMPILING-FOR-EXPLORER-P ()
  "Returns true when compiling for a TI processor; false for LMI."
  'T ; in release 1, was (NOT (EQ TARGET-PROCESSOR ':CADR) )
  )

(DEFMACRO LET-UNLESS-CONSTANT ( BINDING-LIST &BODY BODY )
  ;; Like LET, except that an attempt to bind a DEFCONSTANT will be ignored.
  ;; This is used to conditionalize bindings for things that may be constant
  ;; in some environments.
  ;;  5/07/86 DNG - Original.
  `(LET ,(LOOP FOR X IN BINDING-LIST
	       UNLESS (GET-FOR-TARGET (IF (ATOM X) X (FIRST X))
				      'SYSTEM-CONSTANT)
	       COLLECT X)
     . ,BODY))

(DEFMACRO WHEN-SUPPORTING-CROSS-COMPILATION ( &BODY BODY )
  ;; Include the body forms only if the cross-compilation feature is being supported.
  ;; This is used to avoid errors on trying to SETQ the constant TARGET-PROCESSOR.
  (IF (GET-FOR-TARGET 'TARGET-PROCESSOR 'SYSTEM-CONSTANT)
      NIL
    `(PROGN . ,BODY)))

(EVAL-WHEN (EVAL LISP:COMPILE LOAD)
  (DEFPROP WHEN-SUPPORTING-CROSS-COMPILATION T SI:MAY-SURROUND-DEFUN))

(DEFUN VALIDATE-TARGET ( TARGET &OPTIONAL ALLOW-LAMBDA )
  "Make sure that the argument is the name of a machine the compiler supports.
Returns the corresponding keyword to be used as the value of TARGET-PROCESSOR."
  ;; 2/5/85 - Added ALLOW-LAMBDA argument.
  ;; 7/9/85 - Added :CLM processor kind.
  ;;9/17/85 - Recognize "his son Elroy".
  ;;9/20/85 - Scoff at numeric values.
  ;;10/2/85 - "CLM" becomes a synonym for "Elroy".
  ;;2/17/86 - Allow "Explorer2" as a synonym for "Elroy".
  ;;5/07/86 - Require host processor when TARGET-PROCESSOR is constant.
  ;;5/22/86 - Recognize name VM2 instead of V2.
  (DECLARE (ARGLIST TARGET) (IGNORE ALLOW-LAMBDA))
  (ASSERT (NOT (FIXNUMP TARGET)) (TARGET)
	  "Compile for a ~A?  You've got to be kidding!" TARGET)
  (CHECK-ARG TARGET
	    (AND
	       (COND ((NULL TARGET)
		      (SETQ TARGET HOST-PROCESSOR))
		     ((OR (STRING-EQUAL TARGET ':EXPLORER)
			  (STRING-EQUAL TARGET "VM1"))
		      (SETQ TARGET ':EXPLORER))
		#|	; not supported since release 1
		     ((STRING-EQUAL TARGET ':LAMBDA)
		      (IF ALLOW-LAMBDA
			  (SETQ TARGET ':LAMBDA)
			(SETQ TARGET ':CADR)) )
		     ((STRING-EQUAL TARGET ':CADR)
		      (SETQ TARGET ':CADR))
		|#
		     ((OR (STRING-EQUAL TARGET "ELROY")
			  (STRING-EQUAL TARGET "LROY")
			  (STRING-EQUAL TARGET "CLM")
			  (STRING-EQUAL TARGET "HUMMING-BIRD")
			  (STRING-EQUAL TARGET "VM2")
			  (STRING-EQUAL TARGET "EXPLORER2"))
		      (SETQ TARGET ':ELROY))
		     #+compiler:debug ; temporary test environment
		     ((OR (STRING-EQUAL TARGET "JUDY"))
		      (SETQ TARGET ':JUDY))
		     (T NIL) )
	       (OR (EQ TARGET HOST-PROCESSOR)
		   '#.(NOT (GET 'TARGET-PROCESSOR 'SYSTEM-CONSTANT))))
	     "a recognized target machine"
	     STRINGP)
  TARGET )

;;;	---  Target Machine Evaluator  ---

(DEFUN PUTPROP-FOR-TARGET ( SYMBOL NEW-VALUE PROPERTY )
  ;;  9/13/86 DNG - Fix for arg being locative instead of symbol.
  (IF (OR (EQ TARGET-PROCESSOR HOST-PROCESSOR)
	  (NOT (SYMBOLP SYMBOL)))
      (SETF (GET SYMBOL PROPERTY) NEW-VALUE) 
    (UNLESS (EQUAL (GET-FOR-TARGET SYMBOL PROPERTY)
		   NEW-VALUE)
      (SETF (GETF (TARGET-PROPERTY-LIST SYMBOL) PROPERTY)
	    NEW-VALUE) ) ) )

(DEFUN PUT-TARGET-PROPERTY ( SYMBOL NEW-VALUE PROPERTY )
  ;; Like PUTPROP-FOR-TARGET except put target property even if same as for host.
  ;; 3/4/86 - Original.
  (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
      (SETF (GET SYMBOL PROPERTY) NEW-VALUE) 
    (SETF (GETF (TARGET-PROPERTY-LIST SYMBOL) PROPERTY)
	  NEW-VALUE) ) )

(WHEN-SUPPORTING-CROSS-COMPILATION 
(DEFUN (:PROPERTY REMPROP EVAL-FOR-TARGET) ( SYMBOL PROPERTY )
  ;;  9/08/86 - Fixed for first arg being a locative and enhance to remove propery
  ;;		from target list if it was there instead of giving it a NIL value.
  (IF (AND (SYMBOLP SYMBOL) ; [could be a locative]
	   (NOT (EQ TARGET-PROCESSOR HOST-PROCESSOR)))
      (LET ((PLIST (TARGET-PROPERTY-LIST SYMBOL)))
	(IF (REMF PLIST PROPERTY)
	    (SETF (TARGET-PROPERTY-LIST SYMBOL) PLIST)
	  (PUTPROP-FOR-TARGET SYMBOL NIL PROPERTY)))
    (REMPROP SYMBOL PROPERTY))))

(PROCLAIM '(INLINE SETPROP-FOR-TARGET))
(DEFUN SETPROP-FOR-TARGET ( SYMBOL PROPERTY VALUE )
  (PUTPROP-FOR-TARGET SYMBOL VALUE PROPERTY)
  VALUE )
(DEFSETF GET-FOR-TARGET SETPROP-FOR-TARGET)

(DEFUN FSET-FOR-TARGET ( SYMBOL VALUE )
  (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
      (FSET SYMBOL VALUE)
    (SETF (GETF (TARGET-PROPERTY-LIST SYMBOL) 'FUNCTION) VALUE) ) )

(DEFUN FSYMEVAL-FOR-TARGET ( SYMBOL )
  ;;  3/18/86 - Unencapsulate host definition before using as default target definition.
  ;;  8/11/86 - Look for compile-time definition in FILE-LOCAL-DECLARATIONS first.
  ;;  8/16/88 clm - Added support for new FILE-LOCAL-DECLARATIONS-DEF-ALIST.  List used
  ;;                by new function FILE-LOCAL-DEF to determine if symbol had been
  ;;                declared previously. 
  (let ((def (file-local-def symbol)))
    (when def
      (return-from fsymeval-for-target def)))
  (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
      (SYMBOL-FUNCTION SYMBOL)
    (LET (( PLIST (TARGET-PROPERTY-LIST SYMBOL) )
	  VALUE )
      (IF (AND PLIST
	       (NEQ (SETQ VALUE (GETF PLIST 'FUNCTION '|<Undefined>|))
		    '|<Undefined>|) )
	  VALUE
	;; Need to unencapsulate so that FDEFINE of (:TARGET ...) won't replace
	;; the encapsulated host definition.
	(SYMBOL-FUNCTION (SI:UNENCAPSULATE-FUNCTION-SPEC SYMBOL)) ))))
(DEFSETF FSYMEVAL-FOR-TARGET FSET-FOR-TARGET)

(DEFUN FBOUNDP-FOR-TARGET ( SYMBOL )
  (LET ( PLIST VALUE )
    (IF (AND (NEQ TARGET-PROCESSOR HOST-PROCESSOR)
	     (SETQ PLIST (TARGET-PROPERTY-LIST SYMBOL))
	     (NEQ (SETQ VALUE (GETF PLIST 'FUNCTION '|<Undefined>|))
		  '|<Undefined>|) )
	T
      (FBOUNDP SYMBOL) ) ) )

(DEFUN FDEFINE-FOR-TARGET (FUNCTION-SPEC DEFINITION &OPTIONAL CAREFULLY-FLAG NO-QUERY-FLAG)
  (FDEFINE (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
	       FUNCTION-SPEC
	     `(:TARGET ,TARGET-PROCESSOR ,FUNCTION-SPEC))
	   DEFINITION CAREFULLY-FLAG NO-QUERY-FLAG) )

(DEFUN FDEFINITION-FOR-TARGET ( FUNCTION-SPEC )
  ;;  3/17/89 DNG - Special handling when not cross-compiling.
  (IF (SYMBOLP FUNCTION-SPEC)
      (FSYMEVAL-FOR-TARGET FUNCTION-SPEC)
    (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
	(DECLARED-DEFINITION FUNCTION-SPEC *COMPILE-FILE-ENVIRONMENT*)
      (WITH-STACK-LIST ( FSPEC :TARGET TARGET-PROCESSOR FUNCTION-SPEC )
	(TARGET-FUNCTION-SPEC-HANDLER 'FDEFINITION FSPEC ) ))))

(DEFUN BOUNDP-FOR-TARGET ( SYMBOL )
  (OR (BOUNDP SYMBOL)
      (LET ( PLIST )
	(AND (NEQ TARGET-PROCESSOR HOST-PROCESSOR)
	     (SETQ PLIST (TARGET-PROPERTY-LIST SYMBOL))
	     (NEQ (GETF PLIST 'VALUE '|<Undefined>|)
		  '|<Undefined>|) ) ) ) )

(WHEN-SUPPORTING-CROSS-COMPILATION 
(DEFUN (:PROPERTY VARIABLE-LOCATION EVAL-FOR-TARGET) (&QUOTE SYMBOL)
  ;;  8/07/86 DNG - Original.
  (LET ((LOC (FUNCALL #'VARIABLE-LOCATION SYMBOL))) ; call evaluator's definition
    (IF (OR (EQ TARGET-PROCESSOR HOST-PROCESSOR) ; want host environment
	    (NOT (EQ LOC (%EXTERNAL-VALUE-CELL SYMBOL)))) ; or local variable
	LOC
      ;; Else need location of a special variable in the target environment.
      (LET (( PLIST (TARGET-PROPERTY-LIST SYMBOL) ))
	(WHEN (EQ (GETF PLIST 'VALUE '|unbound|) '|unbound|)
	  ;; not already in the property list, need to add it.
	  (SETF (GETF (TARGET-PROPERTY-LIST SYMBOL) 'VALUE)
		(IF (BOUNDP SYMBOL)
		    (SYMBOL-VALUE SYMBOL) ; default value from host
		  '|<Undefined>|)) ; so it looks undefined to BOUNDP-FOR-TARGET and SYMEVAL-FOR-TARGET
	  (SETQ PLIST (TARGET-PROPERTY-LIST SYMBOL)))
	;; now return the location of the entry in the property list.
	(LOCF (GETF PLIST 'VALUE))))))

(DEFUN DEFVAR-1-FOR-TARGET (&QUOTE SYMBOL &OPTIONAL (VALUE ':UNBOUND) DOCUMENTATION)
  ;;  2/17/86 - Record source file name.
  ;;  3/08/86 - Allow (EQ TARGET-PROCESSOR HOST-PROCESSOR).
  ;;  9/03/86 - Reset SYSTEM-CONSTANT property.
  (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
      (FUNCALL #'SI:DEFVAR-1 SYMBOL VALUE DOCUMENTATION)
    (PROGN
      (AND (CONSP SYMBOL) (EQ (CAR SYMBOL) 'QUOTE)
	   (SETQ SYMBOL (CADR SYMBOL)))
      (WHEN (RECORD-SOURCE-FILE-NAME-FOR-TARGET SYMBOL 'DEFVAR)
	(WHEN (NULL (GET SYMBOL 'SPECIAL))
	  (SETF (GET SYMBOL 'SPECIAL)
		(OR FDEFINE-FILE-PATHNAME T)) )
	(SETF (GET-FOR-TARGET SYMBOL 'COMPILER:SYSTEM-CONSTANT) NIL)
	(AND (NEQ VALUE ':UNBOUND)
	     (OR FS:THIS-IS-A-PATCH-FILE
		 (EQ (GETF (TARGET-PROPERTY-LIST SYMBOL) 'VALUE '|<Undefined>|)
		     '|<Undefined>|)
		 SI:*FORCE-DEFVAR-INIT*)
	     (SET-FOR-TARGET SYMBOL (EVAL-FOR-TARGET VALUE))))
      (IGNORE DOCUMENTATION)
      SYMBOL)))

(DEFUN DEFCONST-1-FOR-TARGET (&QUOTE SYMBOL &EVAL VALUE
			      &OPTIONAL DOCUMENTATION (CONSTANTP NIL))
  ;;  2/17/86 - Record source file name.
  ;;  3/08/86 - Allow (EQ TARGET-PROCESSOR HOST-PROCESSOR).
  ;;  9/03/86 - New argument CONSTANTP.
  (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
      (FUNCALL #'SI:DEFCONST-1 SYMBOL VALUE DOCUMENTATION CONSTANTP)
    (PROGN
      (AND (CONSP SYMBOL) (EQ (CAR SYMBOL) 'QUOTE)
	   (SETQ SYMBOL (CADR SYMBOL)))
      (WHEN (RECORD-SOURCE-FILE-NAME-FOR-TARGET SYMBOL 'DEFVAR)
	(WHEN (NULL (GET SYMBOL 'SPECIAL))
	  (SETF (GET SYMBOL 'SPECIAL)
		(OR FDEFINE-FILE-PATHNAME T)) )
	(SET-FOR-TARGET SYMBOL VALUE))
      SYMBOL)))

(DEFUN ADD-PROPERTY-FOR-TARGET (SYMBOL LIST)
  (LET (( OLD (GET-FOR-TARGET LIST 'VALUE) ))
    (UNLESS (MEMBER SYMBOL OLD :TEST #'EQ) 
      (SET-FOR-TARGET LIST (CONS SYMBOL OLD)) ) ) )

) ; end of WHEN-SUPPORTING-CROSS-COMPILATION 

(DEFPROP GET		GET-FOR-TARGET		EVAL-FOR-TARGET)
(DEFPROP PUTPROP	PUTPROP-FOR-TARGET	EVAL-FOR-TARGET)
(DEFPROP SI:SETPROP	SETPROP-FOR-TARGET	EVAL-FOR-TARGET)
(DEFPROP SET		SET-FOR-TARGET		EVAL-FOR-TARGET)
(DEFPROP SYMEVAL	SYMEVAL-FOR-TARGET	EVAL-FOR-TARGET)
(DEFPROP SYMBOL-VALUE	SYMEVAL-FOR-TARGET	EVAL-FOR-TARGET)
(DEFPROP FSET		FSET-FOR-TARGET		EVAL-FOR-TARGET)
(DEFPROP FDEFINE	FDEFINE-FOR-TARGET	EVAL-FOR-TARGET)
(DEFPROP FDEFINITION	FDEFINITION-FOR-TARGET	EVAL-FOR-TARGET)
(DEFPROP FBOUNDP	FBOUNDP-FOR-TARGET	EVAL-FOR-TARGET)
(DEFPROP SYMBOL-FUNCTION FSYMEVAL-FOR-TARGET	EVAL-FOR-TARGET)
(DEFPROP FSYMEVAL	FSYMEVAL-FOR-TARGET	EVAL-FOR-TARGET)
(DEFPROP BOUNDP		BOUNDP-FOR-TARGET	EVAL-FOR-TARGET)
(DEFPROP SI:GET-DEFINED-VALUE	IDENTITY	EVAL-FOR-TARGET) ; used in QCOM

(WHEN-SUPPORTING-CROSS-COMPILATION 
(DEFPROP SI:DEFCONST-1	DEFCONST-1-FOR-TARGET	EVAL-FOR-TARGET)
(DEFPROP SI:DEFVAR-1	DEFVAR-1-FOR-TARGET	EVAL-FOR-TARGET)
(DEFPROP SI:ADD-PROPERTY ADD-PROPERTY-FOR-TARGET EVAL-FOR-TARGET)
(DEFPROP RECORD-SOURCE-FILE-NAME RECORD-SOURCE-FILE-NAME-FOR-TARGET EVAL-FOR-TARGET)
(DEFPROP FORWARD-VALUE-CELL IGNORE		EVAL-FOR-TARGET)
(DEFPROP MAKE-AREA	 IGNORE		EVAL-FOR-TARGET)
(DEFPROP SI:BOOTSTRAP-EXPORT  EXPORT	EVAL-FOR-TARGET) ; added 11/10/86

(DOLIST ( X  '(;; These cannot be interpreted because they use sub-primitives.
	       MAPC MAPCAR MAPLIST MAPL MAPCAN MAPCON SUBSET SUBSET-NOT
	       ;; We can't evaluate the evaluator itself.
	       GLOBAL:EVAL CLI:EVAL SI:*EVAL APPLY LEXPR-FUNCALL CALL
	       BLOCK TAGBODY GO RETURN RETURN-FROM PROGN *CATCH CLI:CATCH
	       WITH-STACK-LIST WITH-STACK-LIST* SI:ONCE-ONLY MULTIPLE-VALUE-LIST
	       NTH-VALUE MULTIPLE-VALUE-PROG1 MULTIPLE-VALUE MULTIPLE-VALUE-SETQ
	       SI:DISPLACED  VARIABLE-BOUNDP VARIABLE-MAKUNBOUND 
	       ;; Note: LET, DO, PROG, etc. are handled specially in EVAL-FOR-TARGET
	       ;;	and must not be listed here.
	       ;; The following can't be interpreted because they call themselves.
	       IF AND OR COND VALUES-LIST 
	       CEILING TRUNCATE ROUND MAX MIN > < = <= >= /= + - *
	       MOD GLOBAL:REM GLOBAL:/ LOGAND LOGIOR LOGXOR ODDP EVENP
	       ;; These are just too slow evaluated.
	       COPYTREE COPY-TREE  APPEND EXTRACT-DECLARATIONS REVERSE SORT
	       SETF INCF DECF  EVAL-WHEN
	       SI:COPY-OBJECT SI:SUBLIS-EVAL-ONCE SI:SUBLIS-1 STRING-APPEND
	       ;; These use area numbers, so must use host version.
	       GENSYM MAKE-SYMBOL
	       ;; These compiler functions handle the target environment themselves.
	       DEFOP DEF-MISC-OP DEF-AUX-OP DEF-BRANCH-OP DEF-CALLOP
	       ;; Other things that need to be done in the host environment:
	       SPECIAL UNSPECIAL PROCLAIM WARN FERROR GETDECL PUTDECL
	       PRINT PRINC PRIN1 GLOBAL:FORMAT CLI:FORMAT GLOBAL:READ CLI:READ
	       INTERN FIND-PACKAGE PKG-FIND-PACKAGE MAKE-PACKAGE IN-PACKAGE SHADOW
	       SHADOWING-IMPORT EXPORT UNEXPORT USE-PACKAGE UNUSE-PACKAGE IMPORT
	       PACKAGE-NAME
	       ) )
  ;;(PUTPROP X X 'EVAL-FOR-TARGET)		; jlm 4/12/89
  (setf (get x 'eval-for-target) x))
)
(DEFVAR *POSSIBLE-SPECIAL-BINDINGS* NIL)

(DEFUN BOUND-SYMBOL-P ( SYMBOL ) ; does the symbol have a special binding?
  ;;  2/20/86 - Original.
  (MULTIPLE-VALUE-BIND ( VALUE VALUE-LOC LOC )
      (SYMEVAL-IN-STACK-GROUP SYMBOL CURRENT-STACK-GROUP 0)
    (DECLARE (IGNORE VALUE LOC))
    (NOT (EQ VALUE-LOC (LOCF (SYMBOL-VALUE SYMBOL))))))

(DEFUN EVAL-FOR-TARGET ( FORM &OPTIONAL (ENVIRONMENT *COMPILE-FILE-ENVIRONMENT*) &AUX TM)
  "Evaluate FORM, using definitions from the target machine's environment."
  ;;  3/08/85 - Check FILE-CONSTANTS-LIST even for host machine.
  ;;  2/19/86 - Use target definitions of macros and functions;
  ;;		upgrade to handle local variables correctly.
  ;;  2/20/86 - Fix handling of special variable bindings.
  ;;  2/22/86 - Fix to evaluate ADVISE and SI:%MAKE-POINTER in host environment.
  ;;  3/04/86 - Make sure *POSSIBLE-SPECIAL-BINDINGS* is bound to T when evaluating
  ;;		special forms LET, DO, PROG, etc.
  ;;  3/19/86 - Treat PROGV, PROGW, and MULTIPLE-VALUE-BIND like LET.
  ;;  4/24/86 - Remove use of ARGS-INFO for VM2.
  ;;  8/12/86 - Override host definition of FUNCTION to avoid problem of
  ;;		returning a closure object when it should be (MACRO . closure) instead.
  ;; 11/18/86 - Remove above FUNCTION hack for release 3.
  ;;  3/07/87 - Don't do special handling for MAKE-ARRAY unless cross-compiling.
  ;;  6/30/87 - Fix for local macros. [SPR 4655]
  ;;  8/26/88 clm - Added support for new FILE-LOCAL-DECLARATIONS-DEF-ALIST.
  ;;  3/17/89 DNG - Now keeping compile-time function definitions in the 
  ;;		environment instead of in FILE-LOCAL-DECLARATIONS-DEF-ALIST.
  ;;  4/07/89 DNG Fixes to environment handling.
  ;;  4/11/89 DNG - Add binding of *INTERPRETER-EXTRA-ENVIRONMENT* .
  ;;  4/25/89 DNG - No longer need to check FILE-CONSTANTS-LIST or FILE-LOCAL-DECLARATIONS.
  (COND ((NULL FORM) NIL)

	((SYMBOLP FORM)
	 (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
	     (LET ((SI::*INTERPRETER-ENVIRONMENT* (ENV-VARS ENVIRONMENT)))
	       (*EVAL FORM))
	  (IF (KEYWORDP FORM) ; keywords eval to themselves
	     FORM
	   (PROGN
	     (WHEN (COMMON-LISP-ON-P)
	       ;; The following adapted from SI:EVAL1-SYMBOL-LOOKUP 
	       ;; first search the lexical and then the global
	       (LET ((vcell (LOCF (SYMBOL-VALUE FORM)))) ;; fetch the value cell address
		 (DO ((tailenv (CAR ENVIRONMENT) (CDR tailenv)) ;; search each frame
		      slot)
		     ((ATOM tailenv) ) ;; if no binding in lexical - search global
		   (SETQ slot (GET-LEXICAL-VALUE-CELL (CAR tailenv) vcell))
		   (WHEN slot		   ; return value of symbol in frame
		     (RETURN-FROM EVAL-FOR-TARGET (CAR slot))))))
	     (LET (( TEMP (ASSOC FORM FILE-CONSTANTS-LIST :TEST #'EQ) ))
	       (IF TEMP 
		   ;; Value defined by a DEFCONSTANT earlier in the current
		   ;; file being compiled.
		   (CDR TEMP)
		 (IF (AND *POSSIBLE-SPECIAL-BINDINGS*
			  (BOUNDP FORM)
			  (OR (NULL (GET FORM TARGET-PROCESSOR))
			      (BOUND-SYMBOL-P FORM))
			  (NOT (GET-FOR-TARGET FORM 'SYSTEM-CONSTANT)))
		     ;; Looks like there has been a special binding, use the current value.
		     (SYMBOL-VALUE FORM) 
		   ;; Else, get global target value.
		   (SYMEVAL-FOR-TARGET FORM)
		   )))))))

	((ATOM FORM) FORM)

	((AND (EQ (FIRST FORM) 'QUOTE) (= (LENGTH FORM) 2))
	 (SECOND FORM))

	((EQ (FIRST FORM) 'FUNCTION)
	 (FUNCTION-FOR-TARGET (SECOND FORM) ENVIRONMENT))

	((AND (EQ TARGET-PROCESSOR HOST-PROCESSOR)
	      ;;(NULL FILE-CONSTANTS-LIST) ; don't need these now -- DNG 4/25/89
	      ;;(NULL FILE-LOCAL-DECLARATIONS)
	      )
	 ;; no need for any special handling.
	 (LET ((SI:*INTERPRETER-ENVIRONMENT* (ENV-VARS ENVIRONMENT))
	       (SI:*INTERPRETER-FUNCTION-ENVIRONMENT* (ENV-FUNCTIONS ENVIRONMENT))
	       (SI::*INTERPRETER-EXTRA-ENVIRONMENT* (ENV-EXTRA ENVIRONMENT)))
	   (*EVAL FORM)))

	((AND (NEQ TARGET-PROCESSOR HOST-PROCESSOR)
		  (MEMBER (FIRST FORM)
			  '(SI::ENCAPSULATION-LET	; for ADVISE in LOAD-FOR-TARGET
			     %MAKE-POINTER	; must evaluate data type for host
			     MAKE-ARRAY MAKE-SYMBOL-IN-AREA	; need to evaluate area number for host
			     )
			  :TEST #'EQ))
	 ;; need to evaluate in host environment
	 (SI:*EVAL FORM))

	((EQ (FIRST FORM) 'SETQ)
	 (LET (( VALUE NIL ))
	   (DO ((ARGS (REST FORM) (CDDR ARGS)))
	       ((NULL ARGS))
	     (LET (( SYMBOL (FIRST ARGS) ))
	       (SETQ VALUE (EVAL-FOR-TARGET (SECOND ARGS) ENVIRONMENT) )
	       (BLOCK SET
		 (UNLESS (ZETALISP-ON-P)
		   ;; The following adapted from SI:INTERPRETER-SET 
		   (LET ((vcaddress (LOCF (SYMBOL-VALUE symbol)))) ; get value cell address
		     (DO ((tail (CAR environment) (CDR tail)))
			 ((ATOM tail))
		       (LET ((slot (GET-LEXICAL-VALUE-CELL (CAR tail) vcaddress)))
			 (IF slot
			     (RETURN-FROM SET (SETF (CAR slot) value)))))))
		 (IF (AND *POSSIBLE-SPECIAL-BINDINGS*
			  (BOUNDP SYMBOL)
			  (OR (NULL (GET SYMBOL TARGET-PROCESSOR))
			      (BOUND-SYMBOL-P SYMBOL))
			  (NOT (GET SYMBOL 'SYSTEM-CONSTANT)))
		     ;; Looks like there has been a special binding, replace the current value.
		     (SET SYMBOL VALUE)
		   (SET-FOR-TARGET SYMBOL VALUE) ) )
	       ) )
	   VALUE ) )

	((SETQ TM (GET (FIRST FORM) 'EVAL-FOR-TARGET))
	 (LET ((*EVALHOOK* #'EVAL-FOR-TARGET))
	   (SI:EVAL1 (IF (EQ TM (FIRST FORM))
			 FORM
		       (CONS TM (REST FORM)))
		     T) ) )

	((EQ (FIRST FORM) 'DEFPROP)
	 (APPLY #'PUTPROP-FOR-TARGET (REST FORM)))

	;;((EQ (FIRST FORM) 'FUNCTION)
	;;  (FUNCTION-FOR-TARGET (SECOND FORM) (SECOND ENVIRONMENT)))

	(T (LET (( DEF (AND (ATOM (FIRST FORM))
			    (NOT (MEMBER (FIRST FORM)
					 '(LET LET* DO DO* PROG PROG* DO-NAMED DO-NAMED*
					   LET-IF COMPILER-LET PROGV PROGW MULTIPLE-VALUE-BIND)
					 :TEST #'EQ) )
			    (OR (AND (COMMON-LISP-ON-P)
				     ;; first search the lexical and then the global
				     (GET-FROM-FRAME-LIST (LOCF (SYMBOL-FUNCTION  (FIRST FORM)))
							  (ENV-FUNCTIONS ENVIRONMENT) NIL))
				(DECLARED-DEFINITION (FIRST FORM) *COMPILE-FILE-ENVIRONMENT*))) ))
	     (COND ((NULL DEF)
		    (LET (( *EVALHOOK* #'EVAL-FOR-TARGET )
			  ( *POSSIBLE-SPECIAL-BINDINGS* T ))
		      (SI:EVAL1 FORM T) ))
		   ((EQ (CAR-SAFE DEF) 'MACRO)
		    (EVAL-FOR-TARGET (LET (( *EVALHOOK* #'EVAL-FOR-TARGET ))
				       (FUNCALL (CDR DEF) FORM  ENVIRONMENT) )
				     ENVIRONMENT))
		   (T (LET (( *EVALHOOK* #'EVAL-FOR-TARGET )
			    ( *POSSIBLE-SPECIAL-BINDINGS* T ))
			(SI:EVAL1 (CONS DEF (REST FORM)) T) )))
	     ))))

(defun FUNCTION-FOR-TARGET (function ENVIRONMENT)
  ;;  8/12/86 DNG - To work around limitations of the FUNCTION function, add
  ;;		special handling for MACRO forms and don't create closures with
  ;;		null environments.
  ;; 11/18/86 DNG - Remove above hack for release 3.
  ;;  3/17/89 DNG - Use new macro GET-FROM-FRAME-LIST to simplify the source code.
  ;;  4/07/89 DNG - When making a closure, close over the function 
  ;;		environment.  Accept an environment object as the second argument, not 
  ;;		just a function list.
  ;;  4/11/89 DNG - Add binding of *INTERPRETER-EXTRA-ENVIRONMENT* .
  ;;  4/25/89 DNG - Close over *INTERPRETER-ENVIRONMENT* also (used for DEFCONSTANTs).
  (cond ((symbolp function)
	 (if (ZETALISP-ON-P)
	     (FSYMEVAL-FOR-TARGET function)
	   (GET-FROM-FRAME-LIST (FUNCTION-CELL-LOCATION function) (env-functions ENVIRONMENT)
	     (FSYMEVAL-FOR-TARGET function))))
	((functionp function t)
	 (if (OR (ZETALISP-ON-P)
		 (MEMBER '&QUOTE (ARGLIST FUNCTION T))) ; special form can't be a closure
	     function
	   (let* ((var-environment (env-vars ENVIRONMENT))
		  (si::*interpreter-environment*
		    (and (not (equal var-environment '(nil)))
			 var-environment))
		  (function-environment (env-functions ENVIRONMENT))
		  (si::*interpreter-function-environment*
		    (and (not (equal FUNCTION-ENVIRONMENT '(nil)))
			 FUNCTION-ENVIRONMENT))
		  (si::*interpreter-extra-environment* (env-extra environment)))
	     (FUNCALL #'FUNCTION FUNCTION)	; make a closure
	     )))
	(t (FDEFINITION-FOR-TARGET function)) ))

(WHEN-SUPPORTING-CROSS-COMPILATION 
(DEFUN (:PROPERTY LOAD EVAL-FOR-TARGET) (FILE &REST OPTIONS &KEY PKG (VERBOSE T) SET-DEFAULT-PATHNAME PRINT)
  ;;  7/09/86 DNG - Original.
  ;;  9/12/86 DNG - Bind some variables so LOAD-FOR-TARGET will work right within COMPILE-FILE.
  ;;  7/26/88 JHO - Added support for FILE-LOCAL-DECLARATIONS-DEF-ALIST
  ;;  4/07/89 DNG - Replace FILE-LOCAL-DECLARATIONS-DEF-ALIST with 
  ;;		*TARGET-ENVIRONMENT* and *COMPILE-FILE-ENVIRONMENT*.
  SET-DEFAULT-PATHNAME PRINT
  (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
      (APPLY #'LOAD FILE OPTIONS)
    (LET*((TARGET TARGET-PROCESSOR)
	  (TARGET-PROCESSOR HOST-PROCESSOR)
	  (UNDO-DECLARATIONS-FLAG NIL)
	  (*TARGET-ENVIRONMENT* (ENSURE-TARGET-ENVIRONMENT TARGET))
	  (*COMPILE-FILE-ENVIRONMENT* *TARGET-ENVIRONMENT*)
	  (LOCAL-DECLARATIONS NIL)
	  (FILE-LOCAL-DECLARATIONS NIL)
	  ;;(FILE-LOCAL-DECLARATIONS-DEF-ALIST NIL)
	  )
      (LOAD-FOR-TARGET FILE TARGET PKG (NOT VERBOSE)) )))
)

;;;	 ---  Target machine loader  ---

(DEFVAR *RECORD-ALL-TARGET-DEFINITIONS* T
  "When true, LOAD-FOR-TARGET will record the source file names of all definitions.")

(DEFUN LOAD-FOR-TARGET ( FILE TARGET-MACHINE &OPTIONAL DEFAULT-PACKAGE NO-MSG-P )
  "Load definitions for cross-compilation."
  ;; Note: the package argument is a default rather than an override like the
  ;; other loaders.  This is so MAKE-SYSTEM will not force QCOM to be loaded 
  ;; in the COMPILER package when it really needs to be in SI.  The default
  ;; is needed, however, so that DEFMIC does get loaded into COMPILER.
  ;; 2/05/85
  ;; 2/08/85 - Use INIT-SYSTEM-VAR-PROPERTIES.
  ;; 2/15/85 - Fix ADVISE so FSET works in other processes.
  ;; 2/19/85 - Bind FILE-CONSTANTS-LIST to NIL for SYMEVAL-FOR-TARGET.
  ;; 9/20/85 - *FEATURES* for release 3 includes both :EXPLORER and new name.
  ;; 2/13/86 - Advise FDEFINE.
  ;; 2/18/86 - Force file type to ".LISP".
  ;; 2/20/86 - Bind OPTIMIZE-SWITCH to itself to localize (PROCLAIM '(OPTIMIZE...)).
  ;; 2/22/86 - Modify ADVISE on FDEFINE to prevent endless recursion on :TARGET fspec.
  ;; 3/03/86 - Fix to set SYSTEM-CONSTANT property when LROY_QCOM is loaded a second time.
  ;; 3/13/86 - Bind *DEFAULT-DEFS-FROM-HOST* to T.
  (LET (( TARGET (VALIDATE-TARGET TARGET-MACHINE) ))
  (LET-IF DEFAULT-PACKAGE ((*PACKAGE* (FIND-PACKAGE DEFAULT-PACKAGE)))
  (IF (EQ TARGET HOST-PROCESSOR)
      (LOAD FILE :VERBOSE (NOT NO-MSG-P) ) ; ordinary load
    (WHEN-SUPPORTING-CROSS-COMPILATION 
     (UNWIND-PROTECT
	(LET ( PATHNAME )
	  ;; First set up the target environment.
	  (ADVISE FSET :AROUND LOAD-FOR-TARGET NIL
	    (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
		:DO-IT ; when FSET called from another process
	      (APPLY #'FSET-FOR-TARGET ARGLIST) ) ) ; capture function definitions
	  (ADVISE FDEFINE :AROUND LOAD-FOR-TARGET NIL
	    (IF (OR (EQ TARGET-PROCESSOR HOST-PROCESSOR)
		    (EQ (CAR-SAFE (FIRST ARGLIST)) ':TARGET))
		:DO-IT 
	      (APPLY #'CROSS-LOAD-FDEFINE ARGLIST) ) )
	  (LET* ((*BREAK-BINDINGS* (CONS '( TARGET-PROCESSOR HOST-PROCESSOR )
					 *BREAK-BINDINGS*) )
		 ;; Above is to minimize wierdness if BREAK is entered;
		 ;; I wish I knew a way to do the same for the debugger.
		 (*FEATURES* (IF (EQ TARGET :EXPLORER)
				(APPEND '(:EXPLORER :RAVEN :TI)
					(REMOVE ':CADR (THE LIST *FEATURES*) :TEST #'EQ) )
			       (IF (MEMBER TARGET '(:CADR :LAMBDA) :TEST #'EQ) 
				   (CONS TARGET
					 (REMOVE ':EXPLORER (THE LIST *FEATURES*) :TEST #'EQ) )
				 (CONS TARGET *FEATURES*) ) ) )
		( FILE-CONSTANTS-LIST NIL )
		( TARGET-PROCESSOR TARGET )
		( OPTIMIZE-SWITCH OPTIMIZE-SWITCH )
		( SI:*LOADER-EVAL* 'EVAL-FOR-TARGET )
		( *POSSIBLE-SPECIAL-BINDINGS* NIL )
		( *DEFAULT-DEFS-FROM-HOST* 'T ) ; needed for bootstrapping
		;; Note: *LOADER-EVAL* is bound for the loader to look at
		;;  instead of binding *EVALHOOK* because EVAL1 gets called
		;;  for other things (such as opening the file) besides
		;;  evaluating the file being loaded.
		( OLD-CONSTANTS (SYMEVAL-FOR-TARGET 'SYSTEM-CONSTANT-LISTS) )
		( OLD-VARS (SYMEVAL-FOR-TARGET 'SYSTEM-VARIABLE-LISTS) ) )
	    (DECLARE (SPECIAL SI:*LOADER-EVAL*))
	    ;; Now load the file.  Note that only .LISP files are supported.
	    (LET (( PATH (FS:MERGE-PATHNAME-DEFAULTS
			   FILE FS:LOAD-PATHNAME-DEFAULTS :LISP) ))
	      (UNLESS (EQ (SEND PATH :TYPE) :LISP)
		(SETQ PATH (SEND PATH :NEW-PATHNAME :TYPE :LISP)))
	      (SETQ PATHNAME (READFILE PATH NIL NO-MSG-P)) )
	    ;; The following is needed to complete initializations for file COLD-BAND;QCOM.
	    (UNLESS (AND (EQ (SYMEVAL-FOR-TARGET 'SYSTEM-CONSTANT-LISTS) OLD-CONSTANTS)
			 (EQ (SYMEVAL-FOR-TARGET 'SYSTEM-VARIABLE-LISTS) OLD-VARS)
			 (GET-FOR-TARGET 'SI:%%BYTE-SPECIFIER-POSITION 'SYSTEM-CONSTANT) )
	      (LET (( FDEFINE-FILE-PATHNAME (SEND PATHNAME ':GENERIC-PATHNAME) ))
		(INIT-SYSTEM-VAR-PROPERTIES) ) ) )
	  PATHNAME )
      (UNADVISE FSET :AROUND LOAD-FOR-TARGET)
      (UNADVISE FDEFINE :AROUND LOAD-FOR-TARGET)
      )) ) ) ) )

(DEFUN CROSS-LOAD-FDEFINE (FSPEC DEFINITION &OPTIONAL CAREFULLY-FLAG NO-QUERY-FLAG)
  ;; Used by LOAD-FOR-TARGET to handle intercepted calls to FDEFINE.
  ;;  2/14/86 - Original.
  ;;  2/17/86 - Add option to record source file even if definition is not remembered;
  ;;		don't try to FEDEFINE a :METHOD or :SELECT-METHOD.
  ;;  2/19/86 - Don't compile macros -- need to EVAL-FOR-TARGET to be able to be
  ;;		sure they use the target function definitions.
  ;;  3/14/86 - Always record function definitions unless
  ;;		*DEFAULT-DEFS-FROM-HOST* is a contant NIL.
  (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
      (FDEFINE FSPEC DEFINITION CAREFULLY-FLAG NO-QUERY-FLAG)
    (LET-UNLESS-CONSTANT
         (( FUNCTION-SPEC `(:TARGET ,TARGET-PROCESSOR ,FSPEC) )
	  ( TARGET-PROCESSOR HOST-PROCESSOR ) ; prevent recursive ADVISE on FDEFINE
	  ( *EVALHOOK* NIL )) ; don't need EVAL-FOR-TARGET here
      (IF (AND (OR #.(OR (NOT (CONSTANTP '*DEFAULT-DEFS-FROM-HOST*))
			 (NOT *DEFAULT-DEFS-FROM-HOST*))
		   (MEMBER (CAR-SAFE DEFINITION)
			   '(MACRO GLOBAL:SUBST SUBST GLOBAL:NAMED-SUBST NAMED-SUBST)
			   :TEST #'EQ) 
		   (LET (( HOST-DEF (SI:FDEFINITION-SAFE FSPEC) ))
		     (OR (NULL HOST-DEF)
			 (NOT (EQUAL (ARGLIST DEFINITION 'si:COMPILE)
				     (ARGLIST HOST-DEF 'si:COMPILE))) ) )
		   (MEMBER (INLINE-DECL FSPEC) '(INLINE TRY-INLINE) :TEST #'EQ) 
		   )			   ; worth remembering
	       (NOT (MEMBER (CAR-SAFE FSPEC) '(:METHOD :SELECT-METHOD) :TEST #'EQ) ))
	  (FDEFINE FUNCTION-SPEC DEFINITION CAREFULLY-FLAG NO-QUERY-FLAG)
	(WHEN *RECORD-ALL-TARGET-DEFINITIONS*	   ; just record source file where defined
	  (RECORD-SOURCE-FILE-NAME FUNCTION-SPEC)) )
      (WHEN (AND (NOT (NULL FDEFINE-FILE-PATHNAME))
		 SI:FILE-IN-COLD-LOAD
		 (NOT (MEMBER FDEFINE-FILE-PATHNAME COLD-LOAD-FILES :TEST #'EQ) ))
	(LET (( DEFAULT-CONS-AREA BACKGROUND-CONS-AREA ))
	  ;; Let function CHECK-COLD know that this file has the :COLD-LOAD attribute.
	  (PUSH FDEFINE-FILE-PATHNAME COLD-LOAD-FILES) ) )
      )))

(DEFUN RECORD-SOURCE-FILE-NAME-FOR-TARGET (SPEC &OPTIONAL (TYPE 'DEFUN))
  ;;  2/17/86 - Original.
  (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
      (RECORD-SOURCE-FILE-NAME SPEC TYPE)
    (IF *RECORD-ALL-TARGET-DEFINITIONS* 
	(LET (( TARGET-SPEC `(:TARGET ,TARGET-PROCESSOR ,SPEC) ))
	  (RECORD-SOURCE-FILE-NAME TARGET-SPEC TYPE))
      T)))

;; (:TARGET name fspec) is the definition of fspec for the named target environment.
(DEFPROP :TARGET TARGET-FUNCTION-SPEC-HANDLER SI:FUNCTION-SPEC-HANDLER)
(DEFUN TARGET-FUNCTION-SPEC-HANDLER (OPERATION FUNCTION-SPEC &OPTIONAL ARG1 ARG2)
  ;;  2/14/86 DNG - Original.
  ;;  3/11/86 DNG - Return NIL for FDEFINEDP operation on :METHODs etc;
  ;;		record source file pathname even if same as for host.
  ;;  3/15/86 DNG - Fix PUTPROP operation.
  ;;  3/18/86 DNG - Don't return a host definition that is an encapsulation.
  ;;  4/28/86 DNG - Changed function name from (:PROPERTY :TARGET SI:FUNCTION-SPEC-HANDLER).
  ;;  3/17/89 DNG - Update to support a default value for the GET operation.
  (LET ((TARGET (SECOND FUNCTION-SPEC))
	(FSPEC (THIRD FUNCTION-SPEC)))
    (IF (NOT (AND (= (LENGTH FUNCTION-SPEC) 3)
		  (OR (SYMBOLP TARGET) (STRINGP TARGET))
		  (OR (SYMBOLP FSPEC) (CONSP FSPEC))))
	(IF (EQ OPERATION 'VALIDATE-FUNCTION-SPEC)
	    NIL
	  (FERROR 'SYS:INVALID-FUNCTION-SPEC "Invalid function spec ~S." FUNCTION-SPEC))
      (LET-UNLESS-CONSTANT (( TARGET-PROCESSOR (VALIDATE-TARGET TARGET) ))
	(COND ((SYMBOLP FSPEC)
	       (CASE OPERATION
		 (VALIDATE-FUNCTION-SPEC T)
		 (FDEFINE (FSET-FOR-TARGET FSPEC ARG1))
		 (FDEFINITION (FSYMEVAL-FOR-TARGET FSPEC))
		 (FDEFINEDP (LET ( PLIST VALUE )
			      (IF (AND (NEQ TARGET-PROCESSOR HOST-PROCESSOR)
				       (SETQ PLIST (TARGET-PROPERTY-LIST FSPEC))
				       (NEQ (SETQ VALUE (GETF PLIST 'FUNCTION '|<Undefined>|))
					    '|<Undefined>|) )
				  (AND VALUE (VALUES T VALUE))
				;; Don't return host definition here because it may
				;; need to be unencapsulated before it can be properly used.
				(FBOUNDP FSPEC)) ) )
		 ;;(FDEFINITION-LOCATION (LOCF (GETF (TARGET-PROPERTY-LIST FSPEC) 'FUNCTION)))
		 (FUNDEFINE (REMF (TARGET-PROPERTY-LIST FSPEC) 'FUNCTION))
		 (GET (GET-TARGET-PROPERTY FSPEC ARG1 ARG2))
		 (PUTPROP (UNLESS (EQ ARG2 ':PREVIOUS-DEFINITION)
			    (SETF (GET-TARGET-PROPERTY FSPEC ARG2) ARG1))
			   ARG1) 
		 (OTHERWISE (SI:FUNCTION-SPEC-DEFAULT-HANDLER OPERATION FUNCTION-SPEC ARG1 ARG2))) )
	      ((EQ OPERATION 'VALIDATE-FUNCTION-SPEC)
	       (SI:VALIDATE-FUNCTION-SPEC FSPEC))
	      ((EQ TARGET-PROCESSOR HOST-PROCESSOR)
	       (FUNCALL (GET (FIRST FSPEC) 'SI:FUNCTION-SPEC-HANDLER)
			OPERATION FSPEC ARG1 ARG2))
	      ((EQ (FIRST FSPEC) ':INTERNAL)
	       (SI:INTERNAL-FUNCTION-SPEC-HANDLER
		 OPERATION
		 `(:INTERNAL (:TARGET ,TARGET-PROCESSOR ,(SECOND FSPEC)) ,(THIRD FSPEC))
		 ARG1 ARG2) )
	      ((EQ (FIRST FSPEC) ':PROPERTY)
	       (LET (( SYMBOL (SECOND FSPEC) )
		     ( PROPERTY (THIRD FSPEC) ))
		 (CASE OPERATION
		   (FDEFINE (PUTPROP-FOR-TARGET SYMBOL ARG1 PROPERTY))
		   ((FDEFINITION FDEFINEDP) (GET-FOR-TARGET SYMBOL PROPERTY))
		   ;;(FDEFINITION-LOCATION (LOCF (GETF (TARGET-PROPERTY-LIST FSPEC) PROPERTY)))
		   (FUNDEFINE (REMF (TARGET-PROPERTY-LIST FSPEC) PROPERTY))
		   (OTHERWISE (SI:FUNCTION-SPEC-DEFAULT-HANDLER OPERATION FUNCTION-SPEC ARG1 ARG2)))
		 ))
	      ((AND (EQ OPERATION 'FDEFINEDP)
		    (SI:VALIDATE-FUNCTION-SPEC FSPEC))
	       NIL)
	      (T (SI:FUNCTION-SPEC-DEFAULT-HANDLER OPERATION FUNCTION-SPEC ARG1 ARG2)) )))))

(DEFUN INIT-SYSTEM-VAR-PROPERTIES ()
  ;; For constants and special variables declared in file COLD-BAND;QCOM, put the
  ;; appropriate properties on the symbols.   Apparently this is done here because
  ;; QCOM is part of the cold build which doesn't seem to have a way of
  ;; setting up properties.  The compiler is the one who looks at these
  ;; properties, so it does make some sense for it to make sure they are
  ;; initialized.  Prior to now (2/7/85) this operation was done in function
  ;; QC-PROCESS-INITIALIZE the first time the compiler was executed.  Moving it
  ;; here saves time by doing it only when the compiler is first loaded, and
  ;; also allows cross-loading to be handled by the same function.
  ;; 2/08/85 DNG - Original version of this function.
  ;; 4/23/85 DNG - Allow folding of values in Q-FIELDS and NUMERIC-ARG-DESC-FIELDS.
  ;; 3/15/86 DNG - Set SPECIAL property whenever SYSTEM-CONSTANT is set.
  ;; 4/22/86 DNG - Enable value substitution for constants in SI:OLD-DTP-SYMBOLS.
  ;; 6/30/86 DNG - Always bind FDEFINE-FILE-PATHNAME to INIT-SYSTEM-VAR-PROPERTIES.
  ;; 8/04/88 DNG - Add ARRAY-FIELDS to the propagatable constants to speed up 
  ;;		functions such as SYS::ARRAY-CANONICALIZE-TYPE
  (LET (( FDEFINE-FILE-PATHNAME 'INIT-SYSTEM-VAR-PROPERTIES))
    (MAPC #'(LAMBDA (Y)
	      (LET (( VAL (IF (MEMBER Y '(ARRAY-TYPES Q-DATA-TYPES Q-FIELDS
					  NUMERIC-ARG-DESC-FIELDS SI:OLD-DTP-SYMBOLS
					  ARRAY-FIELDS)
				      :TEST #'EQ)
			      ;; These are known to be safe for value substitution.
			      T
			    ;; The following magical value tells P1 to
			    ;; not replace the symbol with its value.
			    'COMPILER:QC-PROCESS-INITIALIZE ) ))
		(MAPC #'(LAMBDA (X)
			  (PUTPROP-FOR-TARGET X VAL 'SYSTEM-CONSTANT)
			  (SPECIAL-1 X) )
		      (SYMEVAL-FOR-TARGET Y) )) )
	  (SYMEVAL-FOR-TARGET 'SYSTEM-CONSTANT-LISTS) )
    (MAPC #'(LAMBDA (Y)
	      (MAPC #'SPECIAL-1
		    (SYMEVAL-FOR-TARGET Y) ) )
	  (SYMEVAL-FOR-TARGET 'SYSTEM-VARIABLE-LISTS) )))

(EVAL-WHEN ( LOAD )
  ;; Initialize properties for system constants and variables.
  (INIT-SYSTEM-VAR-PROPERTIES)
  (DEFPROP NIL T SYSTEM-CONSTANT) ; this wasn't being done anywhere else.
  (DEFPROP T   T SYSTEM-CONSTANT)
 )

;;;;  ===  macro instruction set definition  ===

(DEFSTRUCT (OPCODES (:TYPE LIST) (:CONC-NAME OPCODE-) (:CALLABLE-CONSTRUCTORS NIL)
		    (:ALTERANT NIL) (:PREDICATE NIL) (:COPIER NIL))
  NARGS		; number of arguments expected
  MISC-OP	; opcode for MISC-op
  PUSH-OP	; opcode for pushing result on stack
  TEST-OP	; opcode for setting indicators
  NO-RESULT-OP	; opcode that produces no result
  AUX-OP	; no source address and no result value
 )

(DEFSUBST GET-OPCODES ( FUNCTION-NAME )
  "Return instruction OPCODES structure for FUNCTION-NAME."
  ;;  7/10/85 - Original version.
  ;;  7/20/85 - Use TARGET-PROPERTY-LIST instead of GET-FOR-TARGET.
  ;;  1/08/86 - Do the GETF on a local variable for efficiency.
  ;;  6/21/86 - Use GET-TARGET-PROPERTY.
  (GET-TARGET-PROPERTY FUNCTION-NAME 'OPCODE) )

(DEFSETF LAP-VALUE SET-LAP-VALUE)

(DEFUN SET-LAP-VALUE ( SYMBOL NEW-VALUE )
  ;;  2/17/86 - Original version to put target property even if same as for host.
  ;;  3/04/86 - Use PUT-TARGET-PROPERTY.
  (PUT-TARGET-PROPERTY SYMBOL NEW-VALUE 'QLVAL) )

(DEFUN OPCODE-QLVAL ( OPCODE )
  (DPB OPCODE (SYMEVAL-FOR-TARGET '%%QMI-FULL-OPCODE) 0) )

(unless (fboundp 'get-defined-value)
  (deff get-defined-value #'identity)) ; used in "U2:INFO;DEFOP-AUX.LISP"

(DEFUN DEFOP ( &QUOTE NAME CODE DEST
	       &OPTIONAL ( ARGLIST :UNDEFINED )
	       &KEY DOCUMENTATION LISP-FUNCTION-P NO-REG VALUES )
  "Define a machine instruction [a.k.a. a macro instruction].
Example:  (DEFOP (PUSH-CAR CAR) 10 D-PDL)
defines an instruction named PUSH-CAR which has opcode 10
and which implements function CAR with the result pushed on
the stack.  Other acceptable destinations are D-INDS for
setting the indicators or D-NONE for no result at all.
Instruction names beginning with SETE- are given special treatment."
;;
;; Descriptors for the instructions.  Each descriptor is:
;; (DEFOP <name or names> <opcode> <result-disposition> <arglist>
;;	  &Optional &Key :Documentation :Lisp-Function-P :No-Reg)
;;
;; Where:
;;   <name or names> is the name of the instruction or a list of names.  If there are one
;;	       or more Lisp functions that compile directly to this instruction, then this
;;	       is a list whose CAR is the instruction name and remaining elements are the
;;	       names of lisp functions that compile directly to this.
;;   <opcode> is the number which should be in the %%QMI-FULL-OPCODE field to represent this
;;	      instruction.
;;   <result-disposition> is the "old style" destination symbol for what this instruction
;;	      does with its result:  D-PDL, D-INDS, or D-RETURN
;;	      Also D-VARIES if depends on subordinate op
;;	       and D-STORE  stores somewhere and also does D-INDS
;;   <arglist> is a list argument names.  This resembles a lambda-list for a Lisp function.
;;	       No lambda-list keywords are allowed.  Defaults to NIL if unsupplied.
;;   :Lisp-Function-P  If present should be either T or NIL.  If T, then there
;;	       will be a Lisp function defined and which does this instruction.
;;   :Documentation    If present is the documentation for this instruction.  Should be present
;;	       if Lisp-Function-P is Non-NIL.
;;   :No-Reg   If present should be T or NIL.  Default is NIL.  If non-NIL, there is no
;;	       register field in this instruction.  It can not be arg prefetched.
;;
  ;;  8/24/85 - Allow multiple function names.
  ;;  9/17/85 - Allow the optional keyword arguments.
  ;;  9/30/85 - &QUOTE the &KEY arguments also.
  ;; 12/09/85 - Record DEST property for Disassembler.
  ;; 12/11/85 - Record NO-REG property for Disassembler.
  ;;  3/05/86 - Use RECORD-SOURCE-FILE-NAME-FOR-TARGET.
  ;;  7/09/86 - Allow :VALUES keyword (not yet actually used).
  ;; 10/11/86 - Don't record source file if already specified.
  ;; 11/19/86 - Avoid recording OPCODE property for PUSH and TEST.
  (DECLARE (ARGLIST &QUOTE NAME CODE DEST &OPTIONAL ARGLIST
		    &KEY :DOCUMENTATION :LISP-FUNCTION-P :NO-REG) )
  (DECLARE (IGNORE VALUES DOCUMENTATION))
  (LET ( FUNCTION-NAMES INSTRUCTION-NAME OPCODES )
    (IF (CONSP NAME)
	(SETQ INSTRUCTION-NAME (FIRST NAME)
	      FUNCTION-NAMES (REST NAME))
      (SETQ FUNCTION-NAMES (LIST NAME) INSTRUCTION-NAME NAME) )
    (RECORD-INSTRUCTION-NAME INSTRUCTION-NAME CODE)
    (SETF (GET INSTRUCTION-NAME 'DEST) DEST) ; for disassembler's information
    (UNLESS (AND (NULL NO-REG)
		 (NULL (GET INSTRUCTION-NAME 'NO-REG)))
      (SETF (GET INSTRUCTION-NAME 'NO-REG) NO-REG) ) ; for disassembler
    (UNLESS (OR NO-REG
		(MEMBER DEST '(D-RETURN D-STORE D-VARIES) :TEST #'EQ)
		(AND (ATOM NAME) (NOT LISP-FUNCTION-P)))
      (DOLIST ( FUNCTION-NAME FUNCTION-NAMES )
	(WHEN LISP-FUNCTION-P
	  ;; do this first so it will be at the end of the property list.
	  (UNLESS (GET FUNCTION-NAME ':SOURCE-FILE-NAME)
	    (RECORD-SOURCE-FILE-NAME-FOR-TARGET FUNCTION-NAME) ))
	(SETQ OPCODES (GET-OPCODES FUNCTION-NAME))
	(WHEN (OR (NULL OPCODES)
		  (< (LENGTH OPCODES) 3))
	  (SETQ OPCODES (MAKE-OPCODES :NARGS (OPCODE-NARGS OPCODES)
				      :MISC-OP (OPCODE-MISC-OP OPCODES)))
	  (SETF (GET-OPCODES FUNCTION-NAME) OPCODES) )
	(CASE DEST
	  ( D-INDS   (SETF (OPCODE-TEST-OP OPCODES) INSTRUCTION-NAME) )
	  ( D-NONE   (SETF (OPCODE-NO-RESULT-OP OPCODES) INSTRUCTION-NAME) )
	  ( D-PDL    (SETF (OPCODE-PUSH-OP OPCODES) INSTRUCTION-NAME) )
	  ( OTHERWISE (FERROR NIL "Invalid destination code: ~S" DEST)) )
	(WHEN (NULL (OPCODE-NARGS OPCODES))
	  (UNLESS (EQ ARGLIST :UNDEFINED)
	    (SETF (OPCODE-NARGS OPCODES) (LENGTH ARGLIST)) ) )
	) )
    (SETF (LAP-VALUE INSTRUCTION-NAME)
	  (OPCODE-QLVAL CODE))
    (LET (( NAME-STRING (STRING INSTRUCTION-NAME) ))
      (WHEN (AND (> (LENGTH NAME-STRING) 5)
		 (STRING-EQUAL NAME-STRING "SETE-" :END1 5) )
	(PUTPROP-FOR-TARGET (INTERN (SUBSEQ NAME-STRING 5)
				    SI:PKG-COMPILER-PACKAGE)
			    INSTRUCTION-NAME
			    'SETE) ) )
    INSTRUCTION-NAME ) )

(DEFUN RECORD-INSTRUCTION-NAME ( INSTRUCTION-NAME CODE )
  (LET (( INSTRUCTION-DECODE-TABLE (INSTRUCTION-DECODE-TABLE T) ))
 #| #+compiler:debug  ; while the instruction set is still changing
    (LET (( OLD-NAME (AREF INSTRUCTION-DECODE-TABLE CODE) ))
      (UNLESS (OR (NULL OLD-NAME)
		  (EQ OLD-NAME INSTRUCTION-NAME))
	(LET (( OLD-CODES (GET-OPCODES OLD-NAME) ))
	  (UNLESS (NULL OLD-CODES)
	    (LOOP FOR TAIL ON (CDR OLD-CODES)
		  WHEN (AND (NOT (NULL (CAR TAIL)))
			    (EQ (LAP-VALUE (CAR TAIL)) CODE))
		  DO (SETF (CAR TAIL) NIL))
	    (SETF (LAP-VALUE OLD-NAME) NIL)
	    (UNLESS (OR (OPCODE-TEST-OP OLD-CODES)
			(OPCODE-PUSH-OP OLD-CODES)
			(OPCODE-NO-RESULT-OP OLD-CODES)
			(OPCODE-MISC-OP OLD-CODES) )
	      (SETF (GET-OPCODES OLD-NAME) NIL) ) ) ) ) )
  |#
    (SETF (AREF INSTRUCTION-DECODE-TABLE CODE)
	  INSTRUCTION-NAME) ) )

(DEFVAR SIMPLE-CALL-MAX-ARG) ; Maximum number of arguments before needing to use CALL-N.

(DEFMACRO DEF-CALLOP ( NAME OPCODE &OPTIONAL ARGLIST )
  ;; 12/11/85 DNG - Pass :NO-REG argument of 'CALL to DEFOP.
  (LET* (( STRING (STRING NAME) )
	 ( N ( DIGIT-CHAR-P (CHAR STRING (- (LENGTH STRING) 1))) ))
    `(PROGN (DEFOP ,NAME ,OPCODE D-VARIES ,ARGLIST :NO-REG CALL)
	    (DOTIMES ( I (LDB %%QMI-CALL-DEST -1) )
	      (RECORD-INSTRUCTION-NAME ',NAME (+ ,OPCODE I 1)))
	    (UNLESS (NULL ,N)
	      (SETQ SIMPLE-CALL-MAX-ARG ,N) )
	    ) ) )

(DEFUN DEF-BRANCH-OP ( &QUOTE TEST SENSE ELSE-POP OPCODE &OPTIONAL LIKELY )
  ;;  9/25/85 DNG - Update to match the version in the ULAP package.
  ;; 12/11/85 DNG - Record NO-REG property of BRANCH.
  ;;  2/17/86 DNG - No longer need to set *BRANCH-INSTRUCTION-NAMES*.
  (WHEN (EQ TEST 'TRUE)
    (SETQ TEST 'ALWAYS)
    (SETQ SENSE 'NIL))
  (LET (( NAME-SYMBOL
	 (IF (EQ TEST 'ALWAYS)
	     'BR
	   (LET (( NAME (string-append "BR-"
				       (if (eq sense 'FALSE) "NOT-" "")
				       (string TEST)
				       (if else-pop "-ELSE-POP" "")
				       (if likely "-LIKELY" "")) ))
	     (INTERN NAME SI:PKG-COMPILER-PACKAGE) ) ) ))
    (RECORD-INSTRUCTION-NAME NAME-SYMBOL OPCODE)
    (SETF (GET NAME-SYMBOL 'NO-REG) 'BRANCH) 
    )
  (WHEN LIKELY (RETURN-FROM DEF-BRANCH-OP)) ; <-- Not implemented yet  ***********
  (LET* (( KEY (LIST TEST SENSE ELSE-POP) )
	 ( ALIST (GET-FOR-TARGET TEST 'DEF-BRANCH-OP) )
	 ( TEM (ASSOC KEY ALIST :TEST #'EQUAL)  )
	 ( LAP-VALUE (OPCODE-QLVAL OPCODE) ))
    (WHEN (AND (NEQ TARGET-PROCESSOR HOST-PROCESSOR)
	       (EQ ALIST (GET TEST 'DEF-BRANCH-OP)))
      (SETQ ALIST NIL TEM NIL) )
    (IF TEM
	(SETF (CDR TEM) LAP-VALUE)
      (PUTPROP-FOR-TARGET TEST
			  (CONS (CONS KEY LAP-VALUE) ALIST)
			  'DEF-BRANCH-OP) ) )
  )

(DEFUN DEF-AUX-OP ( &QUOTE NAME &EVAL CODE &QUOTE
   		    &OPTIONAL (ARGLIST NIL ARGLIST-SUPPLIED)
		    &KEY      (LISP-FUNCTION-P NIL)
			      (INTERPRETER-DEFINITION LISP-FUNCTION-P)
			      DOCUMENTATION )
  ;;  7/29/85
  ;;  9/23/85 - Allow LISP-FUNCTION-P and NOT-LISP-CALLABLE arguments.
  ;;  1/20/86 - Modify to use &KEY arguments.
  ;;  7/14/86 - Allow :DOCUMENTATION keyword.
  ;; 11/20/86 - Fix ARGLIST declaration; fix to allow changing number of arguments.
  (DECLARE (ARGLIST &QUOTE NAME &EVAL CODE &QUOTE
   		    &OPTIONAL ARGLIST
		    &KEY :LISP-FUNCTION-P :INTERPRETER-DEFINITION :DOCUMENTATION))
  (DECLARE (IGNORE DOCUMENTATION))
  (LET ( INSTRUCTION-NAME FUNCTION-NAME )
    (IF (ATOM NAME)
	(SETQ INSTRUCTION-NAME NAME
	      FUNCTION-NAME NAME)
      (SETQ INSTRUCTION-NAME (FIRST NAME)
	    FUNCTION-NAME (SECOND NAME)))
  (RECORD-AUX-OP-NAME INSTRUCTION-NAME CODE)
  (WHEN (AND (NOT (NULL FUNCTION-NAME))
	     (OR LISP-FUNCTION-P (CONSP NAME)))
    (UNLESS (MEMBER '&REST ARGLIST :TEST #'EQ) 
      ;; Allow function call to be compiled into this instruction.
      (LET (( OPCODES (GET-OPCODES FUNCTION-NAME) ))
	(WHEN (OR (NULL OPCODES)
		  (< (LENGTH OPCODES) 5))
	  (SETQ OPCODES (MAKE-OPCODES :NARGS (OPCODE-NARGS OPCODES)
				      :MISC-OP (OPCODE-MISC-OP OPCODES)))
	  (SETF (GET-OPCODES FUNCTION-NAME) OPCODES) )
	(SETF (OPCODE-AUX-OP OPCODES) INSTRUCTION-NAME)
	(WHEN ARGLIST-SUPPLIED
	  (SETF (OPCODE-NARGS OPCODES) (LENGTH ARGLIST))
	  (UNLESS INTERPRETER-DEFINITION
	    (SETF (GET FUNCTION-NAME 'ARGLIST) ARGLIST)))
	)))
  (SETF (LAP-VALUE INSTRUCTION-NAME)
	(+ CODE (LAP-VALUE 'AUX-GROUP)))
  INSTRUCTION-NAME ) )

(DEFUN RECORD-AUX-OP-NAME ( AUX-OP-NAME CODE )
  ;;  7/29/85
  (LET (( AUX-OP-NAME-TABLE (AUX-OP-NAME-TABLE T) ))
 #| #+compiler:debug  ; while the instruction set is changing
    (LET (( OLD-NAME (AREF AUX-OP-NAME-TABLE CODE) ))
      (UNLESS (OR (NULL OLD-NAME)
		  (EQ OLD-NAME AUX-OP-NAME))
	(LET (( OLD-CODES (GET-OPCODES OLD-NAME) ))
	  (UNLESS (NULL OLD-CODES)
	    (SETF (OPCODE-AUX-OP OLD-CODES) NIL)
	    (SETF (LAP-VALUE AUX-OP-NAME) NIL)
	    (UNLESS (OR (OPCODE-TEST-OP OLD-CODES)
			(OPCODE-PUSH-OP OLD-CODES)
			(OPCODE-NO-RESULT-OP OLD-CODES)
			(OPCODE-AUX-OP OLD-CODES) )
	      (SETF (GET-OPCODES OLD-NAME) NIL) ) ) ) ) )
  |#
    (SETF (AREF AUX-OP-NAME-TABLE CODE)
	  AUX-OP-NAME) ) )

(DEFSUBST MISC-OP-EVAL ( INSTRUCTION )
  ;; 3/4/86 - Modified to use GET-TARGET-PROPERTY.
  (GET-TARGET-PROPERTY INSTRUCTION 'MISC-VAL) )

#|
#+compiler:debug
(DEFSUBST MISC-LAP-CODE (MISC-NAME)
  "Given the name of a misc-op, return the code that represents it in the LAP code."
  MISC-NAME)
#-compiler:debug
|#
(DEFUN MISC-LAP-CODE (MISC-NAME)
  "Given the name of a misc-op, return the code that represents it in the LAP code."
  ;; 10/11/86 - Original.
  (IF (COMPILING-FOR-V2)
      (MISC-OP-EVAL MISC-NAME)
    (LAP-VALUE MISC-NAME)))


(DEFUN Def-Misc-Op ( &QUOTE NAME OPCODE ARGLIST
		     &KEY (LISP-FUNCTION-P T)
			  (INTERPRETER-DEFINITION T) 
			  (DOCUMENTATION NIL)
			  VALUES)
  "Define a function that is microcoded." ; used only in "SYS:UCODE;DEFOP.LISP"
;; Where:
;;   <name> is the name of the instruction or a list of names.  If there are one
;;	       or more Lisp functions that compile directly to this instruction, then this
;;	       is a list whose CAR is the instruction name and remaining elements are the
;;	       names of lisp functions that compile directly to this.
;;   <opcode> is the number which should be in the %%QMI-MISC-OP field to represent this
;;	      instruction.
;;   <arglist> is a list of argument names.  This resembles a lambda-list for a 
;;	       Lisp function.  No lambda-list keywords are allowed.
;;   :Lisp-Function-P  If true, then the compiler can use this instruction to
;;		implement calls to the corresponding Lisp function.
;;   :Interpreter-Definition  If true, then there will be a Lisp function 
;;		defined which does this instruction.
;;   :Documentation    If present is the documentation for this instruction.  Should be present
;;	       if Lisp-Function-P is Non-NIL.

  ;; 10/26/85 - Change to use keyword options.
  ;;  1/20/86 - New keyword arg :Interpreter-Definition;
  ;;		changed DEFMIC to use DEF-MISC-OP instead of visa-versa;
  ;;		provide for documentation and multiple function names.
  ;;  2/17/86 - Record source file name for target Misc-op functions.
  ;;  2/17/86 - Call RECORD-MISC-OP-NAME in VM2 host mode.
  ;;  3/20/86 - Record a target function definition for EVAL-FOR-TARGET.
  ;;  7/09/86 - Allow new keyword :VALUES.
  ;; 10/11/86 - Allow using numbers instead of names in the LAP code.
  (DECLARE (IGNORE INTERPRETER-DEFINITION))
  (LET ( FUNCTION-NAMES INSTRUCTION-NAME )
    (IF (ATOM NAME)
	(SETQ FUNCTION-NAMES (AND LISP-FUNCTION-P (LIST NAME))
	      INSTRUCTION-NAME NAME)
      (SETQ FUNCTION-NAMES (REST NAME) INSTRUCTION-NAME (FIRST NAME)) )
    (WHEN (COMPILING-FOR-V2)
      (RECORD-MISC-OP-NAME INSTRUCTION-NAME OPCODE))
    (IF (COMPILING-FOR-V2)
	(SETF (MISC-OP-EVAL INSTRUCTION-NAME) OPCODE)
      (SETF (LAP-VALUE INSTRUCTION-NAME) OPCODE))
    (DOLIST ( FUNCTION-NAME FUNCTION-NAMES )
      (WHEN LISP-FUNCTION-P
	(WHEN (OR (COMPILING-FOR-V2)
		  (NULL (GET FUNCTION-NAME ':SOURCE-FILE-NAME)))
	  (RECORD-SOURCE-FILE-NAME-FOR-TARGET FUNCTION-NAME)
	  (UNLESS (OR (AND '#.(CONSTANTP '*DEFAULT-DEFS-FROM-HOST*)
			   (NOT *DEFAULT-DEFS-FROM-HOST*))
		      (EQ TARGET-PROCESSOR HOST-PROCESSOR)
		      (NOT (FBOUNDP FUNCTION-NAME)))
	    ;; Need definition for EVAL-FOR-TARGET to use.
	    (FSET-FOR-TARGET FUNCTION-NAME (SYMBOL-FUNCTION FUNCTION-NAME)) ))
	(WHEN (AND DOCUMENTATION
		   (NULL (DOCUMENTATION FUNCTION-NAME 'FUNCTION)))
	  (SETF (DOCUMENTATION FUNCTION-NAME 'FUNCTION) DOCUMENTATION) ) )
      (WHEN VALUES
	(PUTPROP-FOR-TARGET FUNCTION-NAME VALUES 'VALUES))
      (COND ((AND (NEQ TARGET-PROCESSOR HOST-PROCESSOR)
		  (FBOUNDP FUNCTION-NAME)
		  (= (LENGTH ARGLIST) (LENGTH (ARGLIST FUNCTION-NAME)))))
	    (T (PUTPROP-FOR-TARGET FUNCTION-NAME ARGLIST 'ARGLIST)))
      (UNLESS (MEMBER '&REST ARGLIST :TEST #'EQ) 
	(LET (( OPCODES (GET-OPCODES FUNCTION-NAME) )
	      ( MISC-CODE (MISC-LAP-CODE INSTRUCTION-NAME) ))
	  (IF (NULL OPCODES)
	      (PROGN 
		(SETF OPCODES (LIST (LENGTH ARGLIST) MISC-CODE))
		(SETF (GET-OPCODES FUNCTION-NAME) OPCODES) )
	    (PROGN
	      (SETF (OPCODE-MISC-OP OPCODES) MISC-CODE)
	      (SETF (OPCODE-NARGS OPCODES) (LENGTH ARGLIST)) ) ) ) ) )
    INSTRUCTION-NAME ) )

(DEFUN RECORD-MISC-OP-NAME ( MISC-OP-NAME CODE )
  (LET (( MISC-OP-NAME-TABLE (MISC-OP-NAME-TABLE T) ))
 #| #+compiler:debug  ; while the instruction set is changing
    (LET (( OLD-NAME (AREF MISC-OP-NAME-TABLE CODE) ))
      (UNLESS (OR (NULL OLD-NAME)
		  (EQ OLD-NAME MISC-OP-NAME))
	(LET (( OLD-CODES (GET-OPCODES OLD-NAME) ))
	  (UNLESS (NULL OLD-CODES)
	    (SETF (OPCODE-MISC-OP OLD-CODES) NIL)
	    (IF (COMPILING-FOR-V2)
		(SETF (MISC-OP-EVAL MISC-OP-NAME) NIL)
	      (SETF (LAP-VALUE MISC-OP-NAME) NIL) )
	    (UNLESS (OR (OPCODE-TEST-OP OLD-CODES)
			(OPCODE-PUSH-OP OLD-CODES)
			(OPCODE-NO-RESULT-OP OLD-CODES)
			(OPCODE-MISC-OP OLD-CODES) )
	      (SETF (GET-OPCODES OLD-NAME) NIL) ) ) ) ) )  |#
    (SETF (AREF MISC-OP-NAME-TABLE CODE)
	  MISC-OP-NAME) ) )

(DEFSUBST MODULE-NUMBER ( NAME )
  ;; Given a module name, return its number.
  (GET-FOR-TARGET NAME 'INTERNAL-MODULE-NUMBER) )

(DEFUN DEF-MODULE (&QUOTE NAME &EVAL NUMBER)
  (CHECK-TYPE NAME SYMBOL)
  (CHECK-TYPE NUMBER FIXNUM)
  (SETF (MODULE-NUMBER NAME) NUMBER)
  (LET (( MODULE-OP-NAME-TABLE (MODULE-OP-NAME-TABLE T) ))
    (WHEN (NULL (AREF MODULE-OP-NAME-TABLE NUMBER))
      (SETF (AREF MODULE-OP-NAME-TABLE NUMBER)
	    (MAKE-ARRAY (+ (LDB (SYMEVAL-FOR-TARGET '%%QMI-MODULE-OP)
				(LOGNOT 0) )
			   1)
			:LEADER-LENGTH 1) ) )
    (SETF (ARRAY-LEADER (AREF MODULE-OP-NAME-TABLE NUMBER) 0)
	  NAME)
    )
  NAME
  )

(DEFUN DEF-MODULE-OP (&QUOTE NAME MODULE-NAME OPNUM ARGLIST
		      &KEY INTERPRETER-DEFINITION DOCUMENTATION)
  ;;  1/20/86 - Permit :INTERPRETER-DEFINITION keyword.
  ;;  2/17/86 - Use RECORD-SOURCE-FILE-NAME-FOR-TARGET.
  ;;  7/14/86 - Permit :DOCUMENTATION keyword.
  ;; 10/11/86 - Use MISC-LAP-CODE.
  (DECLARE (IGNORE INTERPRETER-DEFINITION DOCUMENTATION))
  (LET (( MODULE-NUMBER (MODULE-NUMBER MODULE-NAME) ))
    (UNLESS (FIXNUMP MODULE-NUMBER)
      (FERROR NIL "~S is not a defined module name." MODULE-NAME) )
    (WHEN (RECORD-SOURCE-FILE-NAME-FOR-TARGET NAME)
      (SETF (AREF (AREF (MODULE-OP-NAME-TABLE) MODULE-NUMBER)
		  OPNUM)
	    NAME)
      (SETF (MISC-OP-EVAL NAME)
	    (+ (- (LAP-VALUE 'TEST-MODULE-GROUP)
		  (LAP-VALUE 'TEST-MISC-GROUP) )
	       (DPB MODULE-NUMBER
		    (SYMEVAL-FOR-TARGET '%%QMI-EXTERNAL-MODULE-NUMBER)
		    (DPB OPNUM
			 (SYMEVAL-FOR-TARGET '%%QMI-MODULE-OP)
			 0) ) ) )
      (SETF (GET-OPCODES NAME)
	    (LIST (LENGTH ARGLIST)
		  (MISC-LAP-CODE NAME)) )
      ))
  NAME )

(DEFUN DEF-UCODE-ENTRY ( &QUOTE NAME INDEX ARGLIST &KEY DOCUMENTATION
			(LISP-FUNCTION-P T) (INTERPRETER-DEFINITION T) VALUES)
  "Define a micro-coded function."
  ;; This is a dummy version for the compiler, which doesn't need to
  ;; know about these.  The real version is in "GENASYS;PARAMETERS".
  ;; 10/17/85 DNG - Original version.
  ;; 10/24/85 DNG - Changed name from DEF-U-CODE-ENTRY.
  ;; 11/01/85 DNG - Record the source file pathname.
  ;;  2/17/86 - Use RECORD-SOURCE-FILE-NAME-FOR-TARGET.
  ;;  3/14/86 - Create dummy target function definition.
  ;;  3/07/87 - Install doc string.  [SPR 3702]
  (DECLARE (ARGLIST &QUOTE NAME INDEX ARGLIST &KEY DOCUMENTATION))
  (DECLARE (IGNORE INDEX ARGLIST LISP-FUNCTION-P INTERPRETER-DEFINITION VALUES))
  (WHEN (RECORD-SOURCE-FILE-NAME-FOR-TARGET NAME)
    (UNLESS (OR (AND '#.(CONSTANTP '*DEFAULT-DEFS-FROM-HOST*)
		     (NOT *DEFAULT-DEFS-FROM-HOST*))
		(EQ TARGET-PROCESSOR HOST-PROCESSOR))
      ;; Need definition for EVAL-FOR-TARGET to use.
      (FSET-FOR-TARGET NAME (SYMBOL-FUNCTION NAME)) )
    (WHEN (AND DOCUMENTATION
	       (NOT (EQUAL DOCUMENTATION (DOCUMENTATION NAME 'FUNCTION))))
      (SETF (DOCUMENTATION NAME 'FUNCTION) DOCUMENTATION))
    NAME ))

(DEFUN INSTRUCTION-EXISTS-P ( NAME )
  "Tests whether NAME is defined as a machine instruction on the target processor."
  ;;  7/26/85 - Original version.
  (DECLARE (INLINE LAP-VALUE GET-FOR-TARGET))
  (IF (LAP-VALUE NAME)
      T
    NIL))

#|  #-compiler:debug  |#
(PROGN
(DEFPROP INSTRUCTION-EXISTS-P TARGET-FOLDER POST-OPTIMIZERS)
(DEFPROP LAP-VALUE	      TARGET-FOLDER	 OPTIMIZERS)
(DEFPROP MISC-LAP-CODE	      TARGET-FOLDER POST-OPTIMIZERS)
(DEFUN TARGET-FOLDER ( FORM )
  (IF (AND (QUOTEP (SECOND FORM))
	   (CONSTANTP 'TARGET-PROCESSOR))
      (FOLD-CONSTANTS FORM)
    FORM) )

(DEFPROP SYMEVAL-FOR-TARGET TARGET-SYM-OPT POST-OPTIMIZERS)
(DEFUN TARGET-SYM-OPT ( FORM )
  ;; 11/24/86 DNG - Original.
  (IF (AND (QUOTEP (SECOND FORM))
	   (SYMBOLP (SECOND (SECOND FORM)))
	   (CONSTANTP 'TARGET-PROCESSOR))
      (CONS 'SYMEVAL (CDR FORM))
    FORM) )
 )