;;;  -*- Mode:Common-Lisp; Package:Compiler; Base:10; Cold-Load: T -*-

;;;                           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) 1984-1989 Texas Instruments Incorporated. All rights reserved.
;;; Copyright (C) 1980 Massachusetts Institute of Technology


;;;;   *-----------------------------------------------------------*
;;;;   |          --  TI Explorer Lisp Compiler  --                |
;;;;   |  This file contains definitions that are logically part   |
;;;;   |  of the compiler, but which need to be loaded as part of  |
;;;;   |  the minimum Common Lisp kernel, whether the compiler     |
;;;;   |  itself is loaded or not.  This includes things needed by |
;;;;   |  DISASSEMBLE, error handler, EVAL, and MACROEXPAND.       |
;;;;   *-----------------------------------------------------------*

;;  3/06/86 DNG - Original version of this file created from declarations
;;		taken from files TARGET and DEFS.
;;  3/08/86 DNG - Include more things from files COLD, FILE, and P1DEFS;
;;		convert from Zetalisp to Common Lisp.
;;  3/13/86 DNG - Include GETDECL, PUTDECL, and DEFDECL.
;;  3/20/86 DNG - Some re-arranging for the build to work right.
;;  3/31/86 DNG - Moved functions FEF-LIMIT-PC and FEF-LIMIT-PC to here from
;;		the loader file because the disassembler needs them.
;;  4/01/86 DNG - Moved FEF-INSTRUCTION-LENGTH to here.
;;  5/28/86 DNG - SHADOW WARN.
;;  6/09/86 DNG - EXPORT DEF-AUX-OP.
;;  8/04/86 DNG - Moved EVAL-AT-LOAD-TIME-MARKER from file DEFS to MINDEFS.
;;  9/02/86 DNG - Add :IEEE-FLOATING-POINT to *FEATURES*.
;; 10/14/86 DNG - New function FOLD-CONSTANT-ARGUMENTS .
;; 10/29/86 DNG - Use BOOTSTRAP-EXPORT instead of EXPORT to avoid queries in cold-load.
;; 12/31/86 DNG - Fix COMPILEDP to handle macros.
;;  2/04/87 DNG - Expand LAP-VALUE and GET-FOR-TARGET inline.
;;  3/25/87 DNG - Add USES-TAIL-REC-P and MAKE-DYNAMIC-CLOSURE .
;;------------------- The following done after Explorer release 3.0 ------
;;  7/07/87 DNG - Fix STANDARD-TYPE-NAME-P for SPR 5828.
;;------------------- The following done for Explorer release 4.0 ------
;; 12/07/87 DNG - Add temporary definition of EVAL-FOR-TARGET for use by the 
;;		reader in the cold band before the compiler is loaded.
;; 12/11/87 DNG - Add MAKE-OBSOLETE-FLAVOR to EXPORT list.
;;  1/16/88 DNG - Fix STANDARD-TYPE-NAME-P to return false for FUNCTION even if 
;;		TYPE-SPECIFIER-P returns true.  Removed some obsolete VM1 code.
;;  1/21/88 DNG - Make sure SI:BOOTSTRAP-EXPORT is defined since it may be deleted after the cold band.
;;------------------- The following done for Explorer release 5.0 ------
;;  7/26/88 JHO - Added support for FILE-LOCAL-DECLARATIONS-DEF-ALIST
;;  8/19/88 clm - Made some minor modifications to JHOs code.
;; 10/11/88 clm - Added a missing piece of code back into si:DECLARED-DEFINITION.
;;------------------- The following done for Explorer release 6.0 ------
;;  3/15/89 DNG - Include environment support for CLOS.
;;  4/12/89 JLM - Changed (putprop ... usage to (setf (get ...
;;  5/03/89 DNG - New functions ASSIGNMENT-TYPE-ERROR and ARGUMENT-TYPE-ERROR .


(SHADOW '(WARN)) ; COMPILER:WARN is different from LISP:WARN
(unless (fboundp 'SI:BOOTSTRAP-EXPORT)
  (deff SI:BOOTSTRAP-EXPORT 'export))
(SI:BOOTSTRAP-EXPORT '(
;;Documented variables and functions
    COMPILER-VERBOSE
    PEEP-ENABLE
    QC-FILE-CHECK-INDENTATION
    WARN-ON-ERRORS
    COMPILATION-DEFINE
    ADD-OPTIMIZER
    FASD-FILE-SYMBOLS-PROPERTIES
    FASD-FONT
    FASD-SYMBOL-VALUE
    FUNCTION-REFERENCED
    LOCKING-RESOURCES
    MAKE-OBSOLETE

;;Should be documented
    WARN
    EXPR-SXHASH
    COMPILER-WARNINGS-CONTEXT-BIND
    COMPILE-NOW-OR-LATER
    FUNCTION-REFERENCED-P
    COMPILATION-DEFINEDP
    FASL-UPDATE-STREAM
    COMPILE-FORM
    ADD-STYLE-CHECKER
    MAKE-VARIABLE-OBSOLETE
    CW-TOP-LEVEL 
    CW-TOP-LEVEL-LAMBDA-EXPRESSION
    OPTIMIZE-PATTERN
    MAKE-SUPERSEDED
    *OUTPUT-VERSION-BEHAVIOR*
    CONVERT-FASL-DATA
    *WARN-OF-SUPERSEDED-FUNCTIONS-P*
    FOLD-CONSTANT-ARGUMENTS
    MAKE-OBSOLETE-FLAVOR

;;Keywords of interface to compiler.
    MICRO-COMPILE
    MACRO-COMPILE
    COMPILE-TO-CORE
    QFASL
    #+MIT REL
    IGNORABLE-VARIABLE
    UNDEFINED-FUNCTION-USED
    TRY-INLINE

;;Really used in "ZWEI;COMC".
    COMPILE-STREAM
    MACRO-EXPANSION-ERROR
    COMPILE-DRIVER
    COMPILE-1
    LOCKING-RESOURCES-NO-QFASL
    COMPILE-TOP-LEVEL-FORM

;;Disassembly functions.
    DISASSEMBLE-POINTER
    DISASSEMBLE-INSTRUCTION
    DISASSEMBLE-ONE-INSTRUCTION
    DISASSEMBLE-OBJECT-OUTPUT-FUN
    DISASSEMBLE-INSTRUCTION-LENGTH
    DISASSEMBLE-LIM-PC
    DISASSEMBLE-ARG-NAME
    DISASSEMBLE-LOCAL-NAME
    DISASSEMBLE-LEXICAL-NAME

;;Things used randomly elsewhere in the system.
    EVAL-AT-LOAD-TIME-MARKER		;SYS: SYS2; LMMAC
    OPTIMIZED-INTO			;QMISC
    FASL-UPATE-STREAM			;SYS: ZWEI; FASUPD
    BARF-SPECIAL-LIST			;FLAVOR
    SPECIALP				;FLAVOR
    QC-TRANSLATE-FUNCTION		;FLAVOR
    SPEED-OVER-SAFETY-P			;FLAVOR
    INTERPRETED-DEF			;SETF
    GET-OPCODES 			;WHO-CALLS
    STANDARD-TYPE-NAME-P
    SYSTEM-CONSTANT
 ) "COMPILER2" )

(SI:BOOTSTRAP-EXPORT '(LOAD-FOR-TARGET EVAL-FOR-TARGET VALIDATE-TARGET TARGET-KINDS
	  FASD-TARGET
	  *RECORD-ALL-TARGET-DEFINITIONS* *DEFAULT-DEFS-FROM-HOST* 
	  DEFMIC DEFOP DEF-BRANCH-OP DEF-MISC-OP DEF-AUX-OP DEF-CALLOP)
    "COMPILER2")
(SI:BOOTSTRAP-EXPORT '(INSTRUCTION-DECODE-TABLE AUX-OP-NAME-TABLE MISC-OP-NAME-TABLE MODULE-OP-NAME-TABLE)
		    "COMPILER2")

(SI:BOOTSTRAP-EXPORT '( DEFOPTIMIZER DEFCOMPILER-SYNONYM *SUPPRESS-DEBUG-INFO*) ; defined in P1DEFS
		    "COMPILER2")

;; Environment support for CLOS.
(SI:BOOTSTRAP-EXPORT '( same-environment-p environment-remote-p get-from-environment 
	  putprop-in-environment remprop-from-environment
	  *local-environment* *compile-file-environment*) "COMPILER2")

;;;;        ==================================
;;;;          Miscellaneous declarations
;;;;        ==================================

(DEFVAR FILE-CONSTANTS-LIST NIL
  "Association list of symbols and values defined by DEFCONSTANT in COMPILE-FILE.")
  ;; FILE-CONSTANTS-LIST is bound to NIL in COMPILE-STREAM and COMPILE-1;
  ;;    values are pushed on the list in COMPILE-DRIVER, and used in P1.      

(DEFVAR QC-FILE-IN-PROGRESS NIL "T while inside COMPILE-STREAM.") 

;;  4/10/89 DNG - Moved QC-FILE-LOAD-FLAG to here from file "DEFS" and 
;;		initialized to T instead of being unbound.
(DEFVAR QC-FILE-LOAD-FLAG T
   "True when the results of compilation are being immediately installed in memory
instead of just written to a file.") 

(DEFCONSTANT CONTINUE-MESSAGE "Continue anyway.")

(DEFUN MINDEFS-WARN (TYPE SEVERITY FORMAT-STRING &REST ARGS)
  ;; This variation of WARN is for use when the compiler may not be loaded yet.
  ;;  3/20/86 - Use CERROR instead of FERROR.
  ;;  4/04/89 - Use CONTINUE-MESSAGE.
  (IF (FBOUNDP 'WARN) ; if compiler is loaded
      (compiler-let ((INHIBIT-STYLE-WARNINGS-SWITCH t)) ; suppress "not in cold load"
	(APPLY #'WARN TYPE SEVERITY FORMAT-STRING ARGS))
    (APPLY #'CERROR CONTINUE-MESSAGE FORMAT-STRING ARGS) ))

(defun NON-FATAL-ERROR (severity format-string &rest format-args)
  "If compiling a file or buffer, issue a compiler warning message and continue.
Otherwise, signal a proceedable error.  SEVERITY is the same as for COMPILER:WARN.
This is intended for use by macros to report non-fatal errors."
  ;;  9/26/88 DNG - Original.
  ;; 11/17/88 DNG - Named changed from WARNING to NON-FATAL-ERROR.
  ;;  4/04/89 DNG - Use CONTINUE-MESSAGE.
  ;;  4/10/89 DNG - Signal error instead of warning when within QLAPP phase of Compile Buffer.
  (if (and qc-file-in-progress ; in COMPILE-STREAM
	   (or (boundp 'p1value) ; in pass 1
	       (not qc-file-load-flag))) ; in COMPILE-FILE
      (compiler-let ((INHIBIT-STYLE-WARNINGS-SWITCH t)) ; suppress "not in cold load"
	(apply #'warn 'non-fatal-error severity format-string format-args))
    (apply #'cerror CONTINUE-MESSAGE format-string format-args))
  (values))

(defprop  non-fatal-error t :error-reporter)

;;;;        ==================================
;;;;         Support for environment objects
;;;;        ==================================

(DEFVAR *COMPILE-FILE-ENVIRONMENT* NIL
  "The environment used for macro expansions at top-level in COMPILE-FILE.")

(DEFVAR *LOCAL-ENVIRONMENT* NIL
  "Environment for MACROEXPAND to use during compilation."
  ;; This contains the definitions of local macros defined by MACROLET.
  ;; Local functions that are not macros have NIL recorded as their definitions.
  ;; Such local functions are present only to record that they shadow
  ;; more global definitions of the same function names.
  )

;; Environment object for use by MACROEXPAND and FIND-CLASS.
;;  4/12/89 DNG - Added global-env slot.
(defstruct (environment (:conc-name env-) (:callable-constructors nil)
		(:alterant nil) (:predicate nil)
		(:copier nil) (:type :list))
  (vars '() :type list) ; variables - list of frames, each frame is a p-list
  (functions '() :type list) ; functions - list of frames, each frame is a p-list
  (symbol-props '() :type list) ; symbol properties - list of frames, each frame is a p-list
  (fspec-props '() :type list) ; function spec properties - list of a-lists
  (spare nil) ; spare slot reserved for future use
  (global-env '() :type list) ; global remote environment that a local environment inherits from
  )

;; 4/11/89 DNG - Original.
(defsubst env-extra (environment) (cddr environment)) ; cf *INTERPRETER-EXTRA-ENVIRONMENT*

(proclaim '(try-inline extend-environment))
(defun extend-environment (&key parent vars functions symbol-props fspec-props)
  (declare (unspecial vars))
  (make-environment :vars (cons vars (env-vars parent))
		    :functions (cons functions (env-functions parent))
		    :symbol-props (cons symbol-props (env-symbol-props parent))
		    :fspec-props (cons fspec-props (env-fspec-props parent))
		    :global-env (env-global-env parent)))

(defsubst environment-remote-p (environment)
  "Is the argument a remote environment rather than a local environment?"
  (not (null (env-symbol-props environment))))

(proclaim '(try-inline same-environment-p))
(defun same-environment-p (env1 env2)
  ;; Are these environments equivalent for the purposes of GET-FROM-ENVIRONMENT,
  ;; PUTPROP-IN-ENVIRONMENT, GETDECL, and PUTDECL ?
  ;; They might differ for MACROEXPAND and EVAL1.
  (eq (env-symbol-props env1) (env-symbol-props env2)))

(defconstant undefined-flag '|<Undefined>|)

(defmacro get-from-frame-list (key frame-list &body default-value-forms)
  ;; Look up a value in a list of plists.
  ;; If the KEY is found, the corresponding value is returned.
  ;; If not found, the DEFAULT-VALUE-FORMS are executed and the value of the last returned.
  (let ((block-name (gensym))
	(env (gensym))
	(locv (gensym)))
    `(block ,block-name
       (let ((,env ,frame-list))
	 (unless (null ,env)
	   (LET ((.vcell. ,key))
	     (DOLIST (.frame. ,env)
	       (LET ((,locv (GET-LOCATION-OR-NIL (LOCF .frame.) .vcell.)))
		 (unless (null ,locv)
		   (return-from ,block-name (contents ,locv))))))))
       . ,default-value-forms)))

(defun get-from-environment (symbol property &optional default environment not-global-p)
  ;;  3/17/89 DNG - Added not-global-p option for use by FILE-LOCAL-DEF .
  (when (symbolp symbol) ; unless a locative
    (dolist (frame (env-symbol-props environment))
      (let ((locp (get-location-or-nil (locf frame) property)))
	(unless (null locp)
	  (let ((locv (get-location-or-nil locp symbol)))
	    (unless (null locv)
	      (return-from get-from-environment
		(if (eq (contents locv) undefined-flag)
		    default
		  (contents locv)))))))))
  (if not-global-p
      default
    (get symbol property default)))

(defun putprop-in-environment (symbol value property &optional environment)
  (if (or (not (environment-remote-p environment))
	  (not (symbolp symbol))) ; could be a locative
      ;;(putprop symbol value property)		; jlm 4/12/89
      (setf (get symbol property) value)
    (let ((plist (getf (car (env-symbol-props environment)) property)))
      (setf (getf plist symbol) value)
      (setf (getf (car (env-symbol-props environment)) property)
	    plist)
      value)))

(PROCLAIM '(INLINE SETPROP-IN-ENVIRONMENT))
(DEFUN SETPROP-IN-ENVIRONMENT ( SYMBOL PROPERTY default environment VALUE )
  (declare (ignore default))
  (PUTPROP-IN-ENVIRONMENT SYMBOL VALUE PROPERTY environment))
(DEFSETF GET-FROM-ENVIRONMENT SETPROP-IN-ENVIRONMENT)

(defun remprop-from-environment (symbol property &optional environment)
  (if (and (environment-remote-p environment)
	   (symbolp symbol))
      (let ((old (get-from-environment symbol property undefined-flag environment)))
	(if (eq old undefined-flag)
	    nil
	  (progn (putprop-in-environment symbol undefined-flag property environment)
		 (or old t))))
    (remprop symbol property)))

;;  4/04/89 DNG - Use new default argument of FUNCTION-SPEC-GET.
(defun function-spec-get-from-environment (function-spec property &optional default environment)
  (if (atom function-spec)
      (get-from-environment function-spec property default environment)
    (dolist (frame (env-fspec-props environment)
		   (if (eq property fdef-key)
		       default
		     (function-spec-get function-spec property default)))
      (let ((x (assoc function-spec frame :test #'equal)))
	(unless (null x)
	  (let ((locv (get-location-or-nil (locf (cdr x)) property)))
	    (unless (null locv)
	      (return-from function-spec-get-from-environment
		(if (eq (contents locv) undefined-flag)
		    default
		  (contents locv))))))))
    ))

(defun function-spec-putprop-in-environment (function-spec value property &optional environment)
  (if (atom function-spec)
      (putprop-in-environment function-spec value property environment)
    (if (not (environment-remote-p environment))
	(function-spec-putprop function-spec value property)
      (let ((frame (first (env-fspec-props environment))))
	(let ((x (assoc function-spec frame :test #'equal)))
	  (if (not (null x))
	      (setf (getf (cdr x) property) value)
	    (push (dont-optimize (cons function-spec (list property value)))
		  (first (env-fspec-props environment)))
	    ))
	value))))

(defconstant fdef-key '|Function-Definition|)
  
(comment ;; is this needed?
(defun fdefinition-from-environment (function-spec &optional environment)
  (cond ((atom function-spec)
	 (get-from-frame-list (LOCF (SYMBOL-FUNCTION function-spec))
			      (env-functions environment)
	   (fdefinition function-spec)))
	((and (eq (first function-spec) :property)
	      (symbolp (second function-spec)))
	 (get-from-environment (second function-spec) (third function-spec) nil environment))
	(t (let ((def (function-spec-get-from-environment function-spec fdef-key undefined-flag environment)))
	     (if (eq def undefined-flag)
		 (fdefinition function-spec)
	       def)))))
) ; end comment

(defun symbol-function-from-environment (symbol &optional environment)
  (get-from-frame-list (locf (symbol-function symbol))
		       (env-functions environment)
    (symbol-function symbol)))


;;;;        ==================================
;;;;        Declarations for cross-compilation
;;;;        ==================================

;;; ====  CROSS-COMPILATION SUPPORT  ====
;;;
;;;  Processor types recognized:
;;;    :CADR     represents an LMI Cadr or Lambda.
;;;    :EXPLORER represents a TI Explorer using release 1 or 2 microcode.
;;;    :ELROY    represents a TI Compact Lisp Machine or an Explorer
;;;               running microcode for release 3 or later.
;;;
(DEFCONSTANT TARGET-KINDS '(#-Elroy :EXPLORER :ELROY)
  "List of names for the kinds of processors the compiler can generate code for.")

#-Elroy
(DEFCONSTANT HOST-PROCESSOR #+Explorer :EXPLORER
                            #+Elroy    :ELROY
			    #+Cadr     :CADR
			    #+Lambda   :CADR
  "The type of machine the compiler is currently running on.")
#+Elroy
(DEFCONSTANT HOST-PROCESSOR :ELROY
  "The type of machine the compiler is currently running on.")

#-Elroy ; support cross-compilation
(DEFPARAMETER TARGET-PROCESSOR HOST-PROCESSOR
  "The type of machine the compiler is generating code for.")
#+Elroy ; making this constant disables cross-compilation.
(DEFCONSTANT TARGET-PROCESSOR HOST-PROCESSOR
  "The type of machine the compiler is generating code for.")

(DEFSUBST COMPILING-FOR-V2 ()
  "Returns true when compiling for Explorer release 3 or CLM."
  #+Elroy T
  #-Elroy
  (NOT (MEMBER TARGET-PROCESSOR '(:EXPLORER #-Elroy :CADR) :TEST #'EQ) ) )

;;  4/07/89 DNG - Instead of just NIL, initialize to an environment that defines SYMBOL-FUNCTION.
(DEFPARAMETER *TARGET-ENVIRONMENT*
	(make-environment :functions `((,(locf (symbol-function 'SYMBOL-FUNCTION))
					FSYMEVAL-FOR-TARGET))))

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

(DEFSUBST TARGET-PROPERTY-LIST ( SYMBOL )
  (GET SYMBOL TARGET-PROCESSOR) )

(PROCLAIM (IF (CONSTANTP 'TARGET-PROCESSOR)
	      '(INLINE GET-FOR-TARGET)
	    '(TRY-INLINE GET-FOR-TARGET) ; so interpreted definition is saved
	  ))
(DEFUN GET-FOR-TARGET ( SYMBOL PROPERTY &OPTIONAL DEFAULT )
  ;;  9/13/86 DNG - Use GET when arg is a locative.
  (IF (OR (EQ TARGET-PROCESSOR HOST-PROCESSOR)
	  (NOT (SYMBOLP SYMBOL)))
      (GET SYMBOL PROPERTY DEFAULT)
    (LET ( PLIST VALUE )
      (IF (AND (SETQ PLIST (TARGET-PROPERTY-LIST SYMBOL))
	       (NEQ (SETQ VALUE (GETF PLIST PROPERTY '|<Undefined>|))
		    '|<Undefined>|) )
	  VALUE
	(GET SYMBOL PROPERTY DEFAULT) ) ) ) )

(PROCLAIM '(TRY-INLINE GET-TARGET-PROPERTY))
(DEFUN GET-TARGET-PROPERTY ( SYMBOL PROPERTY &OPTIONAL DEFAULT )
  ;; This is like GET-FOR-TARGET except that it doesn't default from the host environment.
  ;; 3/4/86 - Original.
  (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
      (GET SYMBOL PROPERTY DEFAULT )
    (LET (( PLIST (TARGET-PROPERTY-LIST SYMBOL) )) ; to avoid calling SI:GET-LOCATION
      (GETF PLIST PROPERTY DEFAULT) )) )

(DEFSETF GET-TARGET-PROPERTY SET-TARGET-PROPERTY)
(PROCLAIM '(INLINE SET-TARGET-PROPERTY))
(DEFUN SET-TARGET-PROPERTY ( SYMBOL PROPERTY NEW-VALUE )
  (PUT-TARGET-PROPERTY SYMBOL NEW-VALUE PROPERTY) )

(DEFUN SYMEVAL-FOR-TARGET ( SYMBOL )
  ;; 2/19/85 - Check FILE-CONSTANTS-LIST first.
  (LET ( PLIST VALUE TM )
    (IF (SETQ TM (ASSOC SYMBOL FILE-CONSTANTS-LIST :TEST #'EQ) )
	;; Value defined by a DEFCONSTANT earlier in the current
	;; file being compiled.
	(CDR TM)
      (IF (AND (NEQ TARGET-PROCESSOR HOST-PROCESSOR)
	       (SETQ PLIST (TARGET-PROPERTY-LIST SYMBOL))
	       (NOT (EQ (SETQ VALUE (GETF PLIST 'VALUE '|<Undefined>|))
			'|<Undefined>|)) )
	  VALUE
	(SYMBOL-VALUE SYMBOL)  ) ) ) )

(DEFUN SET-FOR-TARGET ( SYMBOL VALUE )
  (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
      (SET SYMBOL VALUE)
    (UNLESS (AND (BOUNDP SYMBOL)
		 (EQL (SYMEVAL-FOR-TARGET SYMBOL) VALUE) )
      (SETF (GETF (TARGET-PROPERTY-LIST SYMBOL) 'VALUE) VALUE) ) ) )
(DEFSETF SYMEVAL-FOR-TARGET SET-FOR-TARGET)

(comment ; new versions using environments -- not used yet, might never be 
  	 ; since cross-compilation is not currently used.  -- DNG 3/16/89

(defvar target-eval-environment
	(make-environment :functions `((,(locf (symbol-function 'GET)) GET-FOR-TARGET
					,(locf (symbol-function 'SYMBOL-FUNCTION)) FSYMEVAL-FOR-TARGET
					; ... etc. ...
					))))

(defsubst get-target-environment (target) (get target 'target-environment))

(defun ensure-target-environment (target)
  ;; (let ((target (validate-target target)))
  (if (eq target host-processor)
      nil
    (or (get-target-environment target)
	(setf (get-target-environment target)
	      (extend-environment :parent target-eval-environment)))))

(DEFUN GET-FOR-TARGET ( SYMBOL PROPERTY &OPTIONAL DEFAULT )
  ;;  9/13/86 DNG - Use GET when arg is a locative.
  ;;  9/27/88 DNG - Rewritten using environments.
  (IF (OR (EQ TARGET-PROCESSOR HOST-PROCESSOR)
	  (NOT (SYMBOLP SYMBOL))) ; a locative
      (GET SYMBOL PROPERTY DEFAULT)
    (get-from-environment symbol property default *target-environment*) ) )

(DEFUN PUTPROP-FOR-TARGET ( SYMBOL NEW-VALUE PROPERTY )
  ;;  9/13/86 DNG - Fix for arg being locative instead of symbol.
  ;;  9/27/88 DNG - Rewritten using environments.
  (IF (OR (EQ TARGET-PROCESSOR HOST-PROCESSOR)
	  (NOT (SYMBOLP SYMBOL)))
      (SETF (GET SYMBOL PROPERTY) NEW-VALUE)
    (let ((environment *target-environment*))
      (UNLESS (EQUAL (get-from-environment symbol property undefined-flag environment)
		     NEW-VALUE)
	(putprop-in-environment symbol property new-value environment) ) ) ))

(DEFUN FSET-FOR-TARGET ( SYMBOL VALUE )
  (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
      (FSET SYMBOL VALUE)
    (let ((env *target-environment*)
	  (vcell (locf (symbol-function symbol))))
      (let ((loc (get-location-or-nil (locf (env-functions env)) vcell)))
	(if loc
	    (setf (contents loc) value)
	  (setf (env-functions env)
		(list* vcell value (env-functions env))))))))

(DEFUN FSYMEVAL-FOR-TARGET ( SYMBOL )
  (get-from-frame-list (LOCF (SYMBOL-FUNCTION symbol))
		       (env-functions (or *compile-file-environment*
					  *target-environment*))
    (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
	(SYMBOL-FUNCTION SYMBOL)
      ;; Need to unencapsulate so that FDEFINE of (:TARGET ...) won't replace
      ;; the encapsulated host definition.
      (SYMBOL-FUNCTION (SI:UNENCAPSULATE-FUNCTION-SPEC SYMBOL)))))

(DEFUN SYMEVAL-FOR-TARGET ( SYMBOL )
  ;; 2/19/85 - Check FILE-CONSTANTS-LIST first.
  ;; 10/4/88 DNG - Rewritten using environments.
  (LET ((TM (ASSOC SYMBOL FILE-CONSTANTS-LIST :TEST #'EQ)))
    (IF TM
	;; Value defined by a DEFCONSTANT earlier in the current
	;; file being compiled.
	(CDR TM)
      (let ((SYS:*INTERPRETER-ENVIRONMENT* (env-vars *target-environment*))
	    (SYS:*LISP-MODE* :COMMON-LISP))
	(declare (unspecial SYS:*INTERPRETER-ENVIRONMENT* SYS:*LISP-MODE*))
	(SYS:LOOKUP-SYMBOL-VALUE symbol)))))

(defun sub-environment-p (e1 e2)
  "Is environment E1 an extension of E2?"
  (let ((sublist (env-symbol-props e2))
	(list (env-symbol-props e1)))
    (if (null sublist)
	(null list)
      (do ((list list (cdr list)))
	  ((atom list) (eq list sublist))
	(if (eq sublist list)
	    (return t))))))

(DEFUN RECORD-SOURCE-FILE-NAME-IN-ENVIRONMENT (SPEC &OPTIONAL (TYPE 'DEFUN) ENVIRONMENT)
  (if (environment-remote-p environment)
      (IF (sub-environment-p environment *TARGET-ENVIRONMENT*)
	  (IF *RECORD-ALL-TARGET-DEFINITIONS* 
	      (LET (( TARGET-SPEC `(:TARGET ,TARGET-PROCESSOR ,SPEC) ))
		(RECORD-SOURCE-FILE-NAME TARGET-SPEC TYPE))
	    T)
	t)
    (RECORD-SOURCE-FILE-NAME SPEC TYPE)))

) ; end comment

;;;;  ===  macro instruction set definition  ===

(EVAL-WHEN (COMPILE LOAD)
  (WHEN (CONSTANTP 'TARGET-PROCESSOR)
    (PROCLAIM '(INLINE LAP-VALUE))))
(DEFUN LAP-VALUE ( SYMBOL )
  "Given the name of a macro-instruction, return its numeric value."
  ;;  2/17/86 - Don't default from the host environment.  This is to avoid
  ;;		accidently using old instruction names that are not
  ;;		defined in the target environment.
  ;;  3/04/86 - Use GET-TARGET-PROPERTY.
  (DECLARE (INLINE GET-TARGET-PROPERTY))
  (GET-TARGET-PROPERTY SYMBOL 'QLVAL) )

(DEFMACRO GET-DECODE-TABLE ( TABLE-NAME CREATEP SIZE )
  ;;  3/04/86 DNG - Original.
  ;;  3/05/86 DNG - Fixed creation of non-host table.
  ;;  6/25/86 DNG - Remove QUOTE from name in SPECIAL declaration.
  `(LOCALLY (DECLARE (SPECIAL ,(SECOND TABLE-NAME)))
     (IF (AND ,CREATEP
	      (NOT (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
		       (BOUNDP (DONT-OPTIMIZE ,TABLE-NAME))
		     (GETF (TARGET-PROPERTY-LIST ,TABLE-NAME) 'VALUE))) )
	 (SET-FOR-TARGET ,TABLE-NAME
			 (MAKE-ARRAY ,SIZE))
       (SYMEVAL-FOR-TARGET ,TABLE-NAME) ) ))

(DEFUN INSTRUCTION-DECODE-TABLE ( &OPTIONAL CREATE-IF-DOESNT-EXIST )
  ;;  3/04/86 DNG - Redesigned to use GET-DECODE-TABLE.
  (GET-DECODE-TABLE 'INSTRUCTION-DECODE-ARRAY
		    CREATE-IF-DOESNT-EXIST
		    (1+ (LDB (SYMEVAL-FOR-TARGET '%%QMI-FULL-OPCODE)
			     (LOGNOT 0))) ) )

(DEFUN AUX-OP-NAME-TABLE  ( &OPTIONAL CREATE-IF-DOESNT-EXIST )
  ;;  7/29/85
  ;;  3/04/86 DNG - Redesigned to use GET-DECODE-TABLE.
  (GET-DECODE-TABLE 'AUX-OP-NAME-ARRAY
		    CREATE-IF-DOESNT-EXIST
		    #o1000 ) )

(DEFUN MISC-OP-NAME-TABLE ( &OPTIONAL CREATE-IF-DOESNT-EXIST )
  ;;  3/04/86 DNG - Redesigned to use GET-DECODE-TABLE.
  (GET-DECODE-TABLE 'MISC-OP-NAME-ARRAY
		    CREATE-IF-DOESNT-EXIST
		    #+compiler:debug #o1200
		    #-compiler:debug #o1000 ) )

(DEFUN MODULE-OP-NAME-TABLE ( &OPTIONAL CREATE-IF-DOESNT-EXIST )
  ;;  3/04/86 DNG - Redesigned to use GET-DECODE-TABLE.
  (GET-DECODE-TABLE 'MODULE-OP-NAME-ARRAY
		    CREATE-IF-DOESNT-EXIST
		    (+ (LDB (SYMEVAL-FOR-TARGET '%%QMI-EXTERNAL-MODULE-NUMBER)
				      (LOGNOT 0) )
				 1) ) )

;;;;        ==================================
;;;;        Things used by EVAL, MACROEXPAND, etc.
;;;;        ==================================

(DEFUN UNDEFINED-VALUE ()
  "The expression (UNDEFINED-VALUE) is used within the compiler as the 
initial value of a local variable which does not really need to be
initialized.  Rather than generating code to call this function, the
compiler does not generate any code.  This would get called as a function
only when evaluating a macro expansion that uses it, in which case it
returns NIL."
  NIL)

;;If this is the car of a list, the cdr is a form to be evaluated at load time
;;The "#," reader macro uses this when called from COMPILE-FILE.
;;It is defined here for the sake of SI:MACRO-TYPE-CHECK-WARNING.
(DEFVAR EVAL-AT-LOAD-TIME-MARKER (COPY-SYMBOL 'EVAL-AT-LOAD-TIME-MARKER NIL)) 

;In the interpreter, this simply evals its arg.
(DEFUN QUOTE-EVAL-AT-LOAD-TIME (FORM) FORM)

(defmacro LOAD-TIME-VALUE (form &optional read-only-p)
  (declare (arglist &quote form &optional (read-only-p nil)))
  "Returns the value resulting from evaluating FORM once at load time.
If READ-ONLY-P is T, the value may be placed in a write-protected memory area."
  ;; This is the interpreter's definition; the compiler has an optimizer that 
  ;; overrides this when within COMPILE-FILE.
  ;; This is implemented here as a macro instead of a special form so that the 
  ;; macro displacing mechanism can be used to cache the value after it is 
  ;; first computed.
  ;; 2/1/89 DNG - Original - new special form for ANSI Common Lisp.
  (declare (ignore read-only-p))
  `(quote ,(eval form)))

(deff sys:eval-at-load-time 'load-time-value) ; older name used in TICLOS

(unless (fboundp 'eval-for-target)
  (fset 'eval-for-target '*eval)) ; for reading "#." in cold band.

;LOCAL-DECLARATIONS (on SYSTEM) is a list of local declarations.
;Each local declaration is a list starting with an atom which says
;what type of declaration it is.  The meaning of the rest of the
;list depends on the type of declaration.
;The compiler is interested only in SPECIAL and UNSPECIAL declarations,
;for which the rest of the list contains the symbols being declared,
;and MACRO declarations, which look like (DEF symbol MACRO LAMBDA args ..body...),
;and ARGLIST declarations, which specify arglists to go in the debugging info
;(to override the actual arglist of the function, for user information)
;which look like (ARGLIST FOO &OPTIONAL BAR ...), etc.
                                                                                                                               
;Things get onto LOCAL-DECLARATIONS in two ways:
;1) inside a LOCAL-DECLARE, the specified declarations are bound onto the front.
;2) if UNDO-DECLARATIONS-FLAG is T, some kinds of declarations
;   in a file being compiled into a QFASL file
;   are consed onto the front, and not popped off until LOCAL-DECLARATIONS
;   is unbound at the end of the whole file.
(DEFVAR LOCAL-DECLARATIONS NIL
  "List of local declarations made by LOCAL-DECLARE or DECLARE.
Each one is a list starting with a local declaration type,
followed by more information meaningful according to that type.
See also *LOCAL-DECLARATIONS-SPECIFIERS*.")
(DEFVAR UNDO-DECLARATIONS-FLAG NIL
  "T during file-to-file compilation, causes DEFMACRO and DEFSUBST to work differently.
They push elements on FILE-LOCAL-DECLARATIONS rather than
actually defining functions in the environment.")

(DEFVAR FILE-SPECIAL-LIST NIL
  "List of symbols declared globally special in file being compiled.")

(DEFVAR FILE-UNSPECIAL-LIST NIL
  "List of symbols declared globally unspecial in file being compiled.")

;FILE-LOCAL-DECLARATIONS is just like LOCAL-DECLARATIONS except that it is
;local to the file being compiled.  The reason this exists is so that if
;you have a (LOCAL-DECLARE ((ARGLIST ...)) ...) around a (MACRO...),
;at compile-time the macro wants to be saved on LOCAL-DECLARATIONS, but that
;is bound by the LOCAL-DECLARE, so it uses FILE-LOCAL-DECLARATIONS instead.
(DEFVAR FILE-LOCAL-DECLARATIONS NIL
  "Like LOCAL-DECLARATIONS for declarations at top level in file being compiled.
However, SPECIAL and UNSPECIAL declarations are handled differently
using FILE-SPECIALS and FILE-UNSPECIALS, for greater speed in SPECIALP.")

;FILE-LOCAL-DECLARATIONS-DEF-ALIST is just like FILE-LOCAL-DECLARATIONS
; except that it contains only the DEF entries
(DEFVAR FILE-LOCAL-DECLARATIONS-DEF-ALIST NIL
  "Like FILE-LOCAL-DECLARATIONS - except an alist of the DEF entries only")

(DEFMACRO DEFDECL (NAME PROPERTY VALUE)
  "Declare that the PROPERTY property of NAME is VALUE, for GETDECL.
When executed, this makes a property, like DEFPROP.
In file compilation, this makes a declaration, so that GETDECL
done in macros being expanded will see this property."
  `(PROGN (DEFPROP ,NAME ,VALUE ,PROPERTY)
	  (EVAL-WHEN (LISP:COMPILE)
	    (PUTDECL ',NAME ',PROPERTY ',VALUE))))

;; Dummy definitions of these to use if the file compiler is not loaded.
;; The real definitions are now in file "FILE".
(unless (fboundp 'PUTDECL-ALIST)
  (setf (symbol-function 'PUTDECL-ALIST) #'ignore))
(unless (fboundp 'FILE-LOCAL-DEF)
  (setf (symbol-function 'FILE-LOCAL-DEF) #'ignore))

(defsetf file-local-def putdecl-alist)

(eval-when (eval compile load) ; were inline in release 5, not in release 6
  (remprop 'file-local-def 'inline)
  (remprop 'putdecl-alist 'inline))


(DEFUN GETDECL (NAME PROPERTY &OPTIONAL DEFAULT (environment *local-environment*))
  "GET, for macro expansion and compilation.
Allows the actual property of NAME to be overridden by a local declaration 
\(property name value) such as PUTDECL or DEFDECL would create. NAME may be any 
symbol or function spec."
  ;;  3/13/86 DNG - Use GET-FOR-TARGET instead of GET.
  ;;  8/27/86 DNG - Add optional DEFAULT argument.
  ;;  9/27/88 DNG - Rewritten using environments.
  (DECLARE (OPTIMIZE SPEED))
  (DOLIST (DECL LOCAL-DECLARATIONS)
    (WHEN (AND (EQ (FIRST DECL) PROPERTY)
	       (EQUAL (SECOND DECL) NAME))
      (RETURN-FROM GETDECL (THIRD DECL))))
  (if (atom name)
      (get-from-environment name property default environment)
    (function-spec-get-from-environment name property default environment)))

(DEFUN PUTDECL (NAME PROPERTY VALUE)
  "Executed while compiling a file, creates a compile-time property.
Compile-time properties are accessed using GETDECL."
  ;;  3/13/86 DNG - Return VALUE instead of FILE-LOCAL-DECLARATIONS.
  ;; 10/04/88 DNG - Rewritten using environments.
  (if (null *compile-file-environment*)
      value
    (function-spec-putprop-in-environment name value property
					        *compile-file-environment*)))

(comment ; old version [before release 6]
;push a random declaration on for the duration of a file being compiled.
;;  7/26/88 JHO - Added support for FILE-LOCAL-DECLARATIONS-DEF-ALIST
;;  8/16/88 clm - removed support for FILE-LOCAL-DECLARATIONS-DEF-ALIST
(DEFUN PUTDECL (NAME PROPERTY VALUE)
  "Executed while compiling a file, creates a compile-time property.
Compile-time properties are accessed using GETDECL."
  ;;  3/13/86 DNG - Return VALUE instead of FILE-LOCAL-DECLARATIONS.
  (PUSH (LIST PROPERTY NAME VALUE) FILE-LOCAL-DECLARATIONS)
  VALUE)

;Get either the current loaded definition or a property
;or the actual value of the property.
(DEFUN GETDECL (NAME PROPERTY &OPTIONAL DEFAULT)
  "GET, for macro expansion and compilation.
Allows the actual property of NAME to be overridden
by a local declaration (property name value)
such as PUTDECL or DEFDECL would create.
NAME may be any symbol or function spec."
  ;;  3/13/86 DNG - Use GET-FOR-TARGET instead of GET.
  ;;  8/27/86 DNG - Add optional DEFAULT argument.
  (DECLARE (OPTIMIZE SPEED))
  (DOLIST (DECL LOCAL-DECLARATIONS)
    (WHEN (AND (EQ (FIRST DECL) PROPERTY)
	       (EQUAL (SECOND DECL) NAME))
      (RETURN-FROM GETDECL (THIRD DECL))))
  (DOLIST (DECL FILE-LOCAL-DECLARATIONS)
    (WHEN (AND (EQ (FIRST DECL) PROPERTY)
	       (EQUAL (SECOND DECL) NAME))
      (RETURN-FROM GETDECL (THIRD DECL))))
  (IF (SYMBOLP NAME)
      (GET-FOR-TARGET NAME PROPERTY DEFAULT)
    (OR (SI:FUNCTION-SPEC-GET NAME PROPERTY)
	DEFAULT)))
)

(DEFSETF GETDECL PUTDECL) ; added 3/13/86

#|
#+compiler:debug
(DEFVAR *DEFAULT-DEFS-FROM-HOST* T
  "During cross-compilation, when this is true, any functions or macros which 
are not defined in the target environment will default from the host environment.
If the value is :WARN, then a warning message is issued when defaulting occurs.")
#-compiler:debug
|#
(DEFCONSTANT *DEFAULT-DEFS-FROM-HOST* T)

(DEFPARAMETER *BARF-DEFAULTS* NIL) ; defaulted definitions already warned about

(DEFUN DECLARED-DEFINITION (FUNCTION-SPEC &OPTIONAL (ENVIRONMENT *LOCAL-ENVIRONMENT*))
  "Return the definition of FUNCTION-SPEC for macro expansion purposes.
This may be the actual definition, or it may be specified by
a local declaration.  If it is encapsulated, unencapsulate it."
  ;;  2/14/86 DNG - Modified to access definitions in target environment.
  ;;  3/13/86 DNG - Use new flag *DEFAULT-DEFS-FROM-HOST*.
  ;;  7/26/88 JHO - Added support for FILE-LOCAL-DECLARATIONS-DEF-ALIST
  ;; 10/04/88 DNG - Major revision using environments.
  ;;  4/13/89 DNG - If definition is a symbol, look up its definition only in the global environment.
  (DECLARE (OPTIMIZE (SPEED 3) (SAFETY 0)))	; to enable Tail Recursion Elimination
  (let ((def (block lookup
	       (DOLIST (L LOCAL-DECLARATIONS)
		 (WHEN (AND (EQ (CAR L) 'DEF)
			    (EQUAL (CADR L) FUNCTION-SPEC))	;Not EQ, might be a list
		   (RETURN-from lookup (CDDR L))))
	       (if (symbolp function-spec)
		   (get-from-frame-list (LOCF (SYMBOL-FUNCTION function-spec))
					(env-functions environment)
		     (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
			 (FDEFINITION-SAFE FUNCTION-SPEC 'MACRO)
		       (AND *DEFAULT-DEFS-FROM-HOST*
			    (LET (( HOST-DEF 
				   (FDEFINITION-SAFE FUNCTION-SPEC 'MACRO) ))
			      (IF (NULL HOST-DEF)
				  NIL
				(PROGN (UNLESS (OR (EQ *DEFAULT-DEFS-FROM-HOST* 'T)
						   (MEMBER FUNCTION-SPEC *BARF-DEFAULTS*
							   :TEST #'EQUAL)
						   (AND (SYMBOLP FUNCTION-SPEC)
							(OR (GET FUNCTION-SPEC 'P1)
							    (MEMBER FUNCTION-SPEC
								    '(LET LET* QUOTE PROG PROG*
									  BLOCK TAGBODY)
								    :TEST #'EQ) )))
					 (WARN 'DECLARED-DEFINITION :MISSING-DECLARATION
					       "Defaulting to host definition for ~S"
					       FUNCTION-SPEC)
					 (PUSH FUNCTION-SPEC *BARF-DEFAULTS*) )
				       HOST-DEF ))))))
		 ;; else not symbol
		 (progn
		   (unless (null environment)
		     (let ((temp (function-spec-get-from-environment
				   function-spec fdef-key undefined-flag environment)))
		       (unless (eq temp undefined-flag)
			 (return-from lookup temp))))
		   (FDEFINITION-SAFE (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
					 FUNCTION-SPEC
				       `(:TARGET ,TARGET-PROCESSOR ,FUNCTION-SPEC))
				     'MACRO))
		 ))))
    (if (and def (symbolp def))
	(declared-definition def (env-global-env environment))
      def)))

(comment ; old way [before release 6]
(DEFUN DECLARED-DEFINITION (FUNCTION-SPEC)
  "Return the definition of FUNCTION-SPEC for macro expansion purposes.
This may be the actual definition, or it may be specified by
a local declaration.  If it is encapsulated, unencapsulate it."
  ;;  2/14/86 DNG - Modified to access definitions in target environment.
  ;;  3/13/86 DNG - Use new flag *DEFAULT-DEFS-FROM-HOST*.
  ;;  7/26/88 JHO - Added support for FILE-LOCAL-DECLARATIONS-DEF-ALIST
  ;; 10/11/88 clm - Added a missing piece of code back into the function call to
  ;;                SI:FDEFINITION-SAFE [mx-bug 134].
  (DECLARE (OPTIMIZE (SPEED 3) (SAFETY 0)))  ; to enable Tail Recursion Elimination
  (LET* (
	( DEF
	 (OR
	   (DOLIST (L LOCAL-DECLARATIONS)
	     (WHEN (AND (EQ (CAR L) 'DEF)
			(EQUAL (CADR L) FUNCTION-SPEC))	;Not EQ, might be a list
	       (RETURN (CDDR L))))

	   (IF (SYMBOLP FUNCTION-SPEC)
	     (CDR (ASSQ FUNCTION-SPEC FILE-LOCAL-DECLARATIONS-DEF-ALIST))
	     (CDR (ASSOC FUNCTION-SPEC FILE-LOCAL-DECLARATIONS-DEF-ALIST :TEST 'EQUAL)))
	 	       
	     (IF (SYMBOLP FUNCTION-SPEC)
		 (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
		     (SI:FDEFINITION-SAFE FUNCTION-SPEC 'MACRO)
		     (LET (( PLIST (TARGET-PROPERTY-LIST FUNCTION-SPEC) )
			   VALUE )
		       (IF (AND PLIST
				(NEQ (SETQ VALUE (GETF PLIST 'FUNCTION '|<Undefined>|))
				     '|<Undefined>|) )
			   VALUE
			   (AND *DEFAULT-DEFS-FROM-HOST*
				(LET (( HOST-DEF 
				       (SI:FDEFINITION-SAFE FUNCTION-SPEC 'MACRO) ))
				  (IF (NULL HOST-DEF)
				      NIL
				      (PROGN (UNLESS (OR (EQ *DEFAULT-DEFS-FROM-HOST* 'T)
							 (MEMBER FUNCTION-SPEC *BARF-DEFAULTS*
								 :TEST #'EQUAL)
							 (AND (SYMBOLP FUNCTION-SPEC)
							      (OR (GET FUNCTION-SPEC 'P1)
								  (MEMBER FUNCTION-SPEC
									  '(LET LET* QUOTE PROG PROG*
										BLOCK TAGBODY)
									  :TEST #'EQ) )))
					       (WARN 'DECLARED-DEFINITION :MISSING-DECLARATION
						     "Defaulting to host definition for ~S"
						     FUNCTION-SPEC)
					       (PUSH FUNCTION-SPEC *BARF-DEFAULTS*) )
					     HOST-DEF )))))))
		 (SI:FDEFINITION-SAFE (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)
					  FUNCTION-SPEC   ;;10/11/88 clm
					  `(:TARGET ,TARGET-PROCESSOR ,FUNCTION-SPEC))
				      'MACRO)) )))
    (IF (AND DEF (SYMBOLP DEF))
	  (DECLARED-DEFINITION DEF)
  	  DEF )))
)


;;;;        ==================================
;;;;     Utilities for loader, disassembler, and EH
;;;;        ==================================

;;  The following 3 functions used to be in "SYS;QFASL.LISP".

;; Used to be called DISASSEMBLE-FETCH and EH:FEF-INSTRUCTION.
(DEFSUBST FEF-INSTRUCTION (FEF PC)
  "Given a FEF and a PC, returns the corresponding 16-bit macro instruction.
There is no error checking."
  (%P-LDB-OFFSET (IF (ZEROP (LOGAND 1 PC))
		     %%Q-LOW-HALF
		   %%Q-HIGH-HALF) 
		 FEF (TRUNCATE PC 2)))

(DEFUN FEF-LIMIT-PC (FEF &AUX LIM-PC)
  "Return the pc value of the end of the code of the fef."
  (SETQ LIM-PC (* 2 (FEF-LENGTH FEF)))
  (IF (ZEROP (FEF-INSTRUCTION FEF (1- LIM-PC)))
      (1- LIM-PC)
    LIM-PC) )

;; Used to be called DISASSEMBLE-INSTRUCTION-LENGTH
(DEFUN FEF-INSTRUCTION-LENGTH (FEF PC &AUX WD OP DISP)
  ;; 12/08/85 CLM - For Rel.3 returns the correct length
  ;;                of the new long-branch aux-ops.
  "Return the length in halfwords of the instruction at PC in FEF."
  (SETQ WD (FEF-INSTRUCTION FEF PC))
  (IF (COMPILING-FOR-V2)
      (PROGN
	(SETQ OP (LDB %%QMI-FULL-OPCODE WD))
	(IF (AND (= OP 0)		   ;AUX-OP
		 (= (LDB (BYTE 5 4) WD) 7))	   ;LONG-BRANCH
	    2
	  1) )
    (PROGN
      (SETQ OP (LDB (BYTE 4 9) WD)
	    DISP (LDB (BYTE 9 0) WD)) 
      (COND ((AND (= OP #o14) (= DISP #o777)) 2)
	    ((AND (< OP #o14) (= DISP #o776)) 2)
	    (T 1))) 
    )) 

;;;;        ==================================
;;;;           User-callable functions
;;;;        ==================================

;;  5/2/89 DNG - added doc string.
(DEFVAR *FEATURES* '(:TI :EXPLORER :COMMON-LISP :IEEE-FLOATING-POINT
		     :LISPM :FLAVORS :DEFSTRUCT :LOOP
		     #+Elroy :ELROY ; temporary indicator for Explorer release 3
		     :CHAOS :SORT :FASLOAD :STRING :NEWIO :TRACE :GRINDEF)
   "A list of atoms that describes the software and hardware features of a Lisp
implementation.  This is used by the reader macros #+ and #-")

(DEFVAR *OUTPUT-VERSION-BEHAVIOR* :SAME ; used by QC-FILE and MAKE-SYSTEM
   "Controls the version number picked for output files by COMPILE-FILE.
Its possible values and their meanings are:

 :SAME	     -- The output file has the same version as the source file.
 :NEWEST     -- The file has a version number one higher than the highest in
		existence beforehand.
 :HIGHER     -- Like :SAME, the output file has the same version as the source
		unless there is already a file with the same or higher version
		number (a \"collision\"), in which case,like :NEWEST, the next
		higher version number is used.  Note: this is a little slower.
 :ASK-HIGHER -- Like :SAME, but asks the user what to do if there is a 
		collision.  If the user does not respond, the next higher
		version is used, as in :NEWEST.
 :ASK-SAME   -- Like :ASK-HIGHER, but if the user does not respond the output
		file has the same version as the source, as in :SAME.")

(DEFUN COMPILEDP (FUNCTION &OPTIONAL DONT-UNENCAPSULATE)
  "Given a function or function spec, returns non-NIL if it is compiled.
The original interpreted definition is returned if it is known, else T."
  ;;  3/06/86 DNG - Original.
  ;;  3/13/86 DNG - Allow argument to be a closure.
  ;; 12/31/86 DNG - Fix to handle macros.
  (COND ((TYPEP FUNCTION 'COMPILED-FUNCTION)
	 (OR (LET (( DBI (SI:GET-DEBUG-INFO-STRUCT FUNCTION) ))
	       (AND DBI (SI:DBI-INTERPRETED-DEFINITION DBI)) )
	     T))
	((AND (CONSP FUNCTION)
	      (MEMBER (FIRST FUNCTION) SI:FUNCTION-START-SYMBOLS :TEST #'EQ) )
	 NIL)
	((AND (CONSP FUNCTION) (EQ (CAR FUNCTION) 'MACRO))
	 (COMPILEDP (CDR FUNCTION)))
 	((SI:VALIDATE-FUNCTION-SPEC FUNCTION)
	 (COMPILEDP (FDEFINITION (IF DONT-UNENCAPSULATE
					FUNCTION
				      (SI:UNENCAPSULATE-FUNCTION-SPEC FUNCTION)))))
	((CLOSUREP FUNCTION)
	 (AND (COMPILEDP (CLOSURE-FUNCTION FUNCTION))
	      ;; Don't return the LAMBDA expression because it is not
	      ;; sufficient by itself to re-create the closure.
	      T))
	(T (FERROR 'SYS:INVALID-FUNCTION-SPEC
		   "~S is neither a function nor the name of one."
		   FUNCTION)) ))

;;;;       Macros for defining optimizers

(DEFUN ADD-OPTIMIZER (&QUOTE TARGET-FUNCTION OPTIMIZER-NAME &REST OPTIMIZED-INTO)
  "Add OPTIMIZER-NAME to TARGET-FUNCTION's list of optimizers.
Also records that TARGET-FUNCTION sometimes gets optimized into
the functions in OPTIMIZED-INTO, for the sake of WHO-CALLS."
  ;;  5/12/86 DNG - Changed to use new function PUSH-NEW-PROPERTY.
  (PUSH-NEW-PROPERTY TARGET-FUNCTION OPTIMIZER-NAME 'OPTIMIZERS)
  (DOLIST (INTO OPTIMIZED-INTO)
    (PUSH-NEW-PROPERTY TARGET-FUNCTION INTO 'OPTIMIZED-INTO))
  OPTIMIZER-NAME)

;Style checkers are, unlike optimizers or macro definitions,
;run only on user-supplied input, not the results of expansions.
;Also, they are not expected to return any values.
;They do not alter the input, merely print warnings if there
;is anything ugly in it.

;Style checkers are used to implement RUN-IN-MACLISP-SWITCH
;and OBSOLETE-FUNCTION-WARNING-SWITCH.  They can also warn
;about anything else that is ugly or frowned upon, though legal.

(DEFMACRO ADD-STYLE-CHECKER ( FUNCTION CHECKER )
  "Have the compiler call CHECKER to check the style of calls to FUNCTION.
CHECKER should be a function taking one argument, which is the form to
be checked, and should call COMPILER:WARN to issue any warning messages."
  `(ADD-STYLE-CHECKER-1 ',FUNCTION ',CHECKER) )

(DEFUN ADD-STYLE-CHECKER-1 ( FNAME CHECKER )
  ;;  5/12/86 DNG - Changed to use new function PUSH-NEW-PROPERTY.
  (PUSH-NEW-PROPERTY FNAME CHECKER 'STYLE-CHECKER))

(DEFUN PUSH-NEW-PROPERTY ( SYMBOL HANDLER-FUNCTION PROPERTY &OPTIONAL ALLOW-LIST )
  ;; Add HANDLER-FUNCTION to the list (GET SYMBOL PROPERTY) if not already there.
  ;;  5/12/86 DNG - Original.
  (LET ((OLD (GET SYMBOL PROPERTY)))
    (UNLESS ALLOW-LIST
      (CHECK-ARG HANDLER-FUNCTION (OR (SYMBOLP HANDLER-FUNCTION)
				      (FUNCTIONP HANDLER-FUNCTION))
		 "the name of a function"))
    (UNLESS (EQ OLD HANDLER-FUNCTION)
      (SETF (GET SYMBOL PROPERTY)
	    (COND ((NULL OLD)
		   (IF (ATOM HANDLER-FUNCTION)
		       HANDLER-FUNCTION
		     (LIST HANDLER-FUNCTION)))
		  ((ATOM OLD)
		   (LIST HANDLER-FUNCTION OLD))
		  ((MEMBER HANDLER-FUNCTION OLD :TEST #'EQUAL)
		   (RETURN-FROM PUSH-NEW-PROPERTY NIL))
		  (T (LIST* HANDLER-FUNCTION OLD))))
      T)))

(DEFUN FOLD-CONSTANT-ARGUMENTS (FUNCTION-NAME)
  "Tell the compiler that if it sees a call to the designated function in which all
of the arguments are constants, then it can call the function at compile-time
and replace the function call with a QUOTE form containing the resulting value.
This also implies that the function has no side-effects, so calls can be deleted
if their value is not used."
  (PUSH-NEW-PROPERTY FUNCTION-NAME
		     (IF (AND (FBOUNDP FUNCTION-NAME)
			      (= (LENGTH (ARGLIST FUNCTION-NAME T)) 1))
			 'FOLD-ONE-ARG
		       'ARITH-OPT-NON-ASSOCIATIVE)
		     'POST-OPTIMIZERS)
  FUNCTION-NAME )


(DEFMACRO MAKE-OBSOLETE (OLD-FUNCTION NEW-FUNCTION)
  "Mark OLD-FUNCTION as obsolete, superseded by NEW-FUNCTION.
NEW-FUNCTION should be a symbol which is the new name of the function, or
a string which is a clause starting with a non-capitalized word.
Uses of OLD-FUNCTION will draw warnings from the compiler."
  ;;  1/21/86 - Added CHECK-TYPE; set property SUPERSEDED-BY instead of OBSOLETE.
  ;;  1/31/86 - Expand to call to MAKE-OBSOLETE-1 instead of PROGN.
  (CHECK-TYPE OLD-FUNCTION SYMBOL)
  `(MAKE-OBSOLETE-1 ',OLD-FUNCTION ',NEW-FUNCTION) )

(DEFUN MAKE-OBSOLETE-1 (OLD-FUNCTION NEW-FUNCTION)
  ;;  1/21/86 - Added CHECK-TYPE; set property SUPERSEDED-BY instead of OBSOLETE.
  (SETF (GET OLD-FUNCTION 'SUPERSEDED-BY) NEW-FUNCTION)
  (ADD-STYLE-CHECKER-1 OLD-FUNCTION 'WARN-OBSOLETE)) 

(DEFUN MAKE-VARIABLE-OBSOLETE ( &QUOTE OLD-NAME NEW-NAME )
  "Cause the compiler to warn about use of an obsolete name for a special variable.
OLD-NAME should be a symbol; NEW-NAME can be a symbol, form, or string."
  ;;  1/31/86 - Original version.
  (SETF (GET OLD-NAME 'OBSOLETE-VARIABLE) NEW-NAME)  )


;;;      Handle SPECIAL and UNSPECIAL declarations.

;When not compiling a file, we simply put on or remove a SPECIAL property.
;When compiling a file, we just use FILE-SPECIAL-LIST to make the change.
;SPECIAL just pushes one big entry on FILE-SPECIAL-LIST to save consing.
;UNSPECIAL, for each symbol, tries to avoid lossage in the case where a symbol
;is repeatedly made special and then unspecial again, by removing any existing
;unshadowed SPECIALs from FILE-SPECIAL-LIST and then putting an UNSPECIAL
;declaration on FILE-UNSPECIAL-LIST only if there isn't already one.  This way,
;the lists don't keep growing.

;SPECIAL-1 and UNSPECIAL-1 can be used to make a computed symbol special or unspecial.

(DEFUN SPECIAL (&QUOTE &REST SYMBOLS)
  "Make all the SYMBOLS be marked special for compilation."
  (MAPC (FUNCTION SPECIAL-1) SYMBOLS)
   T)

(DEFUN SPECIAL-1 (SYMBOL)
  "Make SYMBOL be marked special for compilation."
  ;;  4/25/89 DNG - Add use of *COMPILE-FILE-ENVIRONMENT* .
  (CHECK-TYPE SYMBOL SYMBOL) ; added 2/3/86 by DNG
  ;; The following test added 2/7/86 by DNG because someone degraded the
  ;; performance of release 2 by making IGNORE special, thus causing a
  ;; special variable binding to be done on every function that has an
  ;; argument named IGNORE.
  (WHEN (EQ SYMBOL 'IGNORE)
    (MINDEFS-WARN 'IGNORE :IMPOSSIBLE "Declaring IGNORE to be special is not allowed.")
    (RETURN-FROM SPECIAL-1))
  ;; The following check added by DNG 9/12/84
  (WHEN (AND (EQ (SYMBOL-PACKAGE SYMBOL) SI:PKG-LISP-PACKAGE)
	     (OR (FBOUNDP SYMBOL)
		 (TYPE-SPECIFIER-P SYMBOL NIL)) ; 4/25/89 for SPR 8806
	     ;; Special dispensation for variables defined in QCOM file:
	     (NOT (MEMBER (GET SYMBOL 'SPECIAL)
			  '(INIT-SYSTEM-VAR-PROPERTIES)
			  :TEST #'EQ) )
	     (NOT (EQ FDEFINE-FILE-PATHNAME 'INIT-SYSTEM-VAR-PROPERTIES))
	     ;; Special dispensation for symbols which are documented as
	     ;; being both global functions and variables. -- DNG 4/25/85
	     (NOT (MEMBER SYMBOL '(* + GLOBAL:/ CLI:/ - EVALHOOK APPLYHOOK GRINDEF ROOM
				   READ-CHECK-INDENTATION ERRSET
				   BEEP ; added 9/15/86
				   ;; constants from LROY-QCOM
				   AREA-NAME WORKING-STORAGE-AREA PERMANENT-STORAGE-AREA
				   MACRO-COMPILED-PROGRAM *RSET FASLOAD PRIN1
				   )
			  :TEST #'EQ) ) )
    (MINDEFS-WARN 'SPECIAL-1 :IMPLAUSIBLE 
	  "The symbol ~S is being globally declared as a SPECIAL variable,
which is unwise:  since it is in the ~A package, this may
have unforseen bad effects in other programs." SYMBOL (SYMBOL-PACKAGE SYMBOL))
     ;; Note: Doing a DEFVAR on a global symbol is a bad thing to do
     ;;   because it may change local variables to special variables in
     ;;   someone else's program.
     ;;   Symbols which are really supposed to be global special variables
     ;;   should all be listed in the manual and are made special by
     ;;   including them in one of the sublists of variable
     ;;   SYSTEM-VARIABLE-LISTS or SYSTEM-CONSTANT-LISTS .
     )
  (COND (UNDO-DECLARATIONS-FLAG
	 (SETF (GET-FROM-ENVIRONMENT SYMBOL 'SPECIAL NIL *COMPILE-FILE-ENVIRONMENT*) T)
	 (comment ; not needed anymore
	   (SETQ FILE-UNSPECIAL-LIST
		 (DELETE SYMBOL (THE LIST FILE-UNSPECIAL-LIST) :TEST #'EQ) )
	   (UNLESS (MEMBER SYMBOL FILE-SPECIAL-LIST :TEST #'EQ) 
	     (PUSH SYMBOL FILE-SPECIAL-LIST))))
	((GET SYMBOL 'SPECIAL)) ; don't clobber old value if already true
        (T (SETF (GET SYMBOL 'SPECIAL)
		 (OR FDEFINE-FILE-PATHNAME T)) )))

(DEFUN UNSPECIAL (&QUOTE &REST SYMBOLS)
  "Make all the SYMBOLS not be marked special for compilation."
  (MAPC (FUNCTION UNSPECIAL-1) SYMBOLS)
  T)

(DEFUN UNSPECIAL-1 (SYMBOL)
  "Make SYMBOL not be marked special for compilation."
  ;;  4/25/89 DNG - Add use of *COMPILE-FILE-ENVIRONMENT* .
  (IF UNDO-DECLARATIONS-FLAG
      (PROGN
	(SETF (GET-FROM-ENVIRONMENT SYMBOL 'SPECIAL NIL *COMPILE-FILE-ENVIRONMENT*) NIL)
	(SETF (GET-FROM-ENVIRONMENT SYMBOL 'SYSTEM-CONSTANT NIL *COMPILE-FILE-ENVIRONMENT*) NIL)
	(comment ; not needed anymore
	  (SETQ FILE-SPECIAL-LIST
		(DELETE SYMBOL (THE LIST FILE-SPECIAL-LIST) :TEST #'EQ))
	  (UNLESS (MEMBER SYMBOL FILE-UNSPECIAL-LIST :TEST #'EQ)
	    (PUSH SYMBOL FILE-UNSPECIAL-LIST))))
    (PROGN (REMPROP SYMBOL 'SPECIAL)
	   (REMPROP SYMBOL 'SYSTEM-CONSTANT))))

;; declarations declared by (PROCLAIM '(DECLARATION ...)) so that 
;; functions PROCLAIM and PROCESS-PERVASIVE-DECLARATIONS won't complain.
(DEFVAR DECLARATIONS-IGNORED '() )

(DEFUN PROCLAIM (&REST DECLARATIONS)
  ;; According to Common Lisp, this takes exactly one argument, but we permit an
  ;; arbitrary number for compatibility with MIT system 98.
  (DECLARE (ARGLIST DECLARATION-SPECIFIER))
  "Make DECLARATION-SPECIFIER be in effect globally.
Some of the declarations which are meaningful here are:
  (SPECIAL symbol)	Declare a special variable.
  (UNSPECIAL symbol)	Cancel a special variable declaration.
  (OPTIMIZE ...)	Specify compiler optimization levels for the current file.
  (INLINE name) 	Request in-line expansion of a function.
  (NOTINLINE name)	Prevent in-line expansion.
  (TYPE type var)	Declare the type of a special variable.
  (FUNCTION name arg-types result-type) Declare the type of a function."
  ;; 1/18/85 - Use SI:INTERPRETER-DECLARATION-TYPE-ALIST for compatibility
  ;;           with the interpreter.
  ;; 4/21/86 - Add handling for FTYPE and FUNCTION.
  ;; 8/27/86 - Add handling for type declarations for special variables.
  ;; 9/02/86 - SI:INTERPRETER-DECLARATION-TYPE-ALIST no longer used in release 3.
  ;;11/17/86 - Update doc string and ARGLIST declaration. [SPR 2832]
  (DOLIST (DECL DECLARATIONS)
    (IF (OR (ATOM DECL)
	    (NOT (SYMBOLP (FIRST DECL))))
        (MINDEFS-WARN 'PROCLAIM ':IMPOSSIBLE
		      "Invalid declaration syntax: (PROCLAIM '~S)" DECL)
      (LET (( DT (FIRST DECL) ) DS )
	(DECLARE (SYMBOL DT))
         (COND
           ( (MEMBER DT '(SPECIAL UNSPECIAL) :TEST #'EQ) 
             (SI:EVAL1 DECL) )
           ( (MEMBER DT '(INLINE NOTINLINE TRY-INLINE) :TEST #'EQ) 
             (DOLIST ( FN (REST DECL))
               (IF COMPILER:UNDO-DECLARATIONS-FLAG
                   (PUSH (CONS FN DT) COMPILER:INLINE-DECLARATIONS)
                 (SI:FUNCTION-SPEC-PUTPROP FN DT 'INLINE) ) ) )
           ( (EQ DT 'OPTIMIZE)
	    ;; Can be ignored if the compiler is not loaded.
	     (WHEN (FBOUNDP 'DECLARE-OPTIMIZE)
	       (DECLARE-OPTIMIZE (REST DECL))) )
	   ( (MEMBER DT '(FTYPE FUNCTION))
	    ;; Can be ignored if the compiler is not loaded.
	     (WHEN (FBOUNDP 'DECLARE-FTYPE)
	       (DECLARE-FTYPE DECL)) )
	   ((EQ DT 'TYPE)
	    (WHEN (FBOUNDP 'RECORD-SPECIAL-VAR-TYPE)
	      (RECORD-SPECIAL-VAR-TYPE (SECOND DECL) (CDDR DECL))) )
	   ( (STRING-EQUAL (SETQ DS (STRING DT)) "DECLARATION")
             (DOLIST ( X (REST DECL) )
               (UNLESS (MEMBER X DECLARATIONS-IGNORED :TEST #'EQ) 
                 (PUSH X DECLARATIONS-IGNORED) )
	       ) )
           ((STANDARD-TYPE-NAME-P DT)
	    (WHEN (FBOUNDP 'RECORD-SPECIAL-VAR-TYPE)
	      (RECORD-SPECIAL-VAR-TYPE DT (REST DECL))) )
           ( (MEMBER DT DECLARATIONS-IGNORED :TEST #'EQ)  )
           ( COMPILER:QC-FILE-IN-PROGRESS
             (MINDEFS-WARN 'PROCLAIM ':PROBABLE-ERROR
              "Unrecognized declaration: (PROCLAIM '~S)
If you want it allowed and ignored, do (PROCLAIM '(DECLARATION ~S))"
                   DECL DT) )
           ( T (FERROR NIL "Unknown declaration: (PROCLAIM '~S)" DECL) )
     ))))
  NIL)

(DEFUN STANDARD-TYPE-NAME-P (SYMBOL &OPTIONAL NO-ERROR-P)
  ;; Is this a type specifier which can also be used as a declaration name?
  ;;  8/29/86 - Original.
  ;;  9/04/86 - Recognize structures and flavors in order to accept PACKAGE and HASH-TABLE.
  ;; 10/01/86 - Modify to work in cold load without compiler.
  ;; 10/11/86 - Give warning on names not permited by Common Lisp.
  ;;  7/07/87 - Return false for FUNCTION. [SPR 5828]
  ;;  1/16/88 DNG - Return false for FUNCTION even if TYPE-SPECIFIER-P returns true.
  (AND (GETL SYMBOL '(SI:TYPE-PREDICATE SI:TYPE-OPTIMIZER SI:TYPE-EXPANDER
		      SI:DEFSTRUCT-DESCRIPTION SI:FLAVOR))
       (IF (MEMBER SYMBOL
		   '(ARRAY ATOM BIGNUM BIT BIT-VECTOR CHARACTER GLOBAL:CHARACTER COMMON
		     COMPILED-FUNCTION COMPLEX CONS DOUBLE-FLOAT FIXNUM FLOAT GLOBAL:FLOAT
		     HASH-TABLE INTEGER KEYWORD LIST LONG-FLOAT NULL NUMBER
		     PACKAGE PATHNAME RANDOM-STATE RATIO RATIONAL READTABLE SEQUENCE
		     SHORT-FLOAT SIGNED-BYTE SIMPLE-ARRAY SIMPLE-BIT-VECTOR SIMPLE-STRING
		     SIMPLE-VECTOR SINGLE-FLOAT STANDARD-CHAR STREAM STRING GLOBAL:STRING
		     STRING-CHAR SYMBOL T UNSIGNED-BYTE VECTOR ) :TEST #'EQ)
	   T
	 (IF (AND (SI:TYPE-SPECIFIER-P SYMBOL)
		  (NOT (EQ SYMBOL 'FUNCTION))
		  (NOT (MEMBER SYMBOL DECLARATIONS-IGNORED :TEST #'EQ)))
	     (PROGN
	       (UNLESS (OR NO-ERROR-P (ZETALISP-ON-P))
		 (MINDEFS-WARN 'STANDARD-TYPE-NAME-P ':IGNORABLE-MISTAKE
		   "Invalid declaration (~S ...); will assume you meant (TYPE ~S ...)."
		   SYMBOL SYMBOL))
	       T)
	   NIL))))

;;;;        ==================================
;;;;         Other stuff needed in cold load
;;;;        ==================================

(comment ; not used anymore -- DNG 5/3/89
  (DEFUN USES-TAIL-REC-P (FUNCTION)
    ;; Does the function do any D-TAIL-REC calls?
    ;;  3/25/87 DNG - Original.
    (LOOP WHILE (SYMBOLP FUNCTION)
	  DO (PROGN (UNLESS (FBOUNDP FUNCTION)
		      (RETURN-FROM USES-TAIL-REC-P NIL))
		    (SETQ FUNCTION (SYMBOL-FUNCTION FUNCTION))))
    (AND (TYPEP FUNCTION 'COMPILED-FUNCTION)
	 (GET-DEBUG-INFO-FIELD (GET-DEBUG-INFO-STRUCT FUNCTION)
			       'USES-CALLDEST-TAIL-REC)	; set in P2ARGC
	 )))

;; As of release 6.0, this function is no longer used in code generated by the 
;; compiler, but its definition is retained for compatibility with XLD files 
;; compiled on earlier releases.
(DEFUN MAKE-DYNAMIC-CLOSURE (SYMBOL-LIST FUNCTION)
  ;;  3/25/87 DNG - Original.  Calls to this are generated by P1CLOSURE.
  ;;  5/02/89 DNG - Removed check for (USES-TAIL-REC-P FUNCTION).
  (CLOSURE SYMBOL-LIST FUNCTION))

(SETF (DOCUMENTATION 'MAKE-DYNAMIC-CLOSURE) (DOCUMENTATION 'CLOSURE))

(proclaim '(try-inline self-evaluating-p))
(DEFUN SELF-EVALUATING-P (OBJECT)
  "Is it always true that (EQ (EVAL object) object) ?"
  (TYPECASE OBJECT
    (CONS NIL)
    (SYMBOL (OR (NULL OBJECT)
		(EQ OBJECT T)
		(EQ (SYMBOL-PACKAGE OBJECT) *KEYWORD-PACKAGE*)))
    (T T)))

;; These three functions are used for run-time error reporting when the compiler 
;; has generated code to validate conformance to type declarations.
(DEFUN ASSIGNMENT-TYPE-ERROR (VALUE VARIABLE-NAME TYPE-SPECIFIER)
  ;;  5/03/89 DNG - Original.
  (UNLESS (TYPEP VALUE TYPE-SPECIFIER)
    (CERROR "Proceed, assigning the value anyway."
	    "Assigning value ~S to variable ~A, which was declared to be of type ~S."
	    VALUE VARIABLE-NAME TYPE-SPECIFIER))
  VALUE)

(DEFUN ARGUMENT-TYPE-ERROR (VALUE VARIABLE-NAME TYPE-SPECIFIER)
  ;;  5/03/89 DNG - Original.
  (UNLESS (TYPEP VALUE TYPE-SPECIFIER)
    (CERROR "Proceed, using the value anyway."
	    "Parameter ~A was declared to be of type ~S, but is being given the value ~S."
	    VARIABLE-NAME TYPE-SPECIFIER VALUE))
  VALUE)

(DEFUN THE-TYPE-ERROR (VALUE FORM TYPE-SPECIFIER)
  ;;  5/04/89 DNG - Original.
  (UNLESS (TYPEP VALUE TYPE-SPECIFIER)
    (CERROR CONTINUE-MESSAGE
	    "Type mismatch in (THE ~S ~A); the actual value is ~S."
	    TYPE-SPECIFIER FORM VALUE))
  VALUE)

(DEFPROP ASSIGNMENT-TYPE-ERROR	T :ERROR-REPORTER)
(DEFPROP ARGUMENT-TYPE-ERROR	T :ERROR-REPORTER)
(DEFPROP THE-TYPE-ERROR		T :ERROR-REPORTER)