LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031336. :SYSTEM-TYPE :LOGICAL :VERSION 22. :TYPE "LISP" :NAME "LOAD" :DIRECTORY ("REL3-SOURCE" "IO") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758637469. :AUTHOR "REL3" :LENGTH-IN-BYTES 65486. :LENGTH-IN-BLOCKS 64. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    ;;; -*- Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:8; Cold-load: T -*-;;;                           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) 1980, Massachusetts Institute of Technology; Copyright (C) 1984,1987 Texas Instruments Incorporated. All rights reserved.;;;    READFILE and FASLOAD for the Lisp Machine;;; Feb. 1984 - Version 98 from MIT via LMI.;;; 11/15/84 DNG - Modified to support EXFASL files as well as QFASL.;;; 12/08/84 DNG - Use XFASL instead of EXFASL.;;; 12/08/84 DNG - Update FASL-OP-INITIALIZE-ARRAY from MIT patch 98.50.;;;  1/16/85 DNG - Don't update record of files loaded when cross-loading.;;;  2/05/85 DNG - Precede load message by semicolon as required by;;;                Common Lisp; fix environment binding in READFILE-INTERNAL.;;;  2/21/85 DNG - Fix environment binding in FASLOAD-INTERNAL.;;;  3/04/85 DNG - Allow loading data files of either QFASL or XFASL type.;;;  4/25/85 DNG - Eliminated *EXFASL-ENABLE*.;;;  7/26/85 DNG - Fixed FASL-OP-FILE-PROPERTY-LIST for SPR 209.;;;  9/13/85 CLM - Added function FEF-CONVERT-ADDRESSES for instance variable addressing.;;;  9/26/85 DNG - Modify FASL-OP-FLOAT-FLOAT to use FLOAT instead of COPY-OBJECT.;;; 12/10/85 JK  - Change FASL-OP-PACKAGE-SYMBOL to handle uninterned symbols correctly.;;; 12/17/85 JK  - Remove support for multiple prefixes from FASL-OP-PACKAGE-SYMBOL.  This;;;                code is obsolete after the System 98 package system overhaul.;;;  1/17/86 JK  - Converted to Common Lisp.;;;  2/03/86 JK  - Include new version of FEF-INSTRUCTION-LENGTH to handle long-branch;;;                aux-ops; update TARGET-BINARY-FILE-TYPE, LOCAL-BINARY-FILE-TYPE, and;;;                VALIDATE-BINARY-FILE for VM2.;;;  2/12/86 JK  - Change to handle loading certain types of recursive data structures.;;;  2/19/86 JK  - Change FASL-OP-FRAME to support VM2 FEF format.;;;  3/06/86 JK  - Update FEF-CONVERT-ADDRESSES for VM2 instruction set.;;;  3/31/86 JK  - Speedups to FASL-OP-INITIALIZE-NUMERIC-ARRAY.;;;  4/03/86 JK  - Added new FASL-OPs for loading symbols in the KEYWORD and LISP packages specially.;;;  4/10/86 JK  - Removed FEF-INSTRUCTION, FEF-LIMIT-PC, and FEF-INSTRUCTION-LENGTH.  They;;;                are now in "sys:compiler;mindefs" because they are used by the disassembler.;;;  4/18/86 JK  - Modify FASL-OP-INITIALIZE-ARRAY and FASL-OP-INITIALIZE-NUMERIC-ARRAY;;;                to use FASL-TEMP-AREA rather than FASL-TABLE-AREA.  Also, correct;;;                several calls to RETURN-ARRAY.;;;  4/29/86 JK  - Added several efficiency improvements (eg, test the self-mapping header bit;;;                in FASL-OP-FRAME to minimize calls to FEF-CONVERT-ADDRESSES).;;;  ?/??/86 JK  - Added support for IEEE floating point numbers.;;; 10/02/86 JK  - Various changes so that strings and vectors that are FEF constants are loaded;;;                into the MACRO-COMPILED-PROGRAM area.  Also, FEF documentation strings will now;;;                be loaded into the DEBUG-INFO area.;;; 10/09/86 JK  - Changes to support VM2 canonical file type of :XLD (instead of :YFASL).;;; 12/15/86 JK  - Change to load lists in the debug-info into the DEBUG-INFO-AREA.  Also fix;;;                QFASL-STREAM-PROPERTY-LIST to bind FASL-STREAM-OFFSET & friends like FASLOAD-INTERNAL.;;; 12.19.86 MBC - Remove 2 Fs:Define-Canonical-Type that didn't belong.;;; 12/19/86 JK  - Change to handle both VM1 & VM2 character objects so VM1 data files containing;;;                character objects can be loaded.;;; 01/08/87 GRH - Incorporated Anna's TGC changes.;;;  2/02/87 JK  - Change to allow code that loads XFASL data files to be embedded within XLD files.;;;  2/23/87 JK  - Change FASL-OP-ARRAY to ensure the array is never loaded into a temporary area.;;;  3/23/87 JK  - Change the loader's storage management technique to use resources instead of;;;                RETURN-ARRAY/RETURN-STORAGE, since these are effectively disabled under TGC.;;;  This file used to be "sys:sys;qfasl.lisp".;;;The stream from which we are fasloading.(DEFVAR FASL-STREAM)(DEFVAR FASL-TABLE)  ;;; T if the stream supports :GET-INPUT-BUFFER (and therefore FASLOAD should use it).(DEFVAR FASL-STREAM-BYPASS-P) ;;; The three values returned by the :GET-INPUT-BUFFER stream operation;;; are put in these three values; the index and count are updated as the;;; elements are read from the array.(DEFVAR FASL-STREAM-ARRAY) (DEFVAR FASL-STREAM-INDEX)(DEFVAR FASL-STREAM-COUNT);;; The :GET-INPUT-BUFFER operation can reset FASL-STREAM-INDEX and FASL-STREAM-COUNT.;;; The following variables are used to support random access into the FASL-STREAM,;;; which allows certain load operations to be performed more efficiently.(DEFVAR FASL-STREAM-OFFSET)(DEFVAR LAST-FASL-STREAM-COUNT)(DEFVAR LAST-FASL-STREAM-INDEX);;; Bound to the object to send PUTPROP messages to, for file properties, etc.;;; Can be a generic pathname or an instance of PROPERTY-LIST-MIXIN.(DEFVAR FASL-GENERIC-PLIST-RECEIVER NIL) ;;; Bound by FASL-GROUP to the length of the group being processed.(DEFVAR FASL-GROUP-LENGTH);;; Bound by FASL-GROUP to the flag bit of the nibble starting the group.(DEFVAR FASL-GROUP-FLAG) ;;; Bound by FASL-WHACK; set by a group to cause FASL-WHACK to return.(DEFVAR FASL-RETURN-FLAG);;; String reused as buffer by FASL-OP-SYMBOL.(DEFVAR FASL-OP-SYMBOL-TEMP-STRING NIL) (DEFVAR LAST-FASL-FILE-PACKAGE :UNBOUND  "After FASLOAD returns, holds the package the file was loaded into.")(DEFVAR FASL-PACKAGE-SPECIFIED :UNBOUND  "Holds the PKG argument to FASLOAD.")(DEFVAR FASLOAD-FILE-PROPERTY-LIST-FLAG :UNBOUND  "T within FASLOAD-INTERNAL means exit after loading the file attribute list.")(DEFVAR FASL-FILE-PLIST :UNBOUND  "Within FASLOAD, holds attribute list of this object file.")(DEFVAR DEBUG-INFO-AREA (MAKE-AREA :NAME 'DEBUG-INFO-AREA :REPRESENTATION :LIST   :REGION-SIZE 200000   :READ-ONLY T   :GC :STATIC)  "Debugging info and documentation of FEFs goes in this area.")   (DEFVAR FASL-GROUP-DISPATCH :UNBOUND  "Array of functions to handle fasl ops, indexed by fasl op code.")  (DEFVAR PRINT-LOADED-FORMS NIL  "Set by :PRINT argument to LOAD.  Non-NIL means print the forms loaded.") (DEFVAR ACCUMULATE-FASL-FORMS NIL  "Non-NIL means FASLOAD should compute LAST-FASL-FILE-FORMS.")    (DEFVAR LAST-FASL-FILE-FORMS :UNBOUND  "FASLOAD sets this to a list of forms describing the file.Only if ACCUMULATE-FASL-FORMS is non-NIL, this variable is set to a list of formswhich are equivalent to what was done by loading the file.") ;;; In this we accumulate a list of all forms evaluated at load time.;;; Ordinary function defining is not included, nor is anything that is;;; expected to record its action as a "definition" of any sort.;;; This list is always created, and goes on the :RANDOM-FORMS property;;; of the generic pathname.(DEFVAR FASL-FILE-EVALUATIONS)(DEFVAR MACRO-MISMATCH-FUNCTIONS NIL  "List of functions fasloaded which had been compiled with different macro definitions.Each element of this list looks like (USING-FUNCTION-NAME MACRO-NAME GENERIC-PATHNAME).")(DEFVAR FASLOADED-FILE-TRUENAMES NIL  "List of truenames of all fasl files loaded.");;; FASL-OP's that create a value end up by calling this.  The value is saved;;; away in the FASL-TABLE for later use, and the index is returned (as the ;;; result of FASL-GROUP).(DEFSUBST ENTER-FASL-TABLE (V)  (VECTOR-PUSH-EXTEND V FASL-TABLE)) ;;; This is the function which gets a 16-bit "nibble" from the fasl file.(DEFSUBST FASL-NIBBLE ()  (IF (PLUSP FASL-STREAM-COUNT)      (PROG1 (AREF FASL-STREAM-ARRAY FASL-STREAM-INDEX)     (SETQ FASL-STREAM-INDEX (1+ FASL-STREAM-INDEX))     (SETQ FASL-STREAM-COUNT (1- FASL-STREAM-COUNT)))    (FASL-NIBBLE-SLOW)))(ADD-INITIALIZATION 'FASL-VARIABLES    '(SETQ ACCUMULATE-FASL-FORMS NIL   PRINT-LOADED-FORMS NIL)    '(WARM));;; (EXPORT '(LOCAL-BINARY-FILE-TYPE TARGET-BINARY-FILE-TYPE)) (DEFUN TARGET-BINARY-FILE-TYPE (TARGET)  "Returns the canonical file type for binary object files on the target machine.Either :QFASL, :XFASL, or :XLD is returned."  (CASE TARGET(:EXPLORER :XFASL)(:CADR     :QFASL)(:LAMBDA   :QFASL)(OTHERWISE  :XLD))) (DEFUN LOCAL-BINARY-FILE-TYPE ()  ;; Warning: It is tempting to make this a DEFSUBST instead of a DEFUN, but  ;;          don't do it because an inline expansion of this function would  ;;          be the wrong thing in a cross-compilation!  "Returns the canonical file type for binary object files on the current machine." :XLD);;;  3/23/87 JK  - Change the loader's storage management technique to use resources instead of;;;                RETURN-ARRAY/RETURN-STORAGE, since these are effectively disabled under TGC.(defresource fasl-table-resource ()  :constructor (make-array length-of-fasl-table   :area fasl-table-area   :type 'art-q-list    :leader-list (list fasl-table-working-offset))   :deallocator fasl-table-deallocator    :initial-copies 0)(defun fasl-table-deallocator (ignore object)  (without-interrupts    (let ((fasl-table object))      (setf fasl-table (follow-structure-forwarding fasl-table))      (array-initialize fasl-table nil 0 (fill-pointer fasl-table))      (setf (fill-pointer fasl-table) fasl-table-working-offset)      (initialize-fasl-table))));(add-initialization "Clear FASL-TABLE-RESOURCE";    '(clear-resource 'sys:fasl-table-resource);    :full-gc);;; The following variable is the Lisp evaluator used by the loader.;;; Function LOAD-FOR-TARGET binds it to EVAL-FOR-TARGET.(DEFVAR *LOADER-EVAL* '*EVAL);;; DEFVARs in "SYS:KERNEL;EVALUATOR-MACROS".(PROCLAIM '(SPECIAL *INTERPRETER-ENVIRONMENT* *INTERPRETER-FUNCTION-ENVIRONMENT*)) (DEFUN READFILE-INTERNAL (*STANDARD-INPUT* PKG NO-MSG-P)  ;; 2/5/85 DNG - Fix interpreter environment binding to not change mode.  (LET* ((FILE-ID (FUNCALL *STANDARD-INPUT* :INFO)) (PATHNAME (FUNCALL *STANDARD-INPUT* :PATHNAME)) (GENERIC-PATHNAME (FUNCALL PATHNAME :GENERIC-PATHNAME)) (*PACKAGE* *PACKAGE*) (FDEFINE-FILE-DEFINITIONS) (FDEFINE-FILE-PATHNAME GENERIC-PATHNAME) (*INTERPRETER-ENVIRONMENT* NIL) (*INTERPRETER-FUNCTION-ENVIRONMENT*   (EQ *INTERPRETER-FUNCTION-ENVIRONMENT* T)))    (FS:READ-ATTRIBUTE-LIST GENERIC-PATHNAME *STANDARD-INPUT*)    ;; Enter appropriate environment for the file    (MULTIPLE-VALUE-BIND (VARS VALS)(FS:FILE-ATTRIBUTE-BINDINGS   (IF PKG      ;; If package is specified, don't look up the file's package      ;; since that might ask the user a spurious question.      (LET ((PLIST (COPY-LIST (SEND GENERIC-PATHNAME :PLIST))))(REMPROP (LOCF PLIST) :PACKAGE)(LOCF PLIST))    GENERIC-PATHNAME))      (PROGV VARS VALS;; If package overridden, do so.  *PACKAGE* is bound in any case.(COND (PKG (SETQ *PACKAGE* (FIND-PACKAGE PKG)))      (NO-MSG-P);And tell user what it was unless told not to      (T (FORMAT T "~&; Loading ~A into package ~A~%" PATHNAME *PACKAGE*)))(DO ((EOF '(()))     ;; If the file contains a SETQ, don't alter what package we recorded loading in.     (*PACKAGE* *PACKAGE*)     (FORM))    ((EQ (SETQ FORM (READ *STANDARD-INPUT* NIL EOF)) EOF))  (IF PRINT-LOADED-FORMS      (PRINT (FUNCALL *LOADER-EVAL* FORM))    (FUNCALL *LOADER-EVAL* FORM)))(IF (EQ *LOADER-EVAL* '*EVAL)    (PROGN     ; for normal load      (SET-FILE-LOADED-ID PATHNAME FILE-ID *PACKAGE*)      (RECORD-FILE-DEFINITIONS PATHNAME (NREVERSE FDEFINE-FILE-DEFINITIONS))      PATHNAME)  (SEND *STANDARD-INPUT* :TRUENAME)) ; cross-loader needs version number    ))))(DEFUN FASLOAD (FILE-NAME &OPTIONAL PKG NO-MSG-P)  "Load a binary file.  PKG specifies package to load in.NO-MSG-P inhibits the message announcing that the loading is taking place."    (FS:MERGE-PATHNAME-DEFAULTS FILE-NAME FS:LOAD-PATHNAME-DEFAULTS NIL)  (WITH-OPEN-FILE (STREAM (FS:MERGE-and-set-PATHNAME-DEFAULTS FILE-NAME      FS:LOAD-PATHNAME-DEFAULTS      (LOCAL-BINARY-FILE-TYPE))  :CHARACTERS NIL :DIRECTION :INPUT)  (FASLOAD-INTERNAL STREAM PKG NO-MSG-P)))(DEFUN FASLOAD-INTERNAL (FASL-STREAM PKG NO-MSG-P)  ;; 2/21/85 - Fix binding of INTERPRETER-FUNCTION-ENVIRONMENT to preserve mode.  ;; 3/04/85 - Allow reading data files of either QFASL or XFASL type.  ;; 2/02/87 - Change to allow code that loads XFASL data files to be embedded within XLD files.  (using-resource (fasl-table fasl-table-resource)    (LET* ((PATHNAME (FUNCALL FASL-STREAM :PATHNAME))   (FDEFINE-FILE-PATHNAME     (IF (STRINGP PATHNAME) PATHNAME (FUNCALL PATHNAME :GENERIC-PATHNAME)))   (PATCH-SOURCE-FILE-NAMESTRING)   (FDEFINE-FILE-DEFINITIONS)   (FASL-GENERIC-PLIST-RECEIVER (FUNCALL FASL-STREAM :GENERIC-PATHNAME))   (FILE-ID (FUNCALL FASL-STREAM :INFO))   (FASL-STREAM-BYPASS-P (MEMBER :GET-INPUT-BUFFER (FUNCALL FASL-STREAM :WHICH-OPERATIONS) :TEST #'EQ))   FASL-STREAM-ARRAY FASL-STREAM-INDEX (FASL-STREAM-COUNT 0)   (FASL-STREAM-OFFSET 0)(LAST-FASL-STREAM-COUNT 0)(LAST-FASL-STREAM-INDEX 0)   (FASLOAD-FILE-PROPERTY-LIST-FLAG NIL)   (FASL-PACKAGE-SPECIFIED PKG)   FASL-FILE-EVALUATIONS   FASL-FILE-PLIST   (PREVIOUS-TYPE ACTUAL-TYPE)   FILE-TYPE   (*INTERPRETER-ENVIRONMENT* NIL)   (*INTERPRETER-FUNCTION-ENVIRONMENT* NIL))      ;; Set up the environment      (FASL-START)      (PUSH (CAR (SEND FASL-STREAM :INFO)) FASLOADED-FILE-TRUENAMES)      ;; Start by making sure the file type in the first word is really SIXBIT/QFASL/.      (SETQ FILE-TYPE (VALIDATE-BINARY-FILE FASL-STREAM NIL))      (FUNCALL FASL-GENERIC-PLIST-RECEIVER :REMPROP :MACROS-EXPANDED)      ;; Read in the file property list before choosing a package.      (WHEN (AND (FBOUNDP 'INTERN) (= (LOGAND (FASL-NIBBLE-PEEK) %FASL-GROUP-TYPE) FASL-OP-FILE-PROPERTY-LIST))      (FASL-FILE-PROPERTY-LIST)(UNLESS (OR (NULL (GET (LOCF FASL-FILE-PLIST) :COMPILE-DATA))    (EQ FILE-TYPE (LOCAL-BINARY-FILE-TYPE)))  ;; Data files such as written by DUMP-FORMS-TO-FILE can be read in  ;; either QFASL, XFASL, or XLD form, but files generated by the compiler  ;; must be of the proper type for the FEFs to be valid.  (FERROR NIL "~A is not a valid ~A file."  PATHNAME  (SYMBOL-NAME (LOCAL-BINARY-FILE-TYPE)))))      ;; Enter appropriate environment defined by file property list      (MULTIPLE-VALUE-BIND (VARS VALS)  (IF (NOT (STRINGP PATHNAME))      (FS:FILE-ATTRIBUTE-BINDINGS(IF PKG    ;; If package is specified, don't look up the file's package    ;; since that might ask the user a spurious question.    (LET ((PLIST (COPY-LIST (SEND FDEFINE-FILE-PATHNAME :PLIST))))      (REMPROP (LOCF PLIST) :PACKAGE)      (LOCF PLIST))    FDEFINE-FILE-PATHNAME)))(PROGV VARS VALS  (LET-IF (FBOUNDP 'FIND-PACKAGE)  ((*PACKAGE* (FIND-PACKAGE (OR PKG *PACKAGE*) )))    (LET-IF (FBOUNDP 'FIND-PACKAGE) ((*PACKAGE* *PACKAGE*))      (OR PKG (NOT (FBOUNDP 'FIND-PACKAGE))  ;; Don't want this message for a REL file  ;; since we don't actually know its package yet  ;; and it might have parts in several packages.  (=  (LOGAND (FASL-NIBBLE-PEEK) %FASL-GROUP-TYPE) FASL-OP-REL-FILE)  NO-MSG-P  (FORMAT T "~&; Loading ~A into package ~A~%" PATHNAME *PACKAGE*))      (IF (FBOUNDP 'FIND-PACKAGE)  (SETQ LAST-FASL-FILE-PACKAGE *PACKAGE*))      (FASL-TOP-LEVEL));load it.    (FUNCALL FASL-GENERIC-PLIST-RECEIVER :PUTPROP FASL-FILE-EVALUATIONS :RANDOM-FORMS)    (LET ((*PACKAGE* (IF (VARIABLE-BOUNDP *PACKAGE*) *PACKAGE* "SI")))      (RECORD-FILE-DEFINITIONS PATHNAME (NREVERSE FDEFINE-FILE-DEFINITIONS)       T FASL-GENERIC-PLIST-RECEIVER)      (SET-FILE-LOADED-ID PATHNAME FILE-ID *PACKAGE* )))))      (SETQ FASL-STREAM-ARRAY NIL)      (SETQ LAST-FASL-FILE-FORMS (NREVERSE LAST-FASL-FILE-FORMS))      (WHEN (AND PREVIOUS-TYPE (NEQ PREVIOUS-TYPE FILE-TYPE))(SETQ ACTUAL-TYPE PREVIOUS-TYPE))      PATHNAME)));; Validation codes in first 32 bits of a binary object file:(DEFPARAMETER VALIDATE-BINARY-FILE '((:XLD   #o70001  #o70002)     (:XFASL #o151136 #o20714)     (:QFASL #o143150 #o71660)))(DEFVAR ACTUAL-TYPE NIL "Within FASLOAD, holds the actual type of the object file.")(DEFUN VALIDATE-BINARY-FILE (FASL-STREAM     &OPTIONAL (PROPER-TYPE (LOCAL-BINARY-FILE-TYPE)))  ;; Check the first two nibbles of the file to make sure it is a  ;; valid object file.  If it is valid, the file type symbol  ;; :QFASL, :XFASL, or :XLD is returned; otherwise an error is signalled.  ;; If the second argument is NIL, any defined object file type is allowed.  (SETQ ACTUAL-TYPE(LET ((W1 (OR (SEND FASL-STREAM :TYI) 0))      (W2 (OR (SEND FASL-STREAM :TYI) 0)))  (DOLIST (X VALIDATE-BINARY-FILE NIL)    (WHEN (AND (= W1 (SECOND X)) (= W2 (THIRD X)))      (RETURN (FIRST X))))))  (UNLESS (IF (NULL PROPER-TYPE)      (NOT (NULL ACTUAL-TYPE))              (EQ ACTUAL-TYPE PROPER-TYPE))    (FERROR NIL "~A is not a valid ~A file."    (SEND FASL-STREAM :PATHNAME)    (IF (NULL PROPER-TYPE)"binary object"(SYMBOL-NAME PROPER-TYPE))))  ACTUAL-TYPE)(DEFUN QFASL-FILE-PLIST (FILE)  "Return the attribute list of a compiled file."  (WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT :CHARACTERS NIL)    (QFASL-STREAM-PROPERTY-LIST STREAM)))(DEFUN QFASL-STREAM-PROPERTY-LIST (FASL-STREAM)  ;;  9/14/85 DNG - Allow looking at either XFASL or QFASL files.  (using-resource (fasl-table fasl-table-resource)    (LET ((FASL-GENERIC-PLIST-RECEIVER (MAKE-INSTANCE 'PROPERTY-LIST-MIXIN))  (FASL-STREAM-BYPASS-P (MEMBER :GET-INPUT-BUFFER(FUNCALL FASL-STREAM :WHICH-OPERATIONS):TEST #'EQ))  FASL-STREAM-ARRAY FASL-STREAM-INDEX (FASL-STREAM-COUNT 0)  (FASL-STREAM-OFFSET 0)(LAST-FASL-STREAM-COUNT 0)(LAST-FASL-STREAM-INDEX 0)  (FASLOAD-FILE-PROPERTY-LIST-FLAG NIL))  ;; Set up the environment  (FASL-START)  ;; Start by making sure the file type in the first word is really SIXBIT/QFASL/.  (VALIDATE-BINARY-FILE FASL-STREAM NIL)  ;; Read in the file property list before choosing a package.  (COND ((= (LOGAND (FASL-NIBBLE-PEEK) %FASL-GROUP-TYPE) FASL-OP-FILE-PROPERTY-LIST) (FASL-FILE-PROPERTY-LIST)))  (FUNCALL FASL-GENERIC-PLIST-RECEIVER :PLIST))))(DEFUN RECORD-FILE-DEFINITIONS (ACCESS-PATHNAME DEFINITIONS &OPTIONAL (WHOLE-FILE T)GENERIC-PATHNAME)  "Update the list of functions defined in the file ACCESS-PATHNAME.DEFINITIONS is a list of new definitions.  WHOLE-FILE-P says flush any old ones.If any methods used to be defined in that file but aren't any longer,offer to undefine them.  You can specify GENERIC-PATHNAME to save time,or let it be computed from ACCESS-PATHNAME.The elements of DEFINITIONS look like (OBJECT-DEFINED . DEFINITION-TYPE).Usually DEFINITION-TYPE is DEFUN and OBJECT-DEFINED is a function spec."  (let ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))    (UNLESS GENERIC-PATHNAME      (SETQ GENERIC-PATHNAME    (IF (TYPEP ACCESS-PATHNAME 'INSTANCE)(FUNCALL ACCESS-PATHNAME :GENERIC-PATHNAME)(MAKE-INSTANCE 'PROPERTY-LIST-MIXIN))));Create a generic plist receiver    (LET* ((ALIST-ELEM (ASSOC *PACKAGE*      (FUNCALL GENERIC-PATHNAME :GET :DEFINITIONS)      :TEST #'EQ))   (OLD-DEFINITIONS (CDR ALIST-ELEM))   OLD-FUN)      (LOCALLY (DECLARE (SPECIAL UNANALYZED-FILES))       (IF (AND (VARIABLE-BOUNDP UNANALYZED-FILES)(NOT (MEMBER GENERIC-PATHNAME     UNANALYZED-FILES     :TEST #'EQ)))   (SETQ UNANALYZED-FILES (COPY-LIST (CONS GENERIC-PATHNAME UNANALYZED-FILES)))))      (IF (NOT WHOLE-FILE)  (SETQ DEFINITIONS (NUNION OLD-DEFINITIONS DEFINITIONS :TEST #'EQUAL)) ;replace nunion-equal dkm 7/31/86  ;; Make the data structure compact for paging efficiency.  (SETQ DEFINITIONS (COPY-TREE DEFINITIONS)))      (IF ALIST-ELEM  (RPLACD ALIST-ELEM DEFINITIONS)  (FUNCALL GENERIC-PATHNAME :PUSH-PROPERTY (CONS *PACKAGE* DEFINITIONS)   :DEFINITIONS))      (IF (NOT WHOLE-FILE)  NIL  ;; If we are doing the whole file, offer to undefine any methods deleted from the file.  (PROGN (DO ((DEFS DEFINITIONS (CDR DEFS)))     ((NULL DEFS))   (SETF (CAR DEFS) (COPY-LIST (CAR DEFS)))) (OR (FUNCALL GENERIC-PATHNAME :GET :PATCH-FILE)     (DOLIST (OLD-DEF OLD-DEFINITIONS)       (AND (CONSP OLD-DEF)    (EQ (CDR OLD-DEF) 'DEFUN)    (SETQ OLD-FUN (CAR OLD-DEF))    (CONSP OLD-FUN)    (EQ (CAR OLD-FUN) :METHOD)    ;; Leave out combined methods, which may have been present    ;; due to COMPILE-FLAVOR-METHODS.  They are handled automatically.    (OR (= (LENGTH OLD-FUN) 3)(NOT (MEMBER (CADDR OLD-FUN)     '(:COMBINED FASLOAD-COMBINED)     :TEST #'EQ)))    (NOT (MEMBER OLD-DEF DEFINITIONS :TEST #'EQUAL))    (FDEFINEDP OLD-FUN)    ;; Detect automatic methods defined by a DEFFLAVOR that is still present.    (MULTIPLE-VALUE-BIND (NAME TYPE)(FUNCTION-PARENT OLD-FUN)      (NOT (MEMBER (CONS NAME TYPE) DEFINITIONS :TEST #'EQUAL)))    (LET* ((FILES (CDR (ASSOC 'DEFUN      (GET-ALL-SOURCE-FILE-NAMES OLD-FUN)      :TEST #'EQ)))   (FILES-1 FILES))      (DO () ((NOT (AND FILES-1 (FUNCALL (CAR FILES-1) :GET :PATCH-FILE))))(POP FILES-1))      (AND (EQ (CAR FILES-1) GENERIC-PATHNAME)   (PROGN     (IF (EQ FILES FILES-1) (FORMAT *QUERY-IO* "~&File ~A no longer contains a definition of ~S.~%" ACCESS-PATHNAME OLD-FUN) (FORMAT *QUERY-IO* "~&File ~A no longer contains a definition of ~S.It was more recently redefined by patch file ~A, but no other non-patch file.~%" ACCESS-PATHNAME OLD-FUN (SEND (CAR FILES) :SOURCE-PATHNAME)))     (PROG1 (WITH-TIMEOUT ((* 60. 60.) (FORMAT *QUERY-IO* " ... Yes by timeout.") T)      (Y-OR-N-P "Undefine it? (60 sec timeout for Yes) "))    (TERPRI *QUERY-IO*)))))    (FUNDEFINE OLD-FUN)))))))))(DEFUN FASL-NIBBLE-SLOW ()    (COND (FASL-STREAM-BYPASS-P    (SETQ FASL-STREAM-OFFSET  (+ FASL-STREAM-OFFSET LAST-FASL-STREAM-COUNT LAST-FASL-STREAM-INDEX))    (COND ((<= FASL-STREAM-COUNT 0)   (COND (FASL-STREAM-ARRAY    (FUNCALL FASL-STREAM :ADVANCE-INPUT-BUFFER)))   (MULTIPLE-VALUE-SETQ (FASL-STREAM-ARRAY FASL-STREAM-INDEX FASL-STREAM-COUNT)     (FUNCALL FASL-STREAM :GET-INPUT-BUFFER))   (SETQ LAST-FASL-STREAM-COUNT FASL-STREAM-COUNT LAST-FASL-STREAM-INDEX FASL-STREAM-INDEX)))    (PROG1 (AREF FASL-STREAM-ARRAY FASL-STREAM-INDEX)   (SETQ FASL-STREAM-INDEX (1+ FASL-STREAM-INDEX))   (SETQ FASL-STREAM-COUNT (1- FASL-STREAM-COUNT))))  (T (FUNCALL FASL-STREAM :TYI))));;; Look ahead at the next nibble without discarding it.(DEFUN FASL-NIBBLE-PEEK ()   (COND (FASL-STREAM-BYPASS-P (PROG1 (FASL-NIBBLE)(SETQ FASL-STREAM-COUNT (1+ FASL-STREAM-COUNT))(SETQ FASL-STREAM-INDEX (1- FASL-STREAM-INDEX))))(T (LET ((TEM (FUNCALL FASL-STREAM :TYI)))     (FUNCALL FASL-STREAM :UNTYI TEM)     TEM))))(DEFUN FASL-START ()  (SETQ LAST-FASL-FILE-FORMS NIL)  ;;Initialize the fasl table if necessary  (COND ((NOT (VARIABLE-BOUNDP FASL-GROUP-DISPATCH)) (SETQ FASL-GROUP-DISPATCH (MAKE-ARRAY (LENGTH FASL-OPS)  ))      ;;  TGC - Area no longer exists.   :AREA CONTROL-TABLES)) (DO ((I 0 (1+ I))      (L FASL-OPS (CDR L))      (N (LENGTH FASL-OPS)))     ((>= I N))   (SETF (AREF FASL-GROUP-DISPATCH I) (CAR L))))))#+MIT(DEFUN FASL-OP-REL-FILE ()  (MULTIPLE-VALUE-SETQ (FASL-STREAM-ARRAY FASL-STREAM-INDEX FASL-STREAM-COUNT)    (QFASL-REL:REL-LOAD-STREAM FASL-STREAM       FASL-STREAM-ARRAY       FASL-STREAM-INDEX       FASL-STREAM-COUNT       FASL-PACKAGE-SPECIFIED)));;; FASL-GENERIC-PATHNAME-PLIST, FASL-STREAM, FASL-SOURCE-GENERIC-PATHNAME implicit arguments(DEFUN FASL-FILE-PROPERTY-LIST ()  ;; File property lists are all FASDed and FASLed in the "" package, so  ;; that what you FASD is what you FASL!  (LET ((*PACKAGE* (FIND-PACKAGE ""))(FASLOAD-FILE-PROPERTY-LIST-FLAG T))    (FASL-WHACK-SAVE-FASL-TABLE)))(DEFUN FASL-OP-FILE-PROPERTY-LIST ()  ;;  7/26/85 - Correct back-translation of source pathname for SPR 209.  (LET ((PLIST (FASL-NEXT-VALUE)))    (SETQ FASL-FILE-PLIST PLIST)    ;; Make the source file really correspond to where things were compiled from.    (LET ((SOURCE-PATHNAME (GETF PLIST :SOURCE-FILE-GENERIC-PATHNAME)))      (WHEN (AND (INSTANCEP FDEFINE-FILE-PATHNAME) (INSTANCEP SOURCE-PATHNAME)) ; [should be PATHNAMEP, but not in cold load];; If opened via a logical host, should record with that host in, even if;; not compiled that way.(SETQ FDEFINE-FILE-PATHNAME      (SEND (OR (SEND SOURCE-PATHNAME :SEND-IF-HANDLES      :BACK-TRANSLATED-PATHNAME SOURCE-PATHNAME)SOURCE-PATHNAME)    :GENERIC-PATHNAME))(SETQ FASL-GENERIC-PLIST-RECEIVER FDEFINE-FILE-PATHNAME)))    (DO ((PLIST PLIST (CDDR PLIST)))((NULL PLIST))      (FUNCALL FASL-GENERIC-PLIST-RECEIVER :PUTPROP (CADR PLIST) (CAR PLIST));      (WHEN PRINT-LOADED-FORMS;(PRINT `(FUNCALL ',FASL-GENERIC-PLIST-RECEIVER :PUTPROP; ',(CADR PLIST) ',(CAR PLIST))))      (AND ACCUMULATE-FASL-FORMS   (PUSH `(FUNCALL ',FASL-GENERIC-PLIST-RECEIVER :PUTPROP   ',(CADR PLIST) ',(CAR PLIST)) LAST-FASL-FILE-FORMS))))  (AND FASLOAD-FILE-PROPERTY-LIST-FLAG (SETQ FASL-RETURN-FLAG T))) ;Cause FASL-WHACK to return;;; A call to this function is written at the end of each FASL file by the compiler.(DEFUN FASL-RECORD-FILE-MACROS-EXPANDED (FILE-MACROS-EXPANDED)  ;; For files in cold load, this will be called at cold-load startup time.  ;; For now, do nothing, just avoid bombing out.  (WHEN FASL-GENERIC-PLIST-RECEIVER    (FUNCALL FASL-GENERIC-PLIST-RECEIVER :PUTPROP     FILE-MACROS-EXPANDED :MACROS-EXPANDED)    (CHECK-MACROS-EXPANDED FILE-MACROS-EXPANDED NIL)))(DEFVAR INHIBIT-MACRO-MISMATCH-WARNINGS 'BUILD-SYSTEM  "Non-NIL inhibits warnings about loading functions compiled with different versions of macros.") ;;; The above variable should be off during initial system loadup.(ADD-INITIALIZATION 'SET-INHIBIT-MACRO-MISMATCH-WARNINGS    '(AND (EQ INHIBIT-MACRO-MISMATCH-WARNINGS 'BUILD-SYSTEM)  (NEQ *TERMINAL-IO* COLD-LOAD-STREAM)  (SETQ INHIBIT-MACRO-MISMATCH-WARNINGS NIL))    '(:BEFORE-COLD :NORMAL))(DEFUN CHECK-MACROS-EXPANDED (MACRO-RECORD-LIST FUNCTION)  "Look at a list of macros and sxhashes; report any whose sxhashes don't match."  (LET ((DEFAULT-CONS-AREA WORKING-STORAGE-AREA))    (DOLIST (MACRO MACRO-RECORD-LIST)      (AND (CONSP MACRO)   (FDEFINEDP (CAR MACRO))   (FBOUNDP 'COMPILER:EXPR-SXHASH)   (LET ((CURRENT-SXHASH (COMPILER:EXPR-SXHASH (CAR MACRO))))     (AND CURRENT-SXHASH (CADR MACRO)  (NEQ (CADR MACRO) CURRENT-SXHASH)))   (PUSH (LIST FUNCTION (CAR MACRO) (SEND FASL-STREAM :TRUENAME)) MACRO-MISMATCH-FUNCTIONS)   (NOT INHIBIT-MACRO-MISMATCH-WARNINGS)   (FORMAT:OUTPUT T     (SEND *STANDARD-OUTPUT* :FRESH-LINE)     "Warning: "     (IF FUNCTION (PRIN1 FUNCTION) (PRINC (SEND FASL-STREAM :TRUENAME)))     " was compiled with a different version of macro "     (PRIN1 (CAR MACRO))     "")))));;; The :FILE-ID-PACKAGE-ALIST property of a file-symbol is an a-list;;; of packages and FILE-ID's for the version of that file loaded into;;; that package.  The FILE-ID is in the CADR rather the CDR, for expansibility.;;; Record the fact that a file has been loaded (in a certain package)(DEFUN SET-FILE-LOADED-ID (ACCESS-PATHNAME FILE-ID PKG)  (let* ((GENERIC-PATHNAME (IF (TYPEP ACCESS-PATHNAME 'INSTANCE)       (FUNCALL ACCESS-PATHNAME :GENERIC-PATHNAME)       (MAKE-INSTANCE 'PROPERTY-LIST-MIXIN)));Create a generic plist receiver (TEM (ASSOC PKG (FUNCALL GENERIC-PATHNAME :GET :FILE-ID-PACKAGE-ALIST) :TEST #'EQ)))  (COND (TEM  (RPLACA (CDR TEM) FILE-ID) (RPLACA (CDDR TEM) ACCESS-PATHNAME))(T (FUNCALL GENERIC-PATHNAME  :PUSH-PROPERTY  (LIST PKG FILE-ID ACCESS-PATHNAME)  :FILE-ID-PACKAGE-ALIST))))) ;;; Get the version of a file that was loaded into a particular package, NIL if never loaded.;;; If the package is given as NIL, the file's :PACKAGE property is used.(DEFUN GET-FILE-LOADED-ID (ACCESS-PATHNAME PKG )  (let ((GENERIC-PATHNAME (IF (TYPEP ACCESS-PATHNAME 'INSTANCE)      (FUNCALL ACCESS-PATHNAME :GENERIC-PATHNAME)      (MAKE-INSTANCE 'PROPERTY-LIST-MIXIN))));Create a generic plist receiver  (AND (NULL PKG)       (SETQ PKG (FUNCALL GENERIC-PATHNAME :GET :PACKAGE)))  (CADR (LET ((PROP (FUNCALL GENERIC-PATHNAME :GET :FILE-ID-PACKAGE-ALIST)))  (IF PKG (ASSOC (FIND-PACKAGE PKG) PROP :TEST #'EQ) (CAR PROP))))));;; This is the top-level loop of fasload, a separate function so;;; that the file-opening and closing are separated out.;;; The special variable FASL-STREAM is an implicit argument.(DEFUN FASL-TOP-LEVEL ()  (DO ()      ((EQ (FASL-WHACK) 'EOF)       T)));;; This function processes one "whack" (independent section) of a fasl file.(DEFUN FASL-WHACK ()  (FASL-WHACK-SAVE-FASL-TABLE))(DEFUN FASL-WHACK-SAVE-FASL-TABLE ()  (LET ((FASL-RETURN-FLAG))    (DO ()(FASL-RETURN-FLAG)      (FASL-GROUP))    FASL-RETURN-FLAG))(DEFUN INITIALIZE-FASL-TABLE ()  (SETF (AREF FASL-TABLE FASL-SYMBOL-HEAD-AREA) 'NR-SYM)  (SETF (AREF FASL-TABLE FASL-SYMBOL-STRING-AREA) 'P-N-STRING)  (SETF (AREF FASL-TABLE FASL-STRING-AREA) 'WORKING-STORAGE-AREA)  (SETF (AREF FASL-TABLE FASL-ARRAY-AREA) 'WORKING-STORAGE-AREA)  (SETF (AREF FASL-TABLE FASL-FRAME-AREA) 'MACRO-COMPILED-PROGRAM)  (SETF (AREF FASL-TABLE FASL-LIST-AREA) 'WORKING-STORAGE-AREA)  (SETF (AREF FASL-TABLE FASL-TEMP-LIST-AREA) 'FASL-TEMP-AREA))  ;;; Process one "group" (a single operation)(DEFUN FASL-GROUP ()  (let ((FASL-GROUP-BITS (FASL-NIBBLE)))    (when (ZEROP (LOGAND FASL-GROUP-BITS %FASL-GROUP-CHECK))      (FERROR NIL "Invalid XLD file: first nibble of group is missing the check bit."))    (let* ((FASL-GROUP-FLAG (NOT (ZEROP (LOGAND FASL-GROUP-BITS   %FASL-GROUP-FLAG))))  (FASL-GROUP-LENGTH (LDB %%FASL-GROUP-LENGTH FASL-GROUP-BITS))  (FASL-GROUP-TYPE (LOGAND FASL-GROUP-BITS %FASL-GROUP-TYPE)))      (when (= FASL-GROUP-LENGTH 377)(SETQ FASL-GROUP-LENGTH (FASL-NIBBLE)))      (FUNCALL (AREF FASL-GROUP-DISPATCH FASL-GROUP-TYPE)))));;; Get next nibble out of current group(DEFSUBST FASL-NEXT-NIBBLE ()   (COND ((MINUSP (SETQ FASL-GROUP-LENGTH (1- FASL-GROUP-LENGTH))) (FERROR NIL "Invalid XLD file: not enough nibbles in this group."))(T  (FASL-NIBBLE))));;; Get next value for current group.  Works by recursively evaluating a group.(DEFUN FASL-NEXT-VALUE ()   (AREF FASL-TABLE (FASL-GROUP)))(DEFUN FASL-STORE-EVALED-VALUE (V)  (SETF (AREF FASL-TABLE FASL-EVALED-VALUE) V)  FASL-EVALED-VALUE)  ;;;--FASL OPS;;;      The FASL-OP... symbol values are declared in "KERNEL:COLD-BAND-VM2;QDEFS.LISP"(DEFUN FASL-OP-ERR ()  (FERROR NIL "Invalid XLD file: group code 0 encountered."))(DEFUN FASL-OP-NOOP () 0)(DEFUN FASL-OP-INDEX () (FASL-NEXT-NIBBLE))(DEFUN FASL-OP-LARGE-INDEX ()  (DPB (FASL-NEXT-NIBBLE) (BYTE 10 20) (FASL-NEXT-NIBBLE))) (DEFUN FASL-OP-STRING () (FASL-OP-SYMBOL T))(DEFMACRO FASL-OP-SYMBOL-GET-STRING ()  '(OR     (DO (OLD) ((%STORE-CONDITIONAL (LOCF FASL-OP-SYMBOL-TEMP-STRING)      (SETQ OLD FASL-OP-SYMBOL-TEMP-STRING)      NIL)  OLD))     (MAKE-ARRAY 1000 :ELEMENT-TYPE 'STRING-CHAR :FILL-POINTER 0)));;; The COPY-STRING-IN-AREA defsubst is used only by FASL-OP-SYMBOL.(defsubst copy-string-in-area (string)  (let* ((length (fill-pointer string)) (new-string (make-array length :element-type 'string-char :area (aref fasl-table fasl-string-area))))    (copy-array-portion string 0 length new-string 0 length)    new-string))(DEFUN FASL-OP-SYMBOL (&OPTIONAL STRING-FLAG )  ;; Get reusable string to accumulate data in.  (let ((STRING (FASL-OP-SYMBOL-GET-STRING)))    ;; Make sure it's long enough, though.    (UNLESS (>= (ARRAY-TOTAL-SIZE STRING) (* 2 FASL-GROUP-LENGTH))      (SETQ STRING    (MAKE-ARRAY (MAX (* 2 FASL-GROUP-LENGTH) (* 2 (ARRAY-TOTAL-SIZE STRING))):ELEMENT-TYPE 'STRING-CHAR :FILL-POINTER 0)))     (SETF (FILL-POINTER STRING) 0)    ;; Read in the contents.    (DO ((NIB))((ZEROP FASL-GROUP-LENGTH))      (SETQ NIB (FASL-NEXT-NIBBLE));Two characters, packed.      (VECTOR-PUSH NIB STRING)      (OR (= (LSH NIB -10) 200) (VECTOR-PUSH (LSH NIB -10) STRING)))     ;; Construct and record the desired object.    (PROG1 (ENTER-FASL-TABLE (COND (STRING-FLAG (COPY-STRING-IN-AREA STRING))   ((NOT FASL-GROUP-FLAG)    (INTERN STRING))   (T (MAKE-SYMBOL (STRING-APPEND STRING)))))   ;; Arrange for reuse of the string.   (SETQ FASL-OP-SYMBOL-TEMP-STRING STRING))));;;  4/03/86 JK  - Added new FASL-OPs for loading symbols in the KEYWORD and LISP packages specially.(DEFUN FASL-OP-KEYWORD-SYMBOL ()  (let ((sTRING (FASL-OP-SYMBOL-GET-STRING)))    (UNLESS (>= (ARRAY-TOTAL-SIZE STRING) (* 2 FASL-GROUP-LENGTH))      (SETQ STRING    (MAKE-ARRAY (MAX (* 2 FASL-GROUP-LENGTH) (* 2 (ARRAY-TOTAL-SIZE STRING))):ELEMENT-TYPE 'STRING-CHAR :FILL-POINTER 0)))    (SETF (FILL-POINTER STRING) 0)    (DO ((NIB))((ZEROP FASL-GROUP-LENGTH))      (SETQ NIB (FASL-NEXT-NIBBLE));Two characters, packed.      (VECTOR-PUSH NIB STRING)      (OR (= (LSH NIB -10) 200) (VECTOR-PUSH (LSH NIB -10) STRING)))    (PROG1 (ENTER-FASL-TABLE (INTERN STRING PKG-KEYWORD-PACKAGE))   ;; Arrange FOR REUSE OF THE STRING.   (SETQ FASL-OP-SYMBOL-TEMP-STRING STRING))))(DEFUN FASL-OP-LISP-SYMBOL ()  (let((STRING (FASL-OP-SYMBOL-GET-STRING)))    (UNLESS (>= (ARRAY-TOTAL-SIZE STRING) (* 2 FASL-GROUP-LENGTH))      (SETQ STRING    (MAKE-ARRAY (MAX (* 2 FASL-GROUP-LENGTH) (* 2 (ARRAY-TOTAL-SIZE STRING))):ELEMENT-TYPE 'STRING-CHAR :FILL-POINTER 0)))    (SETF (FILL-POINTER STRING) 0)    (DO ((NIB))((ZEROP FASL-GROUP-LENGTH))      (SETQ NIB (FASL-NEXT-NIBBLE));Two characters, packed.      (VECTOR-PUSH NIB STRING)      (OR (= (LSH NIB -10) 200) (VECTOR-PUSH (LSH NIB -10) STRING)))    (PROG1 (ENTER-FASL-TABLE (INTERN STRING PKG-LISP-PACKAGE))   ;; Arrange for reuse of the string.   (SETQ FASL-OP-SYMBOL-TEMP-STRING STRING))))(DEFVAR FASL-INTERNAL-SYMBOL-HISTORY NIL) (DEFPARAMETER FASL-INTERNAL-DONT-RECORD   '(COMPILER::LOCAL-MAP COMPILER::ARG-MAP FASL-RECORD-FILE-MACROS-EXPANDED DEFVAR-1 XR-BQ-LIST     XR-BQ-LIST* SIMPLE-MAKE-ARRAY DEFCONST-1 *MACROARG* |-- wrong number of args to a macro.|     *SELECTQ-ITEM* XR-BQ-CONS OPERATION DEFFLAVOR2 COMBINED-METHOD-DERIVATION     COMPILE-FLAVOR-METHODS-2 FASLOAD-COMBINED METHOD-MAPPING-TABLE     COMPILE-TIME-REMEMBER-MAPPING-TABLE .FILE-ABORTED-FLAG. CONDITION-CASE-THROW MACROCALL     WRAPPER-SXHASHES SELECT-MEMQ .VAL1. .VAL2. .VAL3. LOOP-COLLECT-INIT DEFSTRUCT-DESCRIPTION     DEFSTRUCT-SLOT DEFSTRUCT-NAME ONE NOTYPE DEFSTRUCT-EXPAND-ALTER-MACRO .NEWVALUE.     ERRSET-HANDLER %%DEFSTRUCT-EMPTY%% TV::INHIBIT-SCREEN-MANAGEMENT     TV::SCREEN-MANAGER-TOP-LEVEL TV::SCREEN-MANAGER-QUEUE     TV::SCREEN-MANAGE-DELAYING-SCREEN-MANAGEMENT-INTERNAL TV::SCREEN-MANAGE-QUEUE     TV::.QUEUE-LEFT. TV::E COPY-VALUE CATCH-ERROR-RESTART-THROW     DEFMACRO-SET-INDENTATION-FOR-ZWEI TV::SHEET-FLAGS *STRING-IO-STRING* *STRING-IO-INDEX*     *STRING-IO-LIMIT* *STRING-IO-DIRECTION* *STRING-IO-STREAM* STRING-IO FORMAT::FORMAT-STRING     FORMAT::FORMAT-STRING-STREAM DEFSTRUCT-EXPAND-CONS-MACRO XR-BQ-APPEND TV::PREPARED-SHEET     TV::SHEET-PREPARE-SHEET-INTERNAL TV::SHEET-IS-PREPARED RESOURCE-CONSTRUCTOR     INITIALIZE-RESOURCE FDEFINE-FOR-DEFMETHOD COMPILER::MAP-RESULT TV::SHEET-GET-LOCK     TV::SHEET-RELEASE-LOCK DEFSELECT-INTERNAL .OPERATION. TV::ESSENTIAL-WINDOW ARGLISTNAME     TV::ESSENTIAL-SET-EDGES TV::.CURRENT-WINDOW. TV::SHEET-EXPOSE TV::FOO     TV::ADD-TYPEOUT-ITEM-TYPE-1 COMPILER::MAP-TEMP TV::.FLAG. TV::ESSENTIAL-EXPOSE     TV::ESSENTIAL-ACTIVATE TV::ESSENTIAL-MOUSE SYMBOL-PACKAGE-OFFSET TV::.OLD.OUTPUT.HOLD.     PRINT-RAW-STRING EH::MAKE-CONDITION-FUNCTION EH::FORMAT-STRING EH::FORMAT-ARGS     TV::WITH-MOUSE-GRABBED-INTERNAL TV::.OLD.VALUE. TV::LM TV::TM TV::RM TV::BM TV::.WINDOW.     SUBOPERATION CASE-METHOD-DEFAULT-HANDLER DISPOSE-OF-WARNINGS-AFTER-LAST-OBJECT     NEW-FILE-THIS-LEVEL TV::.FOR-WINDOW. TV::.OSTATUS. TV::.OSUBST. TV::.STATUS.     TV::SHEET-DEEXPOSE TV::FLAGS WITH-HELP-STREAM-1)) (DEFUN FASL-OP-PACKAGE-SYMBOL ()  (let ((LEN FASL-GROUP-LENGTH)(sym)(str)(pkg))    (COND ((NOT (= LEN 1))   (FORMAT T "This file is in the old format -- recompile the source.~%"))  (T (SETQ LEN (FASL-NEXT-NIBBLE))))    ;; This kludge is so that we can win without the package feature loaded.        ;; Values of LEN that are meaningful nowadays are:    ;; 402 - one prefix, double colon (ignore local package nicknames).    ;; 2 -- one prefix, single colon.    ;; 3 -- two prefixes, si ngle colon (no longer produced by QFASD).    ;; 4 -- three ....    ;; FASL-GROUP-FLAG is non-NIL to allow internal symbols and creation of symbols.    (SETQ STR (FASL-NEXT-VALUE))    (IF (AND FASL-GROUP-FLAG (EQUAL STR ""));; Prefix is just #: -- make uninterned symbol.(ENTER-FASL-TABLE (MAKE-SYMBOL (FASL-NEXT-VALUE)));; We want an interned symbol in some package.;; Decode the first package prefix.(PROGN  (SETQ PKG (OR (AND (NOT (= LEN 402))     (FIND-PACKAGE STR ))(PKG-FIND-PACKAGE STR :ASK)))  ;; Support for multiple prefixes, which are obsolete, was removed for Release 3.  ;; Read in the pname.  (SETQ STR (FASL-NEXT-VALUE))  ;; Get the symbol.  (SETQ SYM (INTERN STR PKG));     (WHEN (AND (MEMBER FLAG '(NIL :INTERNAL) :TEST #'EQ); (NEQ PKG-IN PKG-KEYWORD-PACKAGE); (NOT (PACKAGE-AUTO-EXPORT-P PKG-IN)); (NOT (MEMBER SYM FASL-INTERNAL-DONT-RECORD :TEST #'EQ)));(PUSH (LIST SYM FDEFINE-FILE-PATHNAME);      FASL-INTERNAL-SYMBOL-HISTORY))  ;; Ok, record the symbol we got.  (ENTER-FASL-TABLE SYM)))));;; Generate a FIXNUM (or BIGNUM) value.(DEFUN FASL-OP-FIXED ()   (DO ((POS (LSH (1- FASL-GROUP-LENGTH) 4) (- POS 20))       (C FASL-GROUP-LENGTH (1- C))       (ANS 0))      ((ZEROP C) (COND (FASL-GROUP-FLAG (SETQ ANS (- ANS)))) (ENTER-FASL-TABLE ANS))    (SETQ ANS (DPB (FASL-NEXT-NIBBLE) (+ (LSH POS 6) 20) ANS))));;; Transform a VM1 character object into a VM2 character object.  Since the only differences;;; are in the mouse, keypad, and control bits, only even nibbles are permuted.(defun transform-mouse-and-keypad-bits (vm2-nibble)  (let ((vm1-mouse-bit (ldb (byte 1 4) vm2-nibble))(vm1-nibble (lsh vm2-nibble -2)))    (dpb vm1-mouse-bit (byte 1 7) vm1-nibble)    (dpb 0 (byte 1 10) vm1-nibble)    vm1-nibble));;; Generate a CHARACTER value.;;; Handle both VM1 & VM2 character objects so VM1 data files ;;; containing character objects can be loaded.(DEFUN FASL-OP-CHARACTER ()  (DECLARE (INLINE TRANSFORM-MOUSE-AND-KEYPAD-BITS))  (IF (EQ ACTUAL-TYPE :XLD)      (DO ((POS (LSH (1- FASL-GROUP-LENGTH) 4) (- POS 20))   (C FASL-GROUP-LENGTH (1- C))   (ANS 0))  ((ZEROP C)   (COND (FASL-GROUP-FLAG (SETQ ANS (- ANS))))   (SETQ ANS (%MAKE-POINTER DTP-CHARACTER ANS))   (ENTER-FASL-TABLE ANS))(SETQ ANS (DPB (FASL-NEXT-NIBBLE) (+ (LSH POS 6) 20) ANS)))      (DO ((POS (LSH (1- FASL-GROUP-LENGTH) 4) (- POS 20))   (C FASL-GROUP-LENGTH (1- C))   (ANS 0))  ((ZEROP C)   (COND (FASL-GROUP-FLAG (SETQ ANS (- ANS))))   (SETQ ANS (%MAKE-POINTER DTP-CHARACTER ANS))   (ENTER-FASL-TABLE ANS))(SETQ ANS (DPB (IF (EVENP FASL-GROUP-LENGTH)   (TRANSFORM-MOUSE-AND-KEYPAD-BITS (FASL-NEXT-NIBBLE))   (FASL-NEXT-NIBBLE))       (+ (LSH POS 6) 20)       ANS)))))(DEFUN FASL-OP-FLOAT ()  (COND (FASL-GROUP-FLAG (FASL-OP-FLOAT-SMALL-FLOAT))(T (FASL-OP-FLOAT-FLOAT))))(defun fasl-op-float-small-float ()  (let* ((ans 0) (sign-bit 0) (exponent (fasl-next-nibble)) (fraction (fasl-next-nibble)))    (unless (zerop exponent);Top nibble 0 => 0.0s0      (if (evenp exponent);Extract the (inverted) sign bit  (setq sign-bit 1;Convert from 2's complementfraction (- #x20000 fraction));   to signed magnitude notation  (setq sign-bit 0fraction (+ #x10000 fraction)));Add top bit back in if positive      (setq exponent (+ (ash exponent -1) 62.))      (if (= fraction #x20000);Negation overflow condition  (setq fraction (ash fraction -1)exponent (1+ exponent)))      (setq ans (%logdpb sign-bit #o3001 (dpb exponent #o2010 fraction))))    (enter-fasl-table (%make-pointer dtp-short-float ans))))(defun fasl-op-float-float ()  (let* ((ans (dont-optimize (float 0)));Allocate a fresh single float (sign-bit 0) (exponent (fasl-next-nibble));First nibble only contains exponent (fraction (dpb (fasl-next-nibble) #o2020 (fasl-next-nibble))) (guard 0))    (unless (zerop exponent)      (if (not (zerop (setq sign-bit (ldb #o3701 fraction))));Extract sign bit  (setq fraction (- #x100000000 fraction)));Negate fraction if necessary      (setq guard (ldb #o0007 fraction))      (setq fraction (ldb #o0730 fraction));Use only 24 bits out of the fraction      (setq exponent (- exponent 898.));Set new bias for exponent;Perform proper rounding for the fraction (round to nearest)      (if (or (> guard #x40) (and (= guard #x40) (oddp fraction)))  (if (>= (setq fraction (1+ fraction)) #x1000000)      (setq fraction (ash fraction -1);Catch fraction overflow    exponent (1+ exponent))))      (unless (zerop sign-bit);Correct for hidden top bit(if (zerop fraction); in negative numbers    (setq fraction #x800000  exponent (1+ exponent))))      (%p-dpb-offset fraction #o0027 ans 1);Store the three individual      (%p-dpb-offset exponent #o2710 ans 1);  components in the allocated      (%p-dpb-offset sign-bit #o3701 ans 1));     single precision float    (enter-fasl-table ans)))(defun fasl-op-ieee-float ()  (cond (fasl-group-flag (fasl-op-ieee-float-short-float))(t (if (>  FASL-GROUP-LENGTH 2)       (fasl-op-ieee-float-double-float)       (fasl-op-ieee-float-single-float)))))(defun fasl-op-ieee-float-short-float ()  (prog (ans)(setq ans (%logdpb (fasl-next-nibble) #o2011 (fasl-next-nibble)))(return (enter-fasl-table (%make-pointer DTP-Short-Float ans)))))(defun fasl-op-ieee-float-single-float ()  (prog (ans)(setq ans (%allocate-and-initialize    DTP-Single-Float    DTP-Header    (DPB %Header-Type-Single-Float %%Header-Type-Field 0)    0    ()    2)) ; Must allocate new space(%p-dpb-offset (fasl-next-nibble) #o2020 ans 1)(%p-dpb-offset (fasl-next-nibble) #o0020 ans 1)(return (enter-fasl-table ans)))) (defun fasl-op-ieee-float-double-float ()  (prog (ans)    (setq ans (%allocate-and-initializeDTP-Extended-NumberDTP-Header(DPB %Header-Type-Double-Float %%Header-Type-Field 0)0()3))  ; Must allocate new space    (%p-dpb-offset (fasl-next-nibble) #o2020 ans 1)    (%p-dpb-offset (fasl-next-nibble) #o0020 ans 1)    (%p-dpb-offset (fasl-next-nibble) #o2020 ans 2)    (%p-dpb-offset (fasl-next-nibble) #o0020 ans 2)    (return (enter-fasl-table ans))))(DEFUN FASL-OP-RATIONAL ()  (LET ((RAT (MAKE-RATIONAL (FASL-NEXT-VALUE) (FASL-NEXT-VALUE))))    (ENTER-FASL-TABLE RAT)))(DEFUN FASL-OP-COMPLEX ()  (LET ((COMP (COMPLEX (FASL-NEXT-VALUE) (FASL-NEXT-VALUE))))    (ENTER-FASL-TABLE COMP)))(DEFUN FASL-OP-VM2-LIST (&OPTIONAL AREA COMPONENT-FLAG)    (IF (NULL AREA) (SETQ AREA (AREF FASL-TABLE FASL-LIST-AREA)))  ;;  2/12/86 JK  - Change to handle loading recursive lists.  (LET* ((LIST-LENGTH (FASL-NEXT-NIBBLE))         (LST (MAKE-LIST LIST-LENGTH :AREA AREA));Make the list (RETURN-VALUE (IF COMPONENT-FLAG   (FASL-STORE-EVALED-VALUE LST)   (ENTER-FASL-TABLE LST))))    (DO ((P LST (CDR P));Store the contents (N LIST-LENGTH (1- N)))((ZEROP N))      (RPLACA P (FASL-NEXT-VALUE)))    (COND (FASL-GROUP-FLAG (DOTIFY LST)));FLAG means that the last pair is dotted    RETURN-VALUE))(DEFUN FASL-OP-LIST (&OPTIONAL AREA COMPONENT-FLAG)  (IF (NULL AREA) (SETQ AREA (AREF FASL-TABLE FASL-LIST-AREA)))  (let* ((LIST-LENGTH (FASL-NEXT-NIBBLE)) (LST (MAKE-LIST LIST-LENGTH :AREA AREA)));Make the list    (DO ((P LST (CDR P));Store the contents (N LIST-LENGTH (1- N)))((ZEROP N))      (RPLACA P (FASL-NEXT-VALUE)))    (COND (FASL-GROUP-FLAG (DOTIFY LST)));FLAG means that the last pair is dotted    (IF (NULL COMPONENT-FLAG)(ENTER-FASL-TABLE LST)(FASL-STORE-EVALED-VALUE LST))))(DEFUN FASL-OP-VM2-TEMP-LIST ()  (FASL-OP-VM2-LIST (AREF FASL-TABLE FASL-TEMP-LIST-AREA)))(DEFUN FASL-OP-TEMP-LIST ()   (FASL-OP-LIST (AREF FASL-TABLE FASL-TEMP-LIST-AREA)));;; These leave the value in FASL-EVALED-VALUE instead of adding it to FASL-TABLE,;;; thus avoiding bloatage.(DEFUN FASL-OP-VM2-LIST-COMPONENT ()  (FASL-OP-VM2-LIST NIL T))(DEFUN FASL-OP-LIST-COMPONENT NIL  (FASL-OP-LIST NIL T));;; The argument must be a linear list.;;; Note (hope) that the GC cannot unlinearize a linear list.;;; The CAR of LAST of it becomes the CDR of LAST.(DEFUN DOTIFY (ARG)  (DO ((LST ARG (CDR LST)));Find the 2nd to last CONS of it      ((NULL (CDDR LST))       (OR (= (%P-CDR-CODE LST) CDR-NEXT);Make sure list is linear   (FERROR NIL "~S is not a linear list" ARG))       (%P-STORE-CDR-CODE LST CDR-NORMAL);Change last 2 single-Q nodes to one double-Q node       (%P-store-cdr-code-OFFSET CDR-ERROR LST 1);Fix 2nd cdr code for error checking;; GRH       (%P-DPB-OFFSET CDR-ERROR %%Q-CDR-CODE LST 1);Fix 2nd cdr code for error checking       ARG)));;; Array stuff;;; FASL-OP-ARRAY arguments are;;;  <value>  Area ;;;  <value>  Type symbol;;;  <value>  The dimension or dimension list (use temp-list);;;  <value>  Displace pointer (NIL if none);;;  <value>  Leader (NIL, number, or list) (use temp-list);;;  <value>  Index offset (NIL if none)(DEFUN FASL-OP-ARRAY ()  (LET ((AREA (FASL-NEXT-VALUE))     ;AREA(TYPE (FASL-NEXT-VALUE))     ;TYPE SYMBOL(DIMS (FASL-NEXT-VALUE))     ;DIMENSIONS(DISP (FASL-NEXT-VALUE))     ;DISPLACED-P(LEAD (FASL-NEXT-VALUE))     ;LEADER(IOFF (FASL-NEXT-VALUE))     ;INDEX-OFFSET(N-SS (COND (FASL-GROUP-FLAG     ;NAMED-STRUCTURE-SYMBOL     (FASL-NEXT-VALUE))    (T NIL))))    (ENTER-FASL-TABLE (MAKE-ARRAY DIMS  :TYPE TYPE;use TYPE keyword to accomodate VM1 data files  :AREA (IF (OR (NULL AREA)(EQ AREA 'WORKING-STORAGE-AREA)(AREA-TEMPORARY-P (SYMBOL-VALUE AREA)))    (AREF FASL-TABLE FASL-ARRAY-AREA)    (FIND AREA AREA-LIST :TEST #'EQ))  :DISPLACED-TO DISP  :DISPLACED-INDEX-OFFSET IOFF  :LEADER-LENGTH (IF (CONSP LEAD)     (LENGTH LEAD)     LEAD)  :LEADER-LIST (IF (CONSP LEAD)   (REVERSE LEAD))  :NAMED-STRUCTURE-SYMBOL N-SS))));;;  Get values and store them into an array.;;;  Updated 12/08/84 by D.N.G. from MIT patch 98.50 dated 4/28/84.;;;  4/18/86 JK  - Modify FASL-OP-INITIALIZE-ARRAY and FASL-OP-INITIALIZE-NUMERIC-ARRAY;;;                to use FASL-TEMP-AREA rather than FASL-TABLE-AREA.(DEFUN FASL-OP-INITIALIZE-ARRAY (&OPTIONAL LOAD-16BIT-MODE)  (LET* ((HACK (FASL-GROUP)) (temp (AREF FASL-TABLE HACK)) (ARRAY      (CHECK-ARG temp  ARRAYP "an array")) (NUM        (FASL-NEXT-VALUE));Number of values to initialize with (TEM-ARRAY;Indirect array used to store into it   (MAKE-ARRAY NUM :AREA 'FASL-TEMP-AREA       :ELEMENT-TYPE (IF LOAD-16BIT-MODE '(UNSIGNED-BYTE 20) (ARRAY-ELEMENT-TYPE ARRAY));    :TYPE (IF (NOT LOAD-16BIT-MODE) ;  (%P-MASK-FIELD %%ARRAY-TYPE-FIELD ARRAY);  'ART-16B)       :DISPLACED-TO ARRAY       :FILL-POINTER 0)))    (DO ((N NUM (1- N)))((ZEROP N));Initialize specified num of vals      (LET ((N (FASL-NIBBLE-PEEK)))(IF (= (LOGAND %FASL-GROUP-TYPE N) FASL-OP-NULL-ARRAY-ELEMENT)    (PROGN      (FASL-NIBBLE)      (VECTOR-PUSH NIL TEM-ARRAY)      (%P-STORE-DATA-TYPE (LOCF (AREF ARRAY (1- (FILL-POINTER TEM-ARRAY))))   DTP-NULL))     (VECTOR-PUSH (FASL-NEXT-VALUE) TEM-ARRAY))))     (RETURN-ARRAY (PROG1 TEM-ARRAY (SETQ TEM-ARRAY NIL)))    (IF (TYPEP ARRAY 'NAMED-STRUCTURE)(WHEN (MEMBER :FASLOAD-FIXUP      (NAMED-STRUCTURE-INVOKE :WHICH-OPERATIONS ARRAY)      :TEST #'EQ)  (NAMED-STRUCTURE-INVOKE :FASLOAD-FIXUP ARRAY)))    HACK)) ;;;  3/31/86 JK  - Speedups to FASL-OP-INITIALIZE-NUMERIC-ARRAY.;;;  8/1/86  JK  - We now look at FASL-GROUP-FLAG instead of using FAST-LOADABLE-P to accomodate;;;                VM1 data files.;(DEFSUBST FAST-LOADABLE-P (ARRAY);  (OR (MEMBER (ARRAY-TYPE ARRAY);      '(ART-16B ART-FPS-FLOAT ART-FLOAT ART-HALF-FIX ART-FAT-STRING;ART-COMPLEX-FLOAT ART-COMPLEX ART-COMPLEX-FPS-FLOAT ART-32B);      :TEST #'EQ);      (CASE (ARRAY-TYPE ARRAY);    (ART-1B (= 0 (REM (ARRAY-LENGTH ARRAY) 16.)));    (ART-4B (= 0 (REM (ARRAY-LENGTH ARRAY)  4.)));    (ART-8B (= 0 (REM (ARRAY-LENGTH ARRAY)  2.)));    (ART-STRING (= 0 (REM (ARRAY-LENGTH ARRAY) 2.))))));;;  3/31/86 JK  - Speedups to FASL-OP-INITIALIZE-NUMERIC-ARRAY.(DEFUN FASL-OP-INITIALIZE-NUMERIC-ARRAY (&OPTIONAL LOAD-16BIT-MODE)  (LET* ((HACK     (FASL-GROUP)) (TEMP     (AREF FASL-TABLE HACK)) (ARRAY    (CHECK-ARG TEMP  ARRAYP "An Array")) (FAST-NUMERIC (IF FASL-GROUP-FLAG   (FASL-NEXT-VALUE) NIL)))    (IF (AND FAST-NUMERIC     (TYPEP FASL-STREAM 'FS:LM-INPUT-STREAM))(PROGN  (LET* ((16-BIT-LENGTH (FASL-NEXT-VALUE)) (CURRENT-INDEX FASL-STREAM-INDEX) (OVERLAY-ARRAY (MAKE-ARRAY 16-BIT-LENGTH :ELEMENT-TYPE '(UNSIGNED-BYTE 20) :DISPLACED-TO ARRAY)))    (SEND FASL-STREAM :SET-POINTER (+ fasl-stream-offset FASL-STREAM-INDEX))    (SEND FASL-STREAM :STRING-IN T OVERLAY-ARRAY 0 16-BIT-LENGTH)    (MULTIPLE-VALUE-SETQ (FASL-STREAM-ARRAY FASL-STREAM-INDEX FASL-STREAM-COUNT)      (FUNCALL FASL-STREAM :GET-INPUT-BUFFER T))    (WHEN (< FASL-STREAM-INDEX CURRENT-INDEX);FASL-STREAM-INDEX & FASL-STREAM-COUNT were reset.  (SETQ FASL-STREAM-OFFSET (+ FASL-STREAM-OFFSET LAST-FASL-STREAM-COUNT LAST-FASL-STREAM-INDEX))  (SETQ LAST-FASL-STREAM-INDEX FASL-STREAM-INDEX)  (SETQ LAST-FASL-STREAM-COUNT FASL-STREAM-COUNT))    (COND (FASL-STREAM-ARRAY     (FUNCALL FASL-STREAM :ADVANCE-INPUT-BUFFER)))    ARRAY))(LET* ((NUM       (FASL-NEXT-VALUE));Number of values to initialize       (TEM-ARRAY  (MAKE-ARRAY NUM       :AREA 'FASL-TEMP-AREA       :ELEMENT-TYPE (IF LOAD-16BIT-MODE (ARRAY-ELEMENT-TYPE ARRAY) '(UNSIGNED-BYTE 20));  :TYPE (IF (NOT LOAD-16BIT-MODE) ;    (%P-MASK-FIELD %%ARRAY-TYPE-FIELD ARRAY);    'ART-16B)       :DISPLACED-TO ARRAY       :LEADER-LIST '(0))))  (DO ((N NUM (1- N)))      ((ZEROP N) NIL)    (VECTOR-PUSH (FASL-NIBBLE) TEM-ARRAY))  (RETURN-ARRAY (PROG1 TEM-ARRAY (SETQ TEM-ARRAY NIL)))))    HACK))(DEFUN FASL-OP-ARRAY-PUSH ()  (let ((ARRAY (FASL-NEXT-VALUE))(DATA (FASL-NEXT-VALUE)))    (COND ((NULL (VECTOR-PUSH DATA ARRAY))    (FERROR NIL "VECTOR-PUSH failed for ~S" ARRAY)))     0))(DEFUN FASL-OP-EVAL ()  (LET ((FORM (AREF FASL-TABLE (FASL-NEXT-NIBBLE))))    (COND ((OR (ATOM FORM) (NOT (EQ (CAR FORM) 'FUNCTION)));       (WHEN PRINT-LOADED-FORMS (PRINT FORM))   (AND ACCUMULATE-FASL-FORMS(PUSH FORM      LAST-FASL-FILE-FORMS))   (PUSH FORM FASL-FILE-EVALUATIONS)))    (FASL-STORE-EVALED-VALUE (EVAL1 FORM))));;; Calls to these functions should not be recorded.(DEFPROP DEFCONST-1 T QFASL-DONT-RECORD) (DEFPROP DEFVAR-1 T QFASL-DONT-RECORD) (DEFPROP DEFSELECT-INTERNAL T QFASL-DONT-RECORD)(DEFPROP FUNCTION-SPEC-PUTPROP T QFASL-DONT-RECORD)(DEFPROP FDEFINITION-LOCATION T QFASL-DONT-RECORD)(DEFPROP RECORD-SOURCE-FILE-NAME T QFASL-DONT-RECORD)(DEFPROP DEFMACRO-SET-INDENTATION-FOR-ZWEI T QFASL-DONT-RECORD)(DEFPROP FS:MAKE-FASLOAD-PATHNAME T QFASL-DONT-RECORD) ;;; These properties should not be recorded when they are DEFPROPed.(DEFPROP DEFSTRUCT-SLOT T QFASL-DONT-RECORD) (DEFPROP DEFSTRUCT-DESCRIPTION T QFASL-DONT-RECORD)(DEFPROP DEFSTRUCT-NAME T QFASL-DONT-RECORD) (DEFUN FASL-OP-EVAL1 ()   (let ((FORM (FASL-NEXT-VALUE)))    (COND ((OR (ATOM FORM) (NOT (EQ (CAR FORM) 'FUNCTION)));       (WHEN PRINT-LOADED-FORMS (PRINT FORM))   (AND ACCUMULATE-FASL-FORMS(PUSH FORM      LAST-FASL-FILE-FORMS))   (IF (NOT (AND (CONSP FORM) (OR (GET (CAR FORM) 'QFASL-DONT-RECORD)     (AND (EQ (CAR FORM) 'FDEFINE)  (EQ (FOURTH FORM) T))     (AND (EQ (CAR FORM) 'DEFPROP)  (GET (FOURTH FORM) 'QFASL-DONT-RECORD)))))       (PUSH FORM FASL-FILE-EVALUATIONS))))    (ENTER-FASL-TABLE (*EVAL FORM))))(DEFUN FASL-OP-MOVE ()  (let ((FROM (FASL-NEXT-NIBBLE))(TO (FASL-NEXT-NIBBLE)))    (COND      ((= TO 177777)       (ENTER-FASL-TABLE (AREF FASL-TABLE FROM)))      (T (SETF (AREF FASL-TABLE TO) (AREF FASL-TABLE FROM)) TO))))(DEFUN FEF-CONVERT-ADDRESSES (FEF &AUX ILEN LIM-PC);;Convert indirect addressing used for flavor instance variables;;in machine instructions to direct addressing.;;9-13-85 CLM;;  3/06/86 JK  - Update for VM2 instruction set.    (SETQ LIM-PC (FEF-LIMIT-PC FEF))  (DO ((PC (FEF-INITIAL-PC FEF) (+ PC ILEN)))      ((>= PC LIM-PC))    (LET* ((INSN (FEF-INSTRUCTION FEF PC))   (OP (ASH INSN -11))   (REG (LDB si:%%QMI-REGISTER INSN)));New symbolic constants will eventually be in SYS - jk      (SETQ ILEN (FEF-INSTRUCTION-LENGTH FEF PC))      (WHEN (AND (= ILEN 1);Not a long-branch (< OP #o160) (OR (< REG si:%QMI-REG-LEX);FEF base register     (= OP #o70)));Push-long-FEF;; Now see if instruction has a destination(LET* ((NAME (AREF (compiler:INSTRUCTION-DECODE-TABLE) OP))       (NO-REG (GET NAME 'Compiler:NO-REG)))  (WHEN (OR (NULL NO-REG)    (= OP #o70))    (LET* ((OFFSET (LDB si:%%QMI-FEF-OFFSET INSN))   (FEF-DATA (%P-pointer-OFFSET FEF OFFSET))   (FEF-dtp (%P-data-type-OFFSET FEF OFFSET)));; GRH   (FEF-DATA (%P-ldb-OFFSET sys:%%q-pointer  FEF OFFSET));;   (FEF-dtp (%P-ldb-OFFSET sys:%%q-data-type  FEF OFFSET)))      (WHEN (=  FEF-DTP sys:DTP-Self-Ref-Pointer) (LET ((FLAG (LDB (BYTE 3 #o21) FEF-DATA))        ;Flag bit of the SRP word      (INDEX (LDB si:%%SELF-REF-INDEX FEF-DATA)));Pointer field of the SRP word  (COND        ((OR (= FLAG 2);MAP-LEADER-FLAG is set, so can't use SELF-MAPPING-TABLE (= FLAG 1));MONITOR-FLAG is set, so SRP is a monitor ptr (these never appear in methods)     NIL)        ((> INDEX 37) NIL);Pointer is too big for INSN address field.        ((= FLAG 4);RELOCATE-FLAG is set     (SETF (FEF-INSTRUCTION FEF PC)          (DPB (DPB si:%QMI-REG-IVAR si:%%QMI-REGISTER     (+ INDEX (BYTE-MASK si:%%QMI-IVAR-MAPPED)))(BYTE #o11 0)INSN)));Offset in SELF-MAPPING-TABLE        ((= FLAG 0);RELOCATE-FLAG is not set     (SETF (FEF-INSTRUCTION FEF PC)   (DPB (DPB si:%QMI-REG-IVAR si:%%QMI-REGISTER INDEX)(BYTE #o11 0)INSN)));Offset in SELF (unmapped)    (T NIL))  )))))))     ))(DEFUN FASL-OP-FEF () ; new (November 1984) FEF header format for Explorer  (FASL-OP-FRAME T))(DEFUN FASL-OP-FRAME (&OPTIONAL EXPLORER-P)  (UNLESS (EQ EXPLORER-P      (EQ (LOCAL-BINARY-FILE-TYPE)  (TARGET-BINARY-FILE-TYPE :ELROY))      )    (FERROR NIL "Wrong function header format encountered in ~S."(SEND FASL-STREAM :PATHNAME)))  (LET ((Q-COUNT (FASL-NEXT-NIBBLE));Number of boxed Q's(UNBOXED-COUNT (FASL-NEXT-NIBBLE));Number of unboxed Q's (half num instructions)(SIZE NIL);Total number of Q's(FEF NIL);FEF being created(OBJ NIL)(TEM NIL)(OFFSET NIL)(%INHIBIT-READ-ONLY T))       (PROGN;     (SETQ FASL-GROUP-LENGTH (+ Q-COUNT (LSH UNBOXED-COUNT 1)));We could calculate FEF length instead of storing it      (SETQ FASL-GROUP-LENGTH (FASL-NEXT-NIBBLE));Fixnum specifying length of the FEF      (SETQ FEF (%ALLOCATE-AND-INITIALIZE;Create the FEF  DTP-FUNCTION;Data-type of returned pointer  (IF EXPLORER-P DTP-FEF-HEADER DTP-HEADER)  (FASL-NEXT-VALUE)        ;Header (1st word of FEF)  (SETQ SIZE (+ Q-COUNT UNBOXED-COUNT));FEF storage length (total number of Q's)  (AREF FASL-TABLE FASL-FRAME-AREA);Area in which to allocate  SIZE))        ;Amount to allocate      (SETQ TEM (FASL-NEXT-NIBBLE))      ;; Store FORM and SUBST flags as cdr-code.  Note that the compiler formats modifier      ;; nibbles for all Q words by shifting 6 bits.      (%P-STORE-CDR-CODE FEF (LSH TEM -6))              (BIND (LOCF (AREF FASL-TABLE FASL-LIST-AREA));Create lists, strings, & vectors that are FEF constants in    MACRO-COMPILED-PROGRAM)        ;a read-only area.      (BIND (LOCF (AREF FASL-TABLE FASL-STRING-AREA))    MACRO-COMPILED-PROGRAM)      (BIND (LOCF (AREF FASL-TABLE FASL-ARRAY-AREA))    MACRO-COMPILED-PROGRAM)      (DO ((I 1 (1+ I)))  ((>= I Q-COUNT) NIL);Fill in other BOXED Q's - FEF header already done ;; OBJ gets the object to be stored.(COND ((= I 2);Word 2 now always points to debugging information       ;; Read the FEF's debug-info-structure and documentation string into a special area.       ;; Ensure that lists in the debug-info are also put in this area.       (LET () (BIND (LOCF (AREF FASL-TABLE FASL-LIST-AREA))       DEBUG-INFO-AREA) (BIND (LOCF (AREF FASL-TABLE FASL-STRING-AREA))       DEBUG-INFO-AREA) (BIND (LOCF (AREF FASL-TABLE FASL-ARRAY-AREA))       DEBUG-INFO-AREA) (SETQ OBJ (FASL-NEXT-VALUE)))       ;; See if any macros that were used in this FEF       ;; have changed their sxhashes since the FEF was compiled.       (LET ((TEM (GETF (DBIS-PLIST OBJ) :MACROS-EXPANDED)));Debug-info is a structure for VM2 (IF TEM     (CHECK-MACROS-EXPANDED TEM (FUNCTION-NAME FEF)))))      ;; Read everything except the debug-info-structure.      (T (SETQ OBJ (FASL-NEXT-VALUE))))(SETQ TEM (FASL-NEXT-NIBBLE))        ;Get cdr-code(OR (ZEROP (SETQ OFFSET (LOGAND 17 TEM)));Add offset if necessary    (SETQ OBJ (%MAKE-POINTER-OFFSET DTP-LOCATIVE OBJ OFFSET)))(%P-STORE-CONTENTS-OFFSET OBJ FEF I);Store it(%P-STORE-CDR-CODE-OFFSET (LSH TEM -6) FEF I);Store cdr-code;; GRH(%P-DPB-OFFSET (LSH TEM -6) %%Q-CDR-CODE FEF I);Store cdr-code(AND (LOGTEST 20 TEM)        ;Make into EXTERNAL-VALUE-CELL-POINTER     (%P-STORE-DATA-TYPE-OFFSET       DTP-EXTERNAL-VALUE-CELL-POINTER FEF I));; GRH         (%P-DPB-OFFSET DTP-EXTERNAL-VALUE-CELL-POINTER;;    %%Q-DATA-TYPE FEF I))(AND (LOGTEST 400 TEM)         ;Make into LOCATIVE     (%P-STORE-DATA-TYPE-OFFSET DTP-LOCATIVE FEF I));; GRH     (%P-DPB-OFFSET DTP-LOCATIVE %%Q-DATA-TYPE FEF I))(AND (LOGTEST 1000 TEM)     (%P-STORE-DATA-TYPE-OFFSET DTP-SELF-REF-POINTER FEF I))) );; GRH     (%P-DPB-OFFSET DTP-SELF-REF-POINTER %%Q-DATA-TYPE FEF I))) )       (DO ((I Q-COUNT (1+ I)))        ;Now store unboxed Q's((>= I SIZE))      (%P-DPB-OFFSET (FASL-NEXT-NIBBLE)        ;Store in low-order halfword     %%Q-LOW-HALF FEF I)      (%P-DPB-OFFSET (FASL-NEXT-NIBBLE)        ;Then high-order halfword     %%Q-HIGH-HALF FEF I))    ;; Check self-mapping table bit and convert indirect addressing used for instance variables    ;; in machine instructions to direct addressing if the bit is set.    (UNLESS (ZEROP (%P-LDB %%Fef-Header-Self-Mapping-Table FEF))      (FEF-CONVERT-ADDRESSES FEF))    (ENTER-FASL-TABLE FEF)));;; Used to be called DISASSEMBLE-FETCH and EH:FEF-INSTRUCTION.;;;  4/10/86 JK  - Removed FEF-INSTRUCTION.  It is now in "sys:compiler;mindefs" because it;;;                is used by the disassembler, which may be present without the loader.;(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 (COND ((ZEROP (LOGAND 1 PC));%%Q-LOW-HALF);       (T %%Q-HIGH-HALF)); FEF; (TRUNCATE PC 2)))(DEFUN FASL-OP-FUNCTION-HEADER ()  (PROG (FCTN F-SXH)(SETQ FCTN (FASL-NEXT-VALUE))(SETQ F-SXH (FASL-NEXT-VALUE))(RETURN 0)))(DEFUN FASL-OP-FUNCTION-END ()0)(DEFUN FASL-OP-STOREIN-SYMBOL-CELL ()  (let ((CELL (FASL-NEXT-NIBBLE))(DATA (FASL-NEXT-VALUE))(SYM (FASL-NEXT-VALUE)))    (CASE CELL      (1 (SET SYM DATA) (WHEN PRINT-LOADED-FORMS (PRINT `(SETQ ,SYM ',DATA))) (IF ACCUMULATE-FASL-FORMS     (PUSH `(SETQ ,SYM ',DATA) LAST-FASL-FILE-FORMS)))      (2 (FSET SYM DATA) (WHEN PRINT-LOADED-FORMS (PRINT `(FSET ',SYM ',DATA))) (IF ACCUMULATE-FASL-FORMS     (PUSH `(FSET ',SYM ',DATA) LAST-FASL-FILE-FORMS)));      (3 (SETF (SYMBOL-PLIST SYM) DATA) ; (WHEN PRINT-LOADED-FORMS (PRINT `(SETPLIST ,SYM ',DATA))); (IF ACCUMULATE-FASL-FORMS;     (PUSH `(SETPLIST ',SYM ',DATA) LAST-FASL-FILE-FORMS)))      (3 (SETF (SYMBOL-PLIST SYM) DATA)  (WHEN PRINT-LOADED-FORMS (PRINT `(SETf (symbol-PLIST ,SYM) ',DATA))) (IF ACCUMULATE-FASL-FORMS     (PUSH `(SETf (symbol-PLIST ',SYM) ',DATA) LAST-FASL-FILE-FORMS))))    0))(DEFUN FASL-OP-STOREIN-SYMBOL-VALUE ()   (let ((DATA (AREF FASL-TABLE (FASL-NEXT-NIBBLE)))(SYM (FASL-NEXT-VALUE)))    (SET SYM DATA)    (PUSH `(SETQ ,SYM ',DATA) FASL-FILE-EVALUATIONS)    (WHEN PRINT-LOADED-FORMS      (PRINT (CAR FASL-FILE-EVALUATIONS)))    (AND ACCUMULATE-FASL-FORMS (PUSH (CAR FASL-FILE-EVALUATIONS)       LAST-FASL-FILE-FORMS))    0))(DEFUN FASL-OP-STOREIN-FUNCTION-CELL ()  (LET ((DATA (AREF FASL-TABLE (FASL-NEXT-NIBBLE)))(SYM (FASL-NEXT-VALUE)))    (FDEFINE SYM DATA T)    (WHEN PRINT-LOADED-FORMS      (PRINT `(FSET ',SYM ',DATA)))    (AND ACCUMULATE-FASL-FORMS (PUSH `(FSET ',SYM ',DATA)       LAST-FASL-FILE-FORMS))    0))(DEFUN FASL-OP-STOREIN-PROPERTY-CELL ()  (let ((DATA (AREF FASL-TABLE (FASL-NEXT-NIBBLE)))(sym  (FASL-NEXT-VALUE)))    (SETF (SYMBOL-PLIST SYM ) DATA)    (PUSH `(SETF (SYMBOL-PLIST ',SYM) ',DATA) FASL-FILE-EVALUATIONS)    (WHEN PRINT-LOADED-FORMS      (PRINT (CAR FASL-FILE-EVALUATIONS)))    (AND ACCUMULATE-FASL-FORMS (PUSH (CAR FASL-FILE-EVALUATIONS)       LAST-FASL-FILE-FORMS))    0))(DEFUN FASL-OP-STOREIN-ARRAY-LEADER ()   (let((ARRAY (AREF FASL-TABLE (FASL-NEXT-NIBBLE)))(SUBSCR (AREF FASL-TABLE (FASL-NEXT-NIBBLE)))(VALUE (AREF FASL-TABLE (FASL-NEXT-NIBBLE))))     (STORE-ARRAY-LEADER VALUE ARRAY SUBSCR)      0))(DEFUN FASL-OP-FETCH-SYMBOL-VALUE ()  (ENTER-FASL-TABLE (SYMBOL-VALUE (FASL-NEXT-VALUE)))) ;; fasl-next-value returns a symbol(DEFUN FASL-OP-FETCH-FUNCTION-CELL ()  (ENTER-FASL-TABLE (CAR (FUNCTION-CELL-LOCATION (Fasl-Next-Value)))))   (DEFUN FASL-OP-FETCH-PROPERTY-CELL ()  (ENTER-FASL-TABLE (CAR (PROPERTY-CELL-LOCATION (Fasl-Next-Value)))))(DEFUN FASL-OP-APPLY ()  (let* ((COUNT (FASL-NEXT-NIBBLE)) (FCTN (FASL-NEXT-VALUE)) (v) (p (VALUE-CELL-LOCATION V)))    (do ((c count (1- c)))((zerop c) (AND ACCUMULATE-FASL-FORMS      (PUSH `(APPLY ',FCTN ',V)    LAST-FASL-FILE-FORMS));(WHEN PRINT-LOADED-FORMS;  (PRINT `(APPLY ',FCTN ',V))) (PUSH `(,FCTN) FASL-FILE-EVALUATIONS) (FASL-STORE-EVALED-VALUE (APPLY FCTN V)))            (RPLACD P (SETQ P (CONS-IN-AREA (FASL-NEXT-VALUE)      NIL      (AREF FASL-TABLE     FASL-TEMP-LIST-AREA)))))))(DEFUN FASL-OP-END-OF-WHACK ()  (setf (fill-pointer fasl-table) fasl-table-working-offset)  (SETQ FASL-RETURN-FLAG 'END-OF-WHACK)  0)(DEFUN FASL-OP-END-OF-FILE ()  (SETQ FASL-RETURN-FLAG 'EOF)  0)(Defun Fasl-Op-Soak ()  (do ((count (Fasl-next-Nibble) (1- Count)))      ((zerop Count) (Fasl-Next-Value))    (Fasl-Next-Value)))(DEFUN FASL-OP-SET-PARAMETER ()  (Let ((TO (FASL-NEXT-VALUE))(FROM (FASL-GROUP)))    (SETF (AREF FASL-TABLE(*EVAL TO))  (AREF FASL-TABLE FROM))    0))(DEFUN FASL-APPEND (OUTFILE &REST INFILES)  "Concatenate the contents of XLD files INFILES into one XLD file named OUTFILE."  (LET* ((FILE-TYPE (LET ((INPATH (FS:PARSE-PATHNAME (FIRST INFILES))))                      (OR (SEND INPATH :CANONICAL-TYPE)  (LOCAL-BINARY-FILE-TYPE)))) (OUTPATH (FS:MERGE-PATHNAME-DEFAULTS OUTFILE FS:LOAD-PATHNAME-DEFAULTS         FILE-TYPE)))    (WITH-OPEN-FILE (OSTREAM OUTPATH :CHARACTERS NIL :DIRECTION :OUTPUT)      (DO ((FILES INFILES (CDR FILES)))  ((NULL FILES))(WITH-OPEN-FILE (ISTREAM (FS:MERGE-PATHNAME-DEFAULTS   (CAR FILES) FS:LOAD-PATHNAME-DEFAULTS FILE-TYPE) :CHARACTERS NIL :DIRECTION :INPUT)  ;; Skip first two nibbles of all but the first file.  (UNLESS (EQ FILES INFILES)    (FUNCALL ISTREAM :TYI)    (FUNCALL ISTREAM :TYI))  (DO ((NIBBLE (FUNCALL ISTREAM :TYI))       (NEXT1 (FUNCALL ISTREAM :TYI))       (NEXT2))      ((NULL NIBBLE))    (SETQ NEXT2 (FUNCALL ISTREAM :TYI))    (AND (OR NEXT2     (AND NEXT1 (NOT (ZEROP NEXT1)))     (AND (NULL (CDR FILES))        ;Skip the last nonzero nibble of all files except the last.      (NOT (ZEROP NIBBLE)))) (SEND OSTREAM :TYO NIBBLE))    (SETQ NIBBLE NEXT1  NEXT1 NEXT2))))      OUTPATH)))gth LE-Structure))     (+ (Get-disk-Fixnum LE-