LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760030409. :SYSTEM-TYPE :LOGICAL :VERSION 8. :TYPE "LISP" :NAME "TARGET" :DIRECTORY ("REL3-SOURCE" "COMPILER") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758302966. :AUTHOR "REL3" :LENGTH-IN-BYTES 57278. :LENGTH-IN-BLOCKS 56. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                             ;;;    -*- Mode:Common-Lisp; Package:Compiler2; Base:10 -*-;;;                           RESTRICTED RIGHTS LEGEND;;;;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(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,1987 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 .;;; ====  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.0.(DEFSUBST COMPILING-FOR-EXPLORER-P ()  "Returns true when compiling for a TI processor; false for LMI."  #+Elroy 'T  #-Elroy  (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.  #+Elroy (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     (LET ( (ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON NIL) )       (COND ((NULL TARGET)      (SETQ TARGET HOST-PROCESSOR))     ((OR (STRING-EQUAL TARGET ':EXPLORER)  (STRING-EQUAL TARGET "VM1"))      (SETQ TARGET ':EXPLORER))     #-Elroy     ((STRING-EQUAL TARGET ':LAMBDA)      (IF ALLOW-LAMBDA  (SETQ TARGET ':LAMBDA)(SETQ TARGET ':CADR)) )     #-Elroy     ((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.  (DOLIST (L FILE-LOCAL-DECLARATIONS)    (WHEN (AND (EQ (CAR L) 'DEF)       (EQ (CADR L) SYMBOL))      (RETURN-FROM FSYMEVAL-FOR-TARGET (CDDR L))))  (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 )  (IF (SYMBOLP FUNCTION-SPEC)      (FSYMEVAL-FOR-TARGET FUNCTION-SPEC)    (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 variableLOC      ;; 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>|) #+Elroy 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 #-Elroy CFLAG))  ;;  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 #+Elroy 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)(WHEN (AND #-Elroy CFLAG)  (SETF (GET-FOR-TARGET SYMBOL 'COMPILER:SYSTEM-CONSTANT) CONSTANTP)))      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 GETGET-FOR-TARGETEVAL-FOR-TARGET)(DEFPROP PUTPROPPUTPROP-FOR-TARGETEVAL-FOR-TARGET)(DEFPROP SI:SETPROPSETPROP-FOR-TARGETEVAL-FOR-TARGET)(DEFPROP SETSET-FOR-TARGETEVAL-FOR-TARGET)(DEFPROP SYMEVALSYMEVAL-FOR-TARGETEVAL-FOR-TARGET)(DEFPROP SYMBOL-VALUESYMEVAL-FOR-TARGETEVAL-FOR-TARGET)(DEFPROP FSETFSET-FOR-TARGETEVAL-FOR-TARGET)(DEFPROP FDEFINEFDEFINE-FOR-TARGETEVAL-FOR-TARGET)(DEFPROP FDEFINITIONFDEFINITION-FOR-TARGETEVAL-FOR-TARGET)(DEFPROP FBOUNDPFBOUNDP-FOR-TARGETEVAL-FOR-TARGET)(DEFPROP SYMBOL-FUNCTION FSYMEVAL-FOR-TARGETEVAL-FOR-TARGET)(DEFPROP FSYMEVALFSYMEVAL-FOR-TARGETEVAL-FOR-TARGET)(DEFPROP BOUNDPBOUNDP-FOR-TARGETEVAL-FOR-TARGET)(DEFPROP SI:GET-DEFINED-VALUEIDENTITYEVAL-FOR-TARGET) ; used in QCOM(WHEN-SUPPORTING-CROSS-COMPILATION (DEFPROP SI:DEFCONST-1DEFCONST-1-FOR-TARGETEVAL-FOR-TARGET)(DEFPROP SI:DEFVAR-1DEFVAR-1-FOR-TARGETEVAL-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 IGNOREEVAL-FOR-TARGET)(DEFPROP MAKE-AREA IGNOREEVAL-FOR-TARGET)(DEFPROP SI:BOOTSTRAP-EXPORT  EXPORTEVAL-FOR-TARGET) ; added 11/10/86#-Elroy(DEFPROP SI:*EVALEVAL-FOR-TARGET EVAL-FOR-TARGET)(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 #+Elroy 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) ))(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 &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.  (COND ((NULL FORM) NIL)((SYMBOLP 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))#-Elroy ; temporarily override FUNCTION until fixed to handle MACRO forms right.((EQ (FIRST FORM) 'FUNCTION) (FUNCTION-FOR-TARGET (SECOND FORM) (SECOND ENVIRONMENT)))((AND (EQ TARGET-PROCESSOR HOST-PROCESSOR)      (NULL FILE-CONSTANTS-LIST)      (NULL FILE-LOCAL-DECLARATIONS)) ;; no need for any special handling. (SI:EVAL1 FORM))((OR (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     #-Elroy DEFUN; new DEFUN can't handle old-style property fspecs     MAKE-ARRAY MAKE-SYMBOL-IN-AREA; need to evaluate area number for host     )  :TEST #'EQ))     #-Elroy     (EQ DEFAULT-CONS-AREA EH:ERROR-HANDLER-AREA)) ; in debugger ;; need to evaluate in host environment (SI:EVAL1 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)))#+Elroy  ; temporarily moved above to override the host FUNCTION((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) )    (DECLARED-DEFINITION (FIRST FORM))) ))     (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 ))       #-Elroy       (IF (> (LDB %%ARG-DESC-MAX-ARGS (ARGS-INFO (CDR DEF))) 1)   (FUNCALL (CDR DEF) FORM  ENVIRONMENT) (FUNCALL (CDR DEF) FORM))       #+Elroy       (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 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.  (cond ((symbolp function) (if (ZETALISP-ON-P)     (FSYMEVAL-FOR-TARGET function)   ;; The following adapted from SI:INTERPRETER-FSYMEVAL    (LET ( TEM )     (DO ((restframe FUNCTION-ENVIRONMENT (CDR restframe))  (frame)) ((ATOM restframe) (FSYMEVAL-FOR-TARGET function))       (SETQ frame (CAR restframe))       (AND (SETQ tem (GET-LOCATION-OR-NIL (LOCF frame)   (FUNCTION-CELL-LOCATION function)))    (RETURN (CAR tem)))))))#-Elroy;; Temporary special handling for macros until the FUNCTION function is fixed.((eq (car-safe function) 'macro) (let ((def (FUNCTION-FOR-TARGET (cdr function) FUNCTION-ENVIRONMENT)))   (if (eq def (cdr function))       function     (cons 'macro def))))((functionp function t) (if (or (ZETALISP-ON-P) #-Elroy (and (eq si:interpreter-environment nil)      (eq si:interpreter-function-environment nil)))     function   (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.  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)  (LOCAL-DECLARATIONS NIL)  (FILE-LOCAL-DECLARATIONS 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).  (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)) (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.  (LET (( FDEFINE-FILE-PATHNAME (OR #-Elroy 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 )      :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 ) (WHEN-SUPPORTING-CROSS-COMPILATION   ;; Define SI:PROCESSOR-TYPE-CODE for use in cross-loading.  ;; Normally, reader macros should be used for selecting variants.  ;; This is just in case someone does use a test on PROCESSOR-TYPE-CODE.  #-Elroy  (UNLESS (EQ HOST-PROCESSOR ':EXPLORER)    (LET (( TARGET-PROCESSOR ':EXPLORER ))      (EVAL-FOR-TARGET '(DEFCONST SI:PROCESSOR-TYPE-CODE SI:CHAPARRAL-TYPE-CODE))      (EVAL-FOR-TARGET '(DEFCONSTANT HOST-PROCESSOR :EXPLORER))))  #-Elroy  (UNLESS (EQ HOST-PROCESSOR ':CADR)    (LET (( TARGET-PROCESSOR ':CADR ))      ;; The cross-loader doesn't distinguish Cadr from Lambda; use      ;; the Lambda value since they are more common.      (EVAL-FOR-TARGET '(DEFCONST SI:PROCESSOR-TYPE-CODE SI:LAMBDA-TYPE-CODE))      (EVAL-FOR-TARGET '(DEFCONSTANT HOST-PROCESSOR :CADR))))  #|  not needed anymore because this is now done by cross-loading MINDEFS.  (UNLESS (EQ HOST-PROCESSOR ':ELROY)    (LET (( TARGET-PROCESSOR ':ELROY ))      (EVAL-FOR-TARGET '(DEFCONSTANT HOST-PROCESSOR :ELROY))))  |#  )  ;; Initialize properties for system constants and variables.  (INIT-SYSTEM-VAR-PROPERTIES)  #-Elroy  (DEFPROP ARRAY-INDEX-ORDER T SYSTEM-CONSTANT) ; machine crashes if you change it.  #+Elroy ; wait until P1SBIND is fixed to allow MULTIPLE-VALUE-BIND of NIL.  (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 10and which implements function CAR with the result pushed onthe stack.  Other acceptable destinations are D-INDS forsetting 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)))))    (WHEN (AND INTERPRETER-DEFINITION        (EQ TARGET-PROCESSOR HOST-PROCESSOR) )      ;; Define the function to be this instruction.      ;(Comment - Exactly how to do this is not yet known. )          ) )  (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)))#+compiler:debug ; for compatibility with release 1 and 2 DEFMIC file.;World-load version of DEFMIC. (Other versions in COLD-BAND;PARAMETERS and micro-assembler.);Store into MICRO-CODE-ENTRY-ARGLIST-AREA;Put on QLVAL and QINTCMP properties(DEFMACRO DEFMIC (NAME OPCODE ARGLIST  &OPTIONAL (LISP-FUNCTION-P T) (NOT-LISP-CALLABLE-P NIL))  "Define a function that is microcoded.  Used only in SYS:COLD-BAND;DEFMIC."  ;;  6/26/85 - MISC-INSN property doesn't need to be target-dependent.  ;;  7/01/85 - Avoid storing redundant ARGLIST property; record source file name.  ;; 07/11/85 - Modified for release 3 compiler.  ;; 09/13/85 - Don't record source file if previously done by microcode dev. sys.  ;; 11/01/85 - Record source file even if LISP-FUNCTION-P is false.  ;;  1/20/86 - Changed DEFMIC to use DEF-MISC-OP instead of visa-versa.  ;;  2/01/86 - Fix :LISP-FUNCTION-P criteria.  `(DEF-MISC-OP ,(IF (ATOM NAME) NAME (LIST (CDR NAME) (CAR NAME))),OPCODE ,ARGLIST :LISP-FUNCTION-P ,(OR LISP-FUNCTION-P (NOT NOT-LISP-CALLABLE-P)):INTERPRETER-DEFINITION ,LISP-FUNCTION-P) )(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.  #+Elroy (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 #-Elroy    ((AND INTERPRETER-DEFINITION   (EQ TARGET-PROCESSOR HOST-PROCESSOR)  (NOT (COMPILING-FOR-V2))  (FBOUNDP FUNCTION-NAME)  ;In case DEFMIC file edited after cold-load made  (= (%DATA-TYPE (SYMBOL-FUNCTION FUNCTION-NAME)) DTP-U-ENTRY))     (LET (( MICRO-CODE-ENTRY-INDEX (%POINTER (SYMBOL-FUNCTION FUNCTION-NAME) ) ))       ;;there is no slot if it is not a LISP function.       (SETF (MICRO-CODE-ENTRY-ARGLIST-AREA MICRO-CODE-ENTRY-INDEX) ARGLIST) ) )    ((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) ) ) be popped off the stack on falling thru.;; However, that is some