LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760030336. :SYSTEM-TYPE :LOGICAL :VERSION 50. :TYPE "LISP" :NAME "FASD" :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 2758302449. :AUTHOR "REL3" :LENGTH-IN-BYTES 52821. :LENGTH-IN-BLOCKS 52. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              ;;;  -*- Mode:Common-Lisp; Package:COMPILER2; Base:8 -*-;;;                           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.;;;;;; 09/19/84 DNG - Updated functions FASD-FONT and FASD-ATTRIBUTES-LIST;;;                from MIT patch 98.50.;;; 12/08/84 DNG - Support XFASL file type for Explorer.;;; 12/14/84 DNG - Modify FASD-FONT for XFASL files; modify FASD-ATTRIBUTE-LIST;;;                to fix m-X Fasl Update.;;;  2/16/85 DNG - New function CONVERT-FASL-DATA.;;;  3/07/85 DNG - Comment out obsolete functions FASD-SET-PARAMETER and FASD-TABLE-SET.;;;  3/09/85 DNG - Record :MODE attribute in DUMP-FORMS-TO-FILE; avoid using SETQ;;;                for FASD-SYMBOL-VALUE so Common Lisp evaluator won't complain;;;                about variable not declared special.;;;  4/08/85 DNG - Fix to not crash when dumping FEF with new Explorer header.;;;  6/26/85 DNG - Minor modifications to improve speed.;;; 12/10/85 JK  - Change FASD-SYMBOL to dump uninterned symbols correctly.;;;  1/21/86 DNG - Update CONVERT-FASL-DATA to handle ".XLD" files.;;;  2/01/86 DNG - Moved the DEFVARs to file DEFS because they are referenced in;;;   files FILE and LAP.;;;  2/12/86 JK  - Change to handle dumping certain types of recursive data structures. ;;;  3/03/86 JK  - Fix so that REcompiling files involving package operations such as;;;                IMPORT will not cause the operations to be ignored.;;;  3/14/86 JK  - Converted to Common Lisp.;;;  3/31/86 JK  - Speedups to FASD-ARRAY for certain numeric arrays.;;;  4/03/86 JK  - Added improved method for dumping symbol references.;;;  7/17/86 JK  - Removed compiler optimizations from FASD-TABLE-LOOKUP & FASD-TABLE-ADD;;;                since hash-tables are no longer flavors in VM2.  This prevents the;;;                cross-compiler from generating code that "funcalls" the hash-table.;;;  8/01/86 JK  - Change FASD-ARRAY to use FASL-GROUP-FLAG to indicate whether array was dumped in new format.;;;  8/28/86 JK  - Add support for dumping IEEE floating point numbers.;;;  9/03/86 JK  - Change PACKAGE-PREFIX-TO-DUMP & FASD-SYMBOL so the cross-compiler knows about;;;                the VM2 package structure.;;;  9/22/86 JK  - Change FASD-ATTRIBUTES-LIST to call the function on the FILE-ATTRIBUTE-BINDINGS ;;;                property of :PACKAGE since FIND-PACKAGE will not handle lists that are specifications;;;                of how to create packages under VM2.;;; 10/06/86 DNG - New variable FASD-TARGET to enable it to be bound while;;;   generating data files even when TARGET-PROCESSOR is constant.;;; 10/17/86 JK  - Change FASD-CONSTANT to use %DATA-TYPE, which compiles to a DISPATCH;;;                instruction under version 10 of the VM2 compiler.;;; 11/17/86 DNG - Update FASD-FONT to record :FONT-SYMBOL file attribute.;;;   Use new functions %P-CDR-CODE-OFFSET, %P-DATA-TYPE-OFFSET, and %P-POINTER-OFFSET.;;; 12/05/86 JK  - When dumping a dangerous package operation, purge the FASD-HASH-TABLE of any ;;;                symbols affected by such operations so that a subsequent reference to an affected ;;;                symbol will not use indexing to the symbol in the FASL-TABLE [SPR#2743].  ;;;  2/04/87 DNG - Enable inline expansion of FASD-NIBBLE.;;;  2/20/87 DNG - Fix FASD-ARRAY to never load in QCOMPILE-TEMPORARY-AREA.;;;  This file used to be "sys:sys;qcfasd.lisp".(DEFVAR FASD-SYMBOL-LIST) (DEFVAR FASD-ALREADY-DUMPED-SYMBOL-LIST)(DEFVAR FASD-NEW-SYMBOL-FUNCTION);;; T for the first cross-compile and NIL thereafter.(DEFVAR *initial-cross-compile* T)(DEFVAR FASD-TARGET HOST-PROCESSOR "The processor for which an object file is being written.")(WHEN-SUPPORTING-CROSS-COMPILATION  (FORWARD-VALUE-CELL 'FASD-TARGET 'TARGET-PROCESSOR))(PROCLAIM '(TRY-INLINE FASD-NIBBLE));so interpreted definition is saved(DEFUN FASD-NIBBLE (NUMBER)  (IF (NULL (VECTOR-PUSH NUMBER FASD-TYO-BUFFER-ARRAY))    (PROGN      (FASD-CLEAR-NIBBLE-BUFFER)      (VECTOR-PUSH NUMBER FASD-TYO-BUFFER-ARRAY)))) (DEFUN FASD-CLEAR-NIBBLE-BUFFER ()  (SEND FASD-STREAM :STRING-OUT FASD-TYO-BUFFER-ARRAY)  (STORE-ARRAY-LEADER 0 FASD-TYO-BUFFER-ARRAY 0));;; Output the things that divide a fasl file into its major subparts.;;; Outputs magic numbers used to validate a fasl file.;;; Also clears out the temp area.(DEFUN FASD-START-FILE ()  (LET ((X (ASSOC (TARGET-BINARY-FILE-TYPE FASD-TARGET)  SI::VALIDATE-BINARY-FILE :TEST #'EQ)))    ;; Write out the pair of magic numbers used by the loader    ;; to check for a valid file format.    (FASD-NIBBLE (SECOND X))    (FASD-NIBBLE (THIRD X)))) (DEFUN FASD-START-GROUP (FLAG LENGTH TYPE)  (PROG ((OUT-LEN (LSH (COND ((>= LENGTH 377) 377) (T LENGTH))       (- FASL-GROUP-LENGTH-SHIFT))))    (LOCALLY (DECLARE (INLINE FASD-NIBBLE))       (FASD-NIBBLE(+ %FASL-GROUP-CHECK (+ (COND  (FLAG %FASL-GROUP-FLAG)  (T 0))(+ OUT-LEN TYPE)))))    (AND (>= LENGTH 377) (FASD-NIBBLE LENGTH))))(DEFUN FASD-FUNCTION-HEADER (FCTN-NAME)  (BLOCK ()    (FASD-START-GROUP NIL 0 FASL-OP-FUNCTION-HEADER)    (FASD-CONSTANT FCTN-NAME)    (FASD-CONSTANT '0))  NIL)(DEFUN FASD-FUNCTION-END ()  (BLOCK ()    (FASD-START-GROUP NIL 0 FASL-OP-FUNCTION-END))  NIL)(DEFUN FASD-END-WHACK ()  (FASD-START-GROUP NIL 0 FASL-OP-END-OF-WHACK)  ;; Reset fasd table, but not temporary areas  (CLRHASH FASD-HASH-TABLE)  (CLRHASH FASD-EVAL-HASH-TABLE)  (SETQ FASD-TABLE-CURRENT-INDEX FASL-TABLE-WORKING-OFFSET)) (DEFUN FASD-END-FILE NIL  (BLOCK ()    (FASD-START-GROUP NIL 0 FASL-OP-END-OF-FILE)    (FASD-CLEAR-NIBBLE-BUFFER))  NIL);;; Given an s-exp, dump a group to cons up that s-exp and return it.;;; This is the main function of FASD.  It takes a Lisp object and;;; dumps it.  The second (optional) arg is a FASL-OP to use on;;; any lists in the structure.  It returns the IDX of the object.;;;  8/28/86 JK - Add support for dumping IEEE floating point numbers.;;; 10/17/86 JK - Change FASD-CONSTANT to use %DATA-TYPE, which compiles to a DISPATCH;;;               instruction under version 10 of the VM2 compiler.;;; 10/18/86 DNG- Give meaningful message when flavor instance can't be dumped.(DEFUN FASD-CONSTANT (S-EXP &OPTIONAL (LIST-OP #+Elroy       FASL-OP-VM2-LIST       #-Elroy       FASL-OP-LIST))  (PROG (TEM)(AND FASD-NEW-SYMBOL-FUNCTION        ;For FASD-SYMBOLS-PROPERTIES, make sure we examine all      (= (%data-type s-exp) dtp-symbol)        ;symbols in the data that we dump.     (FUNCALL FASD-NEW-SYMBOL-FUNCTION S-EXP))(when (SETQ TEM (FASD-TABLE-LOOKUP S-EXP))        ;If this object already dumped,  (COND ((>= TEM (LSH 1 20)) (FASD-START-GROUP NIL 2 FASL-OP-LARGE-INDEX) (FASD-NIBBLE (LDB (BYTE 10 20) TEM)) (FASD-NIBBLE (LDB (BYTE 20 0) TEM)))(T (FASD-START-GROUP NIL 1 FASL-OP-INDEX)        ;Just reference it in the FASL-TABLE. (FASD-NIBBLE TEM)))  (RETURN TEM))(select (%data-type s-exp)  (dtp-fix (FASD-FIXED S-EXP))  (dtp-character (FASD-CHARACTER S-EXP))  (dtp-symbol (FASD-SYMBOL S-EXP))  (si:dtp-array (if (stringp s-exp)    (RETURN (FASD-STRING S-EXP))    (RETURN (FASD-ARRAY S-EXP))))  (#+Elroy si:dtp-function #-Elroy dtp-fef-pointer (FASD-FEF S-EXP));remove SI prefix when we compile natively -JK  #+Elroy  (si:dtp-short-float (FASD-IEEE-SHORT-FLOAT S-EXP))  #+Elroy  (dtp-single-float (FASD-IEEE-SINGLE-FLOAT S-EXP));Modify current float data-types for VM2  (dtp-extended-number (cond #+Elroy ((TYPEP S-EXP 'DOUBLE-FLOAT)  (FASD-IEEE-DOUBLE-FLOAT S-EXP));Add new double-float data-type for VM2 ((integerp s-exp)  (FASD-FIXED S-EXP)) ((RATIONALP S-EXP)  (RETURN (FASD-RATIONAL S-EXP))) ((COMPLEXP S-EXP)  (RETURN (FASD-COMPLEX S-EXP)))))  #-Elroy  (dtp-small-flonum (FASD-SMALL-FLOAT S-EXP))  #-Elroy  (dtp-single-float (FASD-FLOAT S-EXP))  (#+Elroy si:dtp-function #-Elroy dtp-fef-pointer (FASD-FEF S-EXP))  (dtp-list (RETURN (FASD-LIST S-EXP LIST-OP)))  (dtp-instance (FASD-EVAL-CONSTRUCT-CONSTANT  (OR (SEND S-EXP :SEND-IF-HANDLES :FASD-FORM)      (AND (SEND S-EXP :OPERATION-HANDLED-P :RECONSTRUCTION-INIT-PLIST)   `(APPLY #'MAKE-INSTANCE   '(,(TYPE-OF S-EXP) . ,(SEND S-EXP :RECONSTRUCTION-INIT-PLIST))))      (FERROR NIL "Can't dump instance ~S to object file because it doesn't have a :FASD-FORM or :RECONSTRUCTION-INIT-PLIST method." S-EXP)      )))  (otherwise (FERROR NIL "~S is a ~S, which is not a valid data-type for FASD-CONSTANT" S-EXP (TYPE-OF S-EXP))))(RETURN (FASD-TABLE-ADD S-EXP))))(DEFUN FASD-LIST (S-EXP LIST-OP)  ;; Determine the size of the list, and check for special markers  (DECLARE (INLINE FASD-NIBBLE))  (DO ((L S-EXP (CDR L))       (N-CONSES 0 (1+ N-CONSES))       (MARK)       (DOTTED))      ((OR (ATOM L)   (SETQ MARK (ASSOC (CAR L) FASD-MARKERS-ALIST :TEST #'EQ))   (AND FASD-MAGIC-AREAS-ALIST(SETQ MARK (ASSOC (%AREA-NUMBER L) FASD-MAGIC-AREAS-ALIST :TEST #'EQ))))       ;; Now dump that many conses and the tail if non-null       ;;  2/12/86 JK  - Change to handle dumping recursive lists.       #+Elroy       (COND ((ZEROP N-CONSES) (FUNCALL (CDR MARK) S-EXP))     (T (LET ((RETURN-VALUE;; FASL-OP-VM2-LIST-COMPONENT speeds things up by not bloating the fasl;; table with conses out of the middle of lists.(IF (= LIST-OP FASL-OP-VM2-LIST-COMPONENT)    FASL-EVALED-VALUE    (FASD-TABLE-ADD S-EXP))))  (SETQ DOTTED (NOT (NULL L)))  (FASD-START-GROUP DOTTED 1 LIST-OP)  (FASD-NIBBLE (IF DOTTED (1+ N-CONSES) N-CONSES))  (DO ((L1 S-EXP (CDR L1)))      ((EQ L1 L))    (FASD-CONSTANT (CAR L1) LIST-OP))  (COND ((NOT DOTTED))((NOT MARK) (FASD-CONSTANT L))(T (FUNCALL (CDR MARK) L)))  RETURN-VALUE)))       #-Elroy       (COND ((ZEROP N-CONSES) (FUNCALL (CDR MARK) S-EXP))     (T (SETQ DOTTED (NOT (NULL L)))(FASD-START-GROUP DOTTED 1 LIST-OP)(FASD-NIBBLE (IF DOTTED (1+ N-CONSES) N-CONSES))(DO ((L1 S-EXP (CDR L1)))    ((EQ L1 L))  (FASD-CONSTANT (CAR L1) LIST-OP))(COND ((NOT DOTTED))      ((NOT MARK) (FASD-CONSTANT L))      (T (FUNCALL (CDR MARK) L)));; FASL-OP-LIST-COMPONENT speeds things up by not bloating the fasl;; table with conses out of the middle of lists.(IF (= LIST-OP FASL-OP-LIST-COMPONENT)    FASL-EVALED-VALUE    (FASD-TABLE-ADD S-EXP))))))) (DEFUN FASD-EVAL-AT-LOAD-TIME (CONS)  (LET ((FORM (CDR CONS)))    (IF (AND (CONSP FORM)     (EQ (CAR FORM) 'SI:FLAVOR-VAR-SELF-REF-INDEX))(FASD-EVAL-MEMOIZED FORM T)      (FASD-EVAL1 FORM)))) (DEFUN FASD-FUNCTIONAL-CONSTANT (CONS)  (COND ((AND (CONSP (CADR CONS))      (FUNCTIONP (CADR CONS) T)) (IF (VARIABLE-BOUNDP COMPILER-QUEUE)     (FERROR NIL "Compiler is not recursive--you will lose somehow")) (QC-TRANSLATE-FUNCTION (IF (ATOM (CADADR CONS)) (CADADR CONS)    (CAR (CADADR CONS)))(CADR CONS)'MACRO-COMPILE'QFASL-NO-FDEFINE))(T (FASD-CONSTANT (CONS 'FUNCTION (CDR CONS))))))(DEFUN SET-UP-SYM-ENTRY (ht list-of-symbols package-prefix)  (DOLIST (sym list-of-symbols)    (LET ((name (SYMBOL-NAME sym)))      (SETF (GETHASH name ht) (CONS sym package-prefix)))));;; Ensure the latest version of each initial VM2 symbol list is loaded when cross-compiling.(defsubst MAYBE-LOAD-OR-UPDATE-VM2-SYMBOL-LISTS ()  (mapcar #'(lambda (pathname)      (let ((loaded-pathname-or-nil (car (si:get-file-loaded-id (fs:parse-pathname pathname) 'si))))(if loaded-pathname-or-nil    (unless (= (send loaded-pathname-or-nil :version)       (send (probe-file pathname) :version))      (load pathname))    (load pathname))))  '("kernel:baseline;initial-lisp-symbols.lisp"    "kernel:baseline;initial-ticl-symbols.lisp"    "kernel:baseline;initial-zlc-symbols.lisp"    "kernel:baseline;external-system-symbols.lisp")));;; The cross-compiler needs to know about the VM2 package structure.;;; A hash table for each major package (LISP, TICL, ZLC, and SYS) is;;; used when VM1 symbols are mapped to their VM2 locations.  A fifth;;; hash table handles other symbols demoted from GLOBAL.(DEFUN CREATE-MAJOR-PACKAGE-HASH-TABLES ()  (DECLARE (SPECIAL lispsym ticlsym zlcsym syssym unglobalizedsym    SI:*INITIAL-COMMON-LISP-SYMBOLS*    SI:*INITIAL-TICL-SYMBOLS*    SI:*INITIAL-ZLC-SYMBOLS*    SI:*EXTERNAL-SYSTEM-SYMBOLS*))  (MAYBE-LOAD-OR-UPDATE-VM2-SYMBOL-LISTS)  ;; Transform the initial symbols lists into hash tables for efficient lookup.  (IF (VARIABLE-BOUNDP LISPSYM)      (CLRHASH LISPSYM)      (SETQ LISPSYM (MAKE-HASH-TABLE :TEST #'EQUAL)))  (SET-UP-SYM-ENTRY LISPSYM SI:*INITIAL-COMMON-LISP-SYMBOLS* "LISP")  (IF (VARIABLE-BOUNDP TICLSYM)      (CLRHASH TICLSYM)      (SETQ TICLSYM (MAKE-HASH-TABLE :TEST #'EQUAL)))  (SET-UP-SYM-ENTRY TICLSYM SI:*INITIAL-TICL-SYMBOLS* "TICL")  (IF (VARIABLE-BOUNDP ZLCSYM)      (CLRHASH ZLCSYM)      (SETQ ZLCSYM (MAKE-HASH-TABLE :TEST #'EQUAL)))  (SET-UP-SYM-ENTRY ZLCSYM SI:*INITIAL-ZLC-SYMBOLS* "ZLC")  (IF (VARIABLE-BOUNDP SYSSYM)      (CLRHASH SYSSYM)      (SETQ SYSSYM (MAKE-HASH-TABLE :TEST #'EQUAL)))  (SET-UP-SYM-ENTRY SYSSYM SI:*EXTERNAL-SYSTEM-SYMBOLS* "SYS")  (IF (VARIABLE-BOUNDP UNGLOBALIZEDSYM)      (CLRHASH UNGLOBALIZEDSYM)      (SETQ UNGLOBALIZEDSYM (MAKE-HASH-TABLE :TEST #'EQUAL)))  ;; All symbols demoted from GLOBAL for VM2 either go to another major package or to TV.  (SET-UP-SYM-ENTRY UNGLOBALIZEDSYM    '(FONT-BLINKER-WIDTH FONT-CHAR-WIDTH FONT-LEFT-KERN-TABLE FONT-BASELINE FONT-RASTERS-PER-WORD FONT-NAME FONT-RASTER-WIDTH FONT-WORDS-PER-CHAR FONT-CHAR-WIDTH-TABLE FONT-RASTER-HEIGHT FONT-BLINKER-HEIGHT FONT-CHARS-EXIST-TABLE FONT-INDEXING-TABLE FONT-CHAR-HEIGHT) "TV"));;; Map an old-world (VM1) symbol to its new location in VM2.(DEFUN MAPSYM (symbol)  (DECLARE (SPECIAL lispsym ticlsym zlcsym syssym unglobalizedsym))  ;; Return a string representing the location of SYMBOL in VM2 if SYMBOL is  ;; assigned to one of the major packages (ie, "LISP", "TICL", "ZLC", or "SYS").  ;; IF SYMBOL was demoted from GLOBAL to a non-major package for VM2, return a string  ;; representing the new package name.  Otherwise, just return NIL.  (WHEN *initial-cross-compile*    (CREATE-MAJOR-PACKAGE-HASH-TABLES)    (setq *initial-cross-compile* nil))  (LET (conflicts)    (DOLIST (ht '(LISPSYM TICLSYM ZLCSYM SYSSYM UNGLOBALIZEDSYM))      (LET ((result (GETHASH (SYMBOL-NAME symbol) (SYMBOL-VALUE ht))))(WHEN result (PUSH result conflicts))))    (WHEN conflicts(DOLIST (entry conflicts (PROBLEM-SYMBOL-RESOLUTION symbol))  (WHEN (EQ (CAR entry) symbol)    (RETURN (CDR entry)))))));;; This kludge can disappear when it can be guaranteed that there can never be 2 different;;; symbols in the same package with the same pname in VM2.(DEFUN PROBLEM-SYMBOL-RESOLUTION (SYMBOL)                 (WHEN (MEMBER SYMBOL '(CLI:STRING-EQUAL CLI:STRING=) :TEST #'EQ)          "LISP"));; 3/3/86  JK  - Fix so that REcompiling files involving package operations such as;;               IMPORT will not cause the operations to be ignored.;; 4/3/86  JK  - Added improved method for dumping symbol references.;; 9/3/86  JK  - Change PACKAGE-PREFIX-TO-DUMP & FASD-SYMBOL so the cross-compiler knows about;;               the VM2 package structure.;;; This DEFSUBST is used only in FASD-SYMBOL.(DEFSUBST PACKAGE-PREFIX-TO-DUMP (SYMBOL &OPTIONAL (PKG *PACKAGE*))  (LET ((SYM-PKG (SYMBOL-PACKAGE SYMBOL)))    (IF (COMPILING-FOR-V2)#+Elroy;; Native compilation from VM2(COND ((NULL SYM-PKG)   (VALUES NIL T))  ((EQ SYM-PKG PKG-KEYWORD-PACKAGE)   (VALUES "" NIL))  ((EQ SYM-PKG SI:PKG-LISP-PACKAGE)   (VALUES 'LISP NIL))  ((EQ PKG SYM-PKG)   NIL);  ((AND PKG;        (MULTIPLE-VALUE-BIND (FOUNDSYM FOUNDP ACTUAL-PACKAGE);    (FIND-SYMBOL SYMBOL PKG);  ;;  SYMBOL is interned in a package ;  (AND FOUNDP;       (EQ FOUNDSYM SYMBOL);       (MEMBER ACTUAL-PACKAGE (PACKAGE-USE-LIST PKG) :TEST #'EQ))));   NIL)  (T   ;; SYMBOL is interned in a package other than PKG (and possibly PKG as well).   ;; Dump it with a prefix.  Note that even external symbols in used packages are dumped this way.   (VALUES SYM-PKG T)))#-Elroy;; Cross-compilation from VM1(COND ((NULL SYM-PKG)       (VALUES NIL T))      ((EQ SYM-PKG PKG-KEYWORD-PACKAGE)       (VALUES "" NIL))      (T       ;; Determine where the VM1 symbol lives in VM2.       (let ((package-prefix-string-or-nil (MAPSYM symbol)))   (COND ((STRINGP package-prefix-string-or-nil)  (IF (string= package-prefix-string-or-nil "LISP")      (VALUES 'LISP nil);FASD-SYMBOL treats LISP specially, so return a symbol as first value.      (VALUES package-prefix-string-or-nil t))) ;; Else package-prefix-string-or-nil is NIL, meaning SYMBOL is not in a major package in VM2. ((EQ pkg sym-pkg) nil)   ;No prefix needed here, since SYMBOL is interned in PKG (and nowhere else). (T   ;; SYMBOL is interned in a package other than PKG (and possibly PKG as well).  ;; Dump it with a prefix.  Note that even external symbols in used packages are dumped this way.  (VALUES SYM-PKG T))))));; Native compilation from VM1(COND ((NULL SYM-PKG)       (VALUES NIL T))      ((EQ SYM-PKG PKG-KEYWORD-PACKAGE)       (VALUES "" NIL))      ((EQ PKG SYM-PKG)       NIL);  ((AND PKG ;       (MULTIPLE-VALUE-BIND (FOUNDSYM FOUNDP ACTUAL-PACKAGE);    (FIND-SYMBOL SYMBOL PKG);  (AND FOUNDP;       (EQ FOUNDSYM SYMBOL);       (MEMBER ACTUAL-PACKAGE (PACKAGE-USE-LIST PKG) :TEST #'EQ))));   NIL)      (T       ;; SYMBOL is interned in a package other than PKG (and possibly PKG as well).       ;; Dump it with a prefix.  Note that even external symbols in used packages are dumped this way.       (VALUES SYM-PKG T))))))(DEFUN FASD-SYMBOL (SYM &AUX (STARTED-FLAG NIL))  (MULTIPLE-VALUE-BIND (PKG-OR-STRING SHARP-FLAG)            (PACKAGE-PREFIX-TO-DUMP SYM FASD-PACKAGE)        ;; Here if symbol should print with a prefix of any kind - dump FASL-OP-PACKAGE-SYMBOL    ;; For uninterned symbols, FASL-OP-PACKAGE-SYMBOL is also dumped so loader won't intern them (Release 3)    (IF (COMPILING-FOR-V2)(PROGN   (WHEN SHARP-FLAG    (SETQ STARTED-FLAG T)    (FASD-START-GROUP SHARP-FLAG 1 FASL-OP-PACKAGE-SYMBOL)    (IF PKG-OR-STRING(PROGN (FASD-NIBBLE;Always dump 2 since no local nicknames in VM2 packages - jk 2)       (FASD-CONSTANT (IF (STRINGP PKG-OR-STRING)     PKG-OR-STRING     (PACKAGE-PREFIX-PRINT-NAME PKG-OR-STRING))));Dump package prefix(PROGN  (FASD-NIBBLE 2)  (FASD-CONSTANT ""))));Dump "" for uninterned symbol  (IF STARTED-FLAG      (FASD-CONSTANT (STRING SYM));If there was a prefix            (FASD-WRITE-STRING SYM (COND       ((EQUAL PKG-OR-STRING "")FASL-OP-KEYWORD-SYMBOL);Handle KEYWORD package specially for speed       ((EQ PKG-OR-STRING 'LISP)FASL-OP-LISP-SYMBOL);Handle LISP package specially for speed       (T FASL-OP-SYMBOL)))));If no prefix is needed(PROGN   (WHEN PKG-OR-STRING    ;; Here if need a prefix of any kind.    (SETQ STARTED-FLAG T)    (FASD-START-GROUP SHARP-FLAG 1 FASL-OP-PACKAGE-SYMBOL)    ;; This nibble is 402 if should ignore local nicknames, else 2.    (FASD-NIBBLE      (IF (AND (NOT (STRINGP PKG-OR-STRING))       (ASSOC (PACKAGE-PREFIX-PRINT-NAME PKG-OR-STRING)      (DONT-OPTIMIZE (SI:PKG-REFNAME-ALIST *PACKAGE*)) :TEST #'EQUAL))  #o402 2))    (FASD-CONSTANT (IF (STRINGP PKG-OR-STRING)       PKG-OR-STRING       (PACKAGE-PREFIX-PRINT-NAME PKG-OR-STRING))))  (IF STARTED-FLAG      (FASD-CONSTANT (STRING SYM))                ;If there was a prefix      (FASD-WRITE-STRING SYM FASL-OP-SYMBOL))))));If no prefix is needed;;; This is expected to do the FASD-TABLE-ADD itself,;;; since FASD-ARRAY has to do so.(DEFUN FASD-STRING (STRING)  (IF (OR (ARRAY-HAS-LEADER-P STRING)  (> (ARRAY-TOTAL-SIZE STRING) (LSH 1 20)))    (FASD-ARRAY STRING)    (PROGN      (FASD-WRITE-STRING STRING FASL-OP-STRING)      (FASD-TABLE-ADD STRING)))) (DEFUN FASD-WRITE-STRING (OBJECT GROUP-TYPE &AUX STRING)  (DECLARE (INLINE FASD-NIBBLE))  (SETQ STRING (IF (STRINGP OBJECT) OBJECT (STRING OBJECT)))  (PROG (LENGTH (I 0) C0 C1)(SETQ LENGTH (ARRAY-ACTIVE-LENGTH STRING))(FASD-START-GROUP NIL (CEILING LENGTH 2) GROUP-TYPE)L(AND (>= I LENGTH) (RETURN NIL))(SETQ C0 (AREF STRING I)      C1 (COND ((= (1+ I) LENGTH) 200)       (T (AREF STRING (1+ I)))))(FASD-NIBBLE (+ (LSH C1 8.) C0))(SETQ I (+ I 2))(GO L)))(DEFUN FASD-FIXED (N) (DECLARE (INLINE FASD-NIBBLE)) (PROG (NMAG NLENGTH)(SETQ NMAG (ABS N)      NLENGTH (CEILING (HAULONG NMAG) 20))(FASD-START-GROUP (< N 0) NLENGTH FASL-OP-FIXED)(DO ((POS (* 20 (1- NLENGTH)) (- POS 20))     (C NLENGTH (1- C)))    ((ZEROP C))    (FASD-NIBBLE (LDB (+ (LSH POS 6) 20) NMAG)))))(DEFUN FASD-CHARACTER (N) (PROG (NMAG NLENGTH)(SETQ NMAG (ABS N)      NLENGTH (CEILING (HAULONG NMAG) 20))(FASD-START-GROUP (< N 0) NLENGTH FASL-OP-CHARACTER)(DO ((POS (* 20 (1- NLENGTH)) (- POS 20))     (C NLENGTH (1- C)))    ((ZEROP C))    (FASD-NIBBLE (LDB (+ (LSH POS 6) 20) NMAG)))));(DEFUN FASD-FIXED (N); (PROG ();(AND (BIGP N) (FERROR NIL "FASL-OP-FIXED doesn't win for bignums yet"));(FASD-START-GROUP (< N 0) 2 FASL-OP-FIXED);(AND (< N 0) (SETQ N (%24-BIT-DIFFERENCE 0 N))) ;Don't use ABS, see FASL-OP-FIXED;(FASD-NIBBLE (LOGAND (LSH N -20) 177777));(FASD-NIBBLE (LOGAND N 177777))))(DEFUN FASD-FLOAT (N)  (BLOCK ()    (FASD-START-GROUP NIL 3 FASL-OP-FLOAT)    (FASD-NIBBLE (%P-LDB-OFFSET (BYTE 13 10) N 0))    (FASD-NIBBLE (DPB (%P-LDB-OFFSET (BYTE 10 0) N 0) (BYTE 10 10) (%P-LDB-OFFSET (BYTE 10 20) N 1)))    (FASD-NIBBLE (%P-LDB-OFFSET (BYTE 20 0) N 1)))  NIL)(DEFUN FASD-SMALL-FLOAT (N)  (BLOCK ()    (SETQ N (%MAKE-POINTER DTP-FIX N));So that LDB's will work.    (FASD-START-GROUP T 2 FASL-OP-FLOAT)    (FASD-NIBBLE (LDB (BYTE 10 20) N))    (FASD-NIBBLE (LDB (BYTE 20 0) N)))  NIL);;;  8/28/86 JK - Add routines to dump IEEE floating point numbers.(defun fasd-ieee-double-float (n)  (block ()    (fasd-start-group nil 4 si:fasl-op-ieee-float)    (fasd-nibble (%p-ldb-offset #o2020 n 1))    (fasd-nibble (%p-ldb-offset #o0020 n 1))    (fasd-nibble (%p-ldb-offset #o2020 n 2))    (fasd-nibble (%p-ldb-offset #o0020 n 2)))  nil)(defun fasd-ieee-single-float (n)   (block ()     (fasd-start-group nil 2 si:fasl-op-ieee-float)     (fasd-nibble (%p-ldb-offset #o2020 n 1))     (fasd-nibble (%p-ldb-offset #o0020 n 1)))   nil)(defun fasd-ieee-short-float (n)   (block ()     (setq n (%make-pointer dtp-fix n));So that LDB's will work.     (fasd-start-group t 2 si:fasl-op-ieee-float)     (fasd-nibble (ldb #o2011 n))     (fasd-nibble (ldb #o0020 n)))   nil)(DEFUN FASD-RATIONAL (RAT)  (FASD-START-GROUP NIL 0 FASL-OP-RATIONAL)  (FASD-CONSTANT (NUMERATOR RAT))  (FASD-CONSTANT (DENOMINATOR RAT))  (FASD-TABLE-ADD RAT))(DEFUN FASD-COMPLEX (COMPLEX)  (FASD-START-GROUP NIL 0 FASL-OP-COMPLEX)  (FASD-CONSTANT (REALPART COMPLEX))  (FASD-CONSTANT (IMAGPART COMPLEX))  (FASD-TABLE-ADD COMPLEX))(DEFUN FASD-FEF (FEF &AUX Q-COUNT NON-Q-COUNT)  (UNLESS (EQ FASD-TARGET HOST-PROCESSOR)    (FERROR NIL "Can't dump a compiled function from ~A for ~A"    HOST-PROCESSOR FASD-TARGET) )  (SETQ Q-COUNT (%STRUCTURE-BOXED-SIZE FEF)NON-Q-COUNT (- (%STRUCTURE-TOTAL-SIZE FEF) Q-COUNT))  (FASD-START-GROUP NIL 3 (IF (= (SI:%P-DATA-TYPE-OFFSET FEF 0) DTP-HEADER)      ;; Then Cadr and Lambda header format      FASL-OP-FRAME      ;; Else new header for Explorer (Nov. 1984)      FASL-OP-FEF))  (FASD-NIBBLE Q-COUNT)  (FASD-NIBBLE NON-Q-COUNT)  (FASD-NIBBLE (+ Q-COUNT (LSH NON-Q-COUNT 1)))  (DO ((I 0 (1+ I)))      ((= I Q-COUNT))    (FASD-FEF-Q FEF I))  (DO ((I Q-COUNT (1+ I)))      ((= I (+ Q-COUNT NON-Q-COUNT)))    (FASD-NIBBLE (%P-LDB-OFFSET %%Q-LOW-HALF FEF I))    (FASD-NIBBLE (%P-LDB-OFFSET %%Q-HIGH-HALF FEF I)))  NIL)(DEFUN FASD-FEF-Q (FEF I &AUX DATTP PTR PTR1 OFFSET (TYPE 0))  ;;  4/02/85 DNG - Fix to not crash on Explorer using new FEF headers.  ;; 10/07/86 DNG - Removed obsolete use of %FEFHI-FCTN-NAME.    (SETQ DATTP (SI:%P-DATA-TYPE-OFFSET FEF I))    (SETQ TYPE (LSH (SI:%P-CDR-CODE-OFFSET FEF I) 6))    (COND ((OR (= DATTP DTP-EXTERNAL-VALUE-CELL-POINTER)       (= DATTP DTP-LOCATIVE))   (SETQ PTR1 (%P-CONTENTS-AS-LOCATIVE-OFFSET FEF I))   (SETQ PTR (%FIND-STRUCTURE-HEADER PTR1))   (SETQ OFFSET (%POINTER-DIFFERENCE PTR1 PTR))   (AND (> OFFSET 17)(FERROR NIL "#o~O is too great an offset into atom while fasdumping FEF ~S"       OFFSET FEF))   (FASD-CONSTANT PTR)   (AND (= DATTP DTP-EXTERNAL-VALUE-CELL-POINTER)(SETQ TYPE (+ TYPE 20)))   (AND (= DATTP DTP-LOCATIVE)(SETQ TYPE (+ TYPE 400)))   ;; LOW 4 BITS OF TYPE ARE OFFSET TO ADD TO POINTER TO MAKE IT POINT AT VALUE CELL, ETC.   (SETQ TYPE (+ TYPE OFFSET)))          ((= DATTP #+(Or Cadr Lambda) DTP-HEADER #+(Or Explorer Elroy) DTP-FEF-HEADER)           (FASD-CONSTANT (SI:%P-POINTER-OFFSET FEF I)))  ((= DATTP DTP-SELF-REF-POINTER)   (INCF TYPE 1000)   (MULTIPLE-VALUE-BIND (SYMBOL FLAG)       (SI:FLAVOR-DECODE-SELF-REF-POINTER (SI:FEF-FLAVOR-NAME FEF)  (SI:%P-POINTER-OFFSET FEF I))     (FASD-EVAL1 `(SI:FLAVOR-VAR-SELF-REF-INDEX    ',(IF FLAG  `(,(SI:FEF-FLAVOR-NAME FEF)    T ,SYMBOL)`(,(SI:FEF-FLAVOR-NAME FEF) ,SYMBOL))))))          (T (FASD-CONSTANT (%P-CONTENTS-OFFSET FEF I))))    (FASD-NIBBLE TYPE))(DEFUN FASD-INTERNALP (INTERNAL MAIN &AUX TEM)  MAIN  (AND (SYMBOLP INTERNAL)       (> (SETQ TEM (LENGTH INTERNAL)) 22)        (SETQ TEM (POSITION #\- (THE STRING (STRING INTERNAL)) :FROM-END T :END TEM :TEST #'CHAR-EQUAL))           (STRING-EQUAL INTERNAL "-INTERNAL-LAMBDA" (- TEM 20) 0 TEM)));;; Does its own FASD-TABLE adding since it has to be done in the middle;;; of this function, after the FASL-OP-ARRAY but before the initialization data.;(DEFUN FASD-ARRAY (ARRAY &AUX TYPE DIMENSIONS-LIST SIZE OBJECTIVE-P FAKE-ARRAY RETVAL NSP);  (SETQ TYPE (ARRAY-TYPE ARRAY);DIMENSIONS-LIST (ARRAY-DIMENSIONS ARRAY);NSP (NAMED-STRUCTURE-P ARRAY));  (SETQ SIZE (APPLY #'* DIMENSIONS-LIST);OBJECTIVE-P (NULL (CDR (ASSOC TYPE ARRAY-BITS-PER-ELEMENT :TEST #'EQ))));  (COND ((NOT OBJECTIVE-P); (LET ((EPQ (CDR (ASSOC TYPE ARRAY-ELEMENTS-PER-Q :TEST #'EQ))));   ;; In this case, number of halfwords;   (SETQ SIZE (IF (PLUSP EPQ) (CEILING (* SIZE 2) EPQ) (* SIZE 2 (- EPQ)))))));  (FASD-START-GROUP NIL 0 (COND (OBJECTIVE-P FASL-OP-INITIALIZE-ARRAY);(T FASL-OP-INITIALIZE-NUMERIC-ARRAY)));  (FASD-START-GROUP NSP 0 FASL-OP-ARRAY);  (FASD-CONSTANT NIL)       ;Area.  Don't lose on arrays in QCOMPILE-TEMPORARY-AREA.;  (FASD-CONSTANT TYPE)       ;Element-type;  (FASD-CONSTANT DIMENSIONS-LIST; (IF (COMPILING-FOR-V2);     FASL-OP-VM2-TEMP-LIST;     FASL-OP-TEMP-LIST))       ;Dimensions;  (FASD-CONSTANT NIL)       ;Displaced-P;  (FASD-CONSTANT       ;Leader;    (COND ((ARRAY-HAS-LEADER-P ARRAY);   (DO ((I 0 (1+ I));(LIST NIL);(LIM (ARRAY-LEADER-LENGTH ARRAY)));       ((>= I LIM) LIST);     (PUSH (ARRAY-LEADER ARRAY I) LIST)));  (T NIL));    (IF (COMPILING-FOR-V2);FASL-OP-VM2-TEMP-LIST;FASL-OP-TEMP-LIST));  (FASD-CONSTANT NIL)       ;Index-offset;  (AND NSP;       (FASD-CONSTANT T))       ;NAMED-STRUCTURE-P;  ;; Now that six values have been given, the group is over.;  (SETQ RETVAL (FASD-TABLE-ADD ARRAY));  ;; Next, continue to initialize the array.;  (FASD-CONSTANT SIZE);  (SETQ FAKE-ARRAY;(MAKE-ARRAY SIZE;    :ELEMENT-TYPE (COND (OBJECTIVE-P 'ART-Q) (T '(UNSIGNED-BYTE 20)));    :DISPLACED-TO ARRAY));  (COND (OBJECTIVE-P; (DO ((I 0 (1+ I)));     ((>= I SIZE) NIL);     (IF (LOCATION-BOUNDP (AP-1-FORCE ARRAY I)); (FASD-CONSTANT (AREF FAKE-ARRAY I)); (FASD-NIBBLE (+ %FASL-GROUP-CHECK FASL-OP-NULL-ARRAY-ELEMENT)))));(T; (DO ((I 0 (1+ I)));     ((>= I SIZE) NIL);     (FASD-NIBBLE (AREF FAKE-ARRAY I)))));  (RETURN-ARRAY (PROG1 FAKE-ARRAY (SETQ FAKE-ARRAY NIL)));  RETVAL);;;  3/31/86 JK  - Speedups to FASD-ARRAY for certain numeric arrays.(DEFSUBST FAST-SAVABLE-P (ARRAY)       (OR (MEMBER (ARRAY-TYPE ARRAY)   '(ART-16B ART-SINGLE-FLOAT ART-DOUBLE-FLOAT ART-HALF-FIX ART-FAT-STRING     ART-COMPLEX-DOUBLE-FLOAT ART-COMPLEX ART-COMPLEX-SINGLE-FLOAT ART-32B)   :TEST #'EQ)   (CASE (ARRAY-TYPE ARRAY)     (ART-1B (= 0 (REM (ARRAY-TOTAL-SIZE ARRAY) 16.)))     (ART-4B (= 0 (REM (ARRAY-TOTAL-SIZE ARRAY)  4.)))     (ART-8B (= 0 (REM (ARRAY-TOTAL-SIZE ARRAY)  2.)))     (ART-STRING (= 0 (REM (ARRAY-TOTAL-SIZE ARRAY) 2.))))));;; Does its own FASD-TABLE adding since it has to be done in the middle;;; of this function, after the FASL-OP-ARRAY but before the initialization data.;;;  3/31/86 JK  - Speedups to FASD-ARRAY for certain numeric arrays.;;;  8/1/86  JK  - Use FASL-GROUP-FLAG to indicate whether array was dumped in new format.;;;  2/20/87 DNG - Add special check to never load in QCOMPILE-TEMPORARY-AREA.(DEFUN FASD-ARRAY (ARRAY &AUX TYPE DIMENSIONS-LIST SIZE OBJECTIVE-P FAST-NUMERIC FAKE-ARRAY RETVAL NSP)  (SETQ TYPE (ARRAY-TYPE ARRAY)DIMENSIONS-LIST (ARRAY-DIMENSIONS ARRAY)NSP (NAMED-STRUCTURE-P ARRAY))  (SETQ SIZE (APPLY #'* DIMENSIONS-LIST)OBJECTIVE-P (NULL (CDR (ASSOC TYPE ARRAY-BITS-PER-ELEMENT :TEST #'EQ))))  (SETQ FAST-NUMERIC (AND (NOT OBJECTIVE-P) (FAST-SAVABLE-P ARRAY) T))  (COND ((NOT OBJECTIVE-P) (LET ((EPQ (CDR (ASSOC TYPE ARRAY-ELEMENTS-PER-Q :TEST #'EQ))))   ;; In this case, number of halfwords   (SETQ SIZE (IF (PLUSP EPQ) (CEILING (* SIZE 2) EPQ) (* SIZE 2 (- EPQ)))))))  (FASD-START-GROUP FAST-NUMERIC 0 (COND (OBJECTIVE-P FASL-OP-INITIALIZE-ARRAY);Group-flag indicates speedups on   (T FASL-OP-INITIALIZE-NUMERIC-ARRAY)))  (FASD-START-GROUP NSP 0 FASL-OP-ARRAY)  (FASD-CONSTANT (LET ((AREA (%AREA-NUMBER (%POINTER ARRAY))))   (UNLESS (OR (EQL AREA QCOMPILE-TEMPORARY-AREA)       (SI::AREA-TEMPORARY-P AREA))     (AREA-NAME AREA))));Area name unless the area is temporary  (FASD-CONSTANT TYPE);Element-type  (FASD-CONSTANT DIMENSIONS-LIST #+Elroy FASL-OP-VM2-TEMP-LIST #-Elroy FASL-OP-TEMP-LIST);Dimensions  (FASD-CONSTANT NIL);Displaced-P  (FASD-CONSTANT;Leader    (COND ((ARRAY-HAS-LEADER-P ARRAY)   (DO ((I 0 (1+ I))(LIST NIL)(LIM (ARRAY-LEADER-LENGTH ARRAY)))       ((>= I LIM) LIST)     (PUSH (ARRAY-LEADER ARRAY I) LIST)))  (T NIL))    #+Elroy    FASL-OP-VM2-TEMP-LIST    #-Elroy    FASL-OP-TEMP-LIST)  (FASD-CONSTANT NIL);Index-offset  (AND NSP       (FASD-CONSTANT T));NAMED-STRUCTURE-P  ;; Now that six values have been given, the group is over.  (SETQ RETVAL (FASD-TABLE-ADD ARRAY))  ;; Next, continue to initialize the array.  (COND     ((OR OBJECTIVE-P (NOT FAST-NUMERIC))     (FASD-CONSTANT SIZE)     (SETQ FAKE-ARRAY   (MAKE-ARRAY SIZE       :TYPE (COND (OBJECTIVE-P ART-Q) (T ART-16B));Use TYPE keyword so loader won't have to       :DISPLACED-TO ARRAY))                        ;distinguish whether array was dumped in VM1 or VM2     (IF OBJECTIVE-P (DO ((I 0 (1+ I)))     ((>= I SIZE) NIL)   (IF (LOCATION-BOUNDP (AP-1-FORCE ARRAY I))       (FASD-CONSTANT (AREF FAKE-ARRAY I))       (FASD-NIBBLE (+ %FASL-GROUP-CHECK FASL-OP-NULL-ARRAY-ELEMENT)))) (DO ((I 0 (1+ I)))     ((>= I SIZE) NIL)   (FASD-NIBBLE (AREF FAKE-ARRAY I)))))    (T     (FASD-CONSTANT FAST-NUMERIC);Dump in new format for extra fast loading     (LET* ((BITS-PER-CELL      (CASE (ARRAY-TYPE ARRAY)    (ART-1B 1.) (ART-4B 4.) (ART-8B 8.) (ART-STRING 8.) (ART-16B 16.)    (ART-SINGLE-FLOAT 32.) (ART-DOUBLE-FLOAT 64.) (ART-HALF-FIX 16.) (ART-FAT-STRING 16.)    (ART-COMPLEX-DOUBLE-FLOAT 128.) (ART-COMPLEX 64.) (ART-COMPLEX-SINGLE-FLOAT 64.) (ART-32B 32.)))    (16-BIT-LENGTH (/ (* (ARRAY-TOTAL-SIZE ARRAY) BITS-PER-CELL) 16.))    (OVERLAY-ARRAY (MAKE-ARRAY 16-BIT-LENGTH :ELEMENT-TYPE '(UNSIGNED-BYTE 20) :DISPLACED-TO ARRAY)))       (FASD-CONSTANT 16-BIT-LENGTH)       (FASD-CLEAR-NIBBLE-BUFFER)       (SEND FASD-STREAM :STRING-OUT OVERLAY-ARRAY 0 16-BIT-LENGTH))))  (RETURN-ARRAY (PROG1 FAKE-ARRAY (SETQ FAKE-ARRAY NIL)))  RETVAL);;; Low-level routines to dump groups to deposit things in various places#|(DEFUN FASD-SET-PARAMETER (PARAM VAL)  param val  (FORMAT t "The function FASD-SET-PARAMETER is probably obsolete, please send a bug report if you end up calling it.")  (break "FASD-SET-PARAMETER")  (comment     (PROG (C-VAL)  (COND ((NULL (SETQ C-VAL (ASSQ PARAM FASD-TABLE))) (FERROR NIL "~S is an unknown FASL parameter" PARAM)))  (COND ((EQUAL VAL (CDR C-VAL))(RETURN NIL)))  (FASD-START-GROUP NIL 0 FASL-OP-SET-PARAMETER)  (FASD-CONSTANT PARAM)  (FASD-CONSTANT VAL)  ))) |#(DEFUN FASD-STORE-ARRAY-LEADER (VALUE ARRAY SUBSCR)   (BLOCK ()(FASD-START-GROUP NIL 3 FASL-OP-STOREIN-ARRAY-LEADER)(FASD-NIBBLE ARRAY)(FASD-NIBBLE SUBSCR)(FASD-NIBBLE VALUE);NOTE nibbles not in same order as STORE-ARRAY-LEADER!(RETURN 0)))(DEFUN FASD-STORE-FUNCTION-CELL (SYM IDX);IDX is an index into the FASD-TABLE location   (BLOCK ()                ;containing the structure to be stored.(FASD-START-GROUP NIL 1 FASL-OP-STOREIN-FUNCTION-CELL)(FASD-NIBBLE IDX)(FASD-CONSTANT SYM)(RETURN 0)))(SETF (SYMBOL-FUNCTION 'FASD-STOREIN-FUNCTION-CELL) #'FASD-STORE-FUNCTION-CELL)(DEFUN FASD-STORE-VALUE-CELL (SYM IDX)   (BLOCK ()(FASD-START-GROUP NIL 1 FASL-OP-STOREIN-SYMBOL-VALUE)(FASD-NIBBLE IDX)(FASD-CONSTANT SYM)(RETURN 0)))(DEFUN FASD-STORE-PROPERTY-CELL (SYM IDX)   (BLOCK ()(FASD-START-GROUP NIL 1 FASL-OP-STOREIN-PROPERTY-CELL)(FASD-NIBBLE IDX)(FASD-CONSTANT SYM)(RETURN 0)))(DEFUN FASD-FILE-PROPERTY-LIST (PLIST)  (FASD-ATTRIBUTES-LIST PLIST NIL))(DEFUN FASD-ATTRIBUTES-LIST (PLIST &OPTIONAL (ADD-FASD-DATA T))  ;; Updated 9/19/84 by D.N.G. from MIT patch 98.50 dated 4/28/84  ;; 12/08/84 DNG - Call GET-SYSTEM-VERSION without argument to  ;;                let it default to the correct system name.  ;; 12/14/84 DNG - Change :NEW-DESTINATIONS to COMPILER:NEW-DESTINATIONS  ;;                to fix m-X Fasl Update.  ;;  9/22/86 JK  - Change to call the function on the FILE-ATTRIBUTE-BINDINGS property  ;;                of :PACKAGE since FIND-PACKAGE will not handle lists that are specifications  ;;                of how to create packages under VM2.  ;; 11/17/86 DNG - Remove NEW-DESTINATIONS attribute, which was for Cadr and Lambda.  (WHEN ADD-FASD-DATA    (MULTIPLE-VALUE-BIND (MAJOR MINOR)(SI:GET-SYSTEM-VERSION)      (SETQ PLIST (LIST* :FASD-DATA `(,USER-ID   ,SI:LOCAL-PRETTY-HOST-NAME   ,(TIME:GET-UNIVERSAL-TIME)   ,MAJOR ,MINOR   (#+LMI COMPILER:NEW-DESTINATIONS #+LMI T    :SITE ,(LONG-SITE-NAME))) PLIST))))  (LET ((P (GETF PLIST :PACKAGE)))    (AND P (SETQ FASD-PACKAGE (MULTIPLE-VALUE-BIND (IGNORE PKG-LIST)     (FUNCALL (GET :PACKAGE 'FS:FILE-ATTRIBUTE-BINDINGS) NIL NIL P)   (CAR PKG-LIST)))))  (FASD-START-GROUP NIL 0 FASL-OP-FILE-PROPERTY-LIST)  ;; Put package prefixes on everything in the plist since it will be loaded in  ;; the wrong package.  This way the symbols in the plist will always be loaded  ;; into exactly the same package they were dumped from, while the rest of the  ;; symbols in the file will be free to follow the usual rules for intern.  (LET ((FASD-PACKAGE NIL))    (FASD-CONSTANT PLIST)));;; The old way of doing eval (FASD-EVAL) unfortunately does not nest properly.  ;;; It  can not be used to load into a FEF, because the loader is expecting to see;;; a single next-value.  so this is the way it probably should have been done in;;; the first place..(DEFUN FASD-EVAL1 (SEXP &OPTIONAL TEMPORARY)  (BLOCK ()(FASD-START-GROUP NIL 0 FASL-OP-EVAL1)(FASD-CONSTANT SEXP       #+Elroy       (IF TEMPORARY FASL-OP-VM2-TEMP-LIST FASL-OP-VM2-LIST)       #-Elroy       (IF TEMPORARY FASL-OP-TEMP-LIST FASL-OP-LIST));(RETURN (FASD-TABLE-ADD FASD-TABLE-IGNORE))(RETURN (FASD-TABLE-NEXT-INDEX))))(DEFUN FASD-EVAL-CONSTRUCT-CONSTANT (SEXP)  "Fasdump a group to eval FORM, but let our caller record it in the FASD-TABLE.He will record the index we use under the object that FORMis supposed to reconstruct at load time."  (FASD-START-GROUP NIL 0 FASL-OP-EVAL1)  (FASD-CONSTANT SEXP))(DEFUN FASD-EVAL-MEMOIZED (FORM &OPTIONAL TEMPORARY &AUX TEM)  (COND ((SETQ TEM (FASD-EVAL-TABLE-LOOKUP FORM));If this object already dumped, (COND ((>= TEM (LSH 1 20))(FASD-START-GROUP NIL 2 FASL-OP-LARGE-INDEX)(FASD-NIBBLE (LDB (BYTE 10 20) TEM))(FASD-NIBBLE (LDB (BYTE 20 0) TEM)))       (T(FASD-START-GROUP NIL 1 FASL-OP-INDEX);Just reference it in(FASD-NIBBLE TEM)))          ;the FASL-TABLE. TEM)(T (LET ((INDEX (FASD-EVAL1 FORM TEMPORARY)))     (FASD-EVAL-TABLE-ADD FORM INDEX)     INDEX))))  ;;; Routines to manipulate the FASD-TABLE;;; FASD simulates keeping a table that looks just like the one FASLOAD will keep.;;; FASD uses it to refer back to atoms which have been seen before,;;; so that no atom need be interned twice.(defun fasd-table-next-index nil  (declare (optimize (speed 2) (safety 0)))  (prog1 fasd-table-current-index (setq fasd-table-current-index (1+ fasd-table-current-index))))(defun fasd-table-add (data)  (declare (inline fasd-table-next-index))  (let ((index (fasd-table-next-index)))    (puthash data index fasd-hash-table)    index))(defun fasd-table-lookup (data)  (cond ((numberp data) nil)(t (gethash data fasd-hash-table))));;; The EVAL hash table is used to record data constructed by evaluations at load time,;;; in case we want to reuse the data instead of computing them twice.(DEFUN FASD-EVAL-TABLE-LOOKUP (DATA)  (GETHASH DATA FASD-EVAL-HASH-TABLE)) (DEFUN FASD-EVAL-TABLE-ADD (DATA INDEX)  (SETF (GETHASH DATA FASD-EVAL-HASH-TABLE) INDEX));  (PUTHASH-EQUAL DATA INDEX FASD-EVAL-HASH-TABLE));Set one of the parameters at the front of the FASD-TABLE, as in;(FASD-TABLE-SET FASL-SYMBOL-STRING-AREA PN-STRING)#|(DEFUN FASD-TABLE-SET (PARAM DATA)  param data  (FORMAT t "The function FASD-TABLE-SET is probably obsolete, please send a bug report if you end up calling it.")  (break "FASD-TABLE-SET")  (comment    (AS-1 DATA FASD-TABLE PARAM))) |#(DEFUN FASD-TABLE-LENGTH ()  FASD-TABLE-CURRENT-INDEX)(DEFUN FASD-INITIALIZE ()  (OR QCOMPILE-TEMPORARY-AREA      (FERROR NIL "FASD-INITIALIZE must be called inside a COMPILER:LOCKING-RESOURCES."))  (SETQ FASD-NEW-SYMBOL-FUNCTION NIL)  (SETQ FASD-PACKAGE *PACKAGE*)  (SETQ FASD-TABLE-CURRENT-INDEX FASL-TABLE-WORKING-OFFSET)  (STORE-ARRAY-LEADER 0 FASD-TYO-BUFFER-ARRAY 0));Leader for filling;;; Dump forms to be evaluated.  Treat certain common types of forms;;; specially (eg, DEFUN and SETQ).;;; Dump a group to evaluate a given form and return its value.;;; If OPTIMIZE is set, SETQ and DEFUN are handled specially,;;; in a way appropriate for the top level of FASDUMP or QC-FILE.(DEFUN FASD-FORM (FORM &OPTIONAL OPTIMIZE &AUX FUNCTION)  "Put something to execute FORM into the XLD file being written.If OPTIMIZE is true, many common types of forms are handled specially,including SETQ, DEFF, DEFUN, etc.  In particular, (DEFUN FOO)is processed by dumping FOO's current function definition."   (COND ((OR (MEMBER FORM '(T NIL) :TEST #'EQ)      (STRINGP FORM)      (NUMBERP FORM))  (FASD-CONSTANT FORM)) ((SYMBOLP FORM) (FASD-SYMEVAL FORM)) ((ATOM FORM) (FASD-RANDOM-FORM FORM)) ((NOT (SYMBOLP (CAR FORM))) (FASD-RANDOM-FORM FORM)) ((EQ (SETQ FUNCTION (AND (FBOUNDP (CAR FORM)) (SYMBOL-FUNCTION (CAR FORM))))      #'QUOTE)  (FASD-CONSTANT (CADR FORM))) ((NOT OPTIMIZE)  (FASD-RANDOM-FORM FORM)) ((EQ FUNCTION #'SETQ)  (FASD-SETQ FORM)) ((EQ FUNCTION #'DEFF)  (FASD-STORE-FUNCTION-CELL (CADR FORM) (FASD-FORM (CADDR FORM))))         ((AND (EQ FUNCTION #'FDEFINE)               (CONSP (CADR FORM))               (EQ (CAADR FORM) 'QUOTE))          (FASD-STORE-FUNCTION-CELL (CADADR FORM) (FASD-FORM (CADDR FORM)))) ((EQ FUNCTION #'DEFUN)  (FASD-FUNCTION (CADR FORM) (FDEFINITION (SI:UNENCAPSULATE-FUNCTION-SPEC (CADR FORM))))) ((MEMBER (CAR FORM) '(SHADOW SHADOWING-IMPORT UNINTERN UNEXPORT) :TEST #'EQ)  (FASD-DANGEROUS-PACKAGE-OPERATION FORM)) ;; Does this happen?  It does not, for compilation of top-level DECLAREs. ;; Let's see if anyone misses it.  RELDMP has something similar.;         ((EQ FUNCTION #'DECLARE);          (MAPC (FUNCTION FASD-DECLARATION) (CDR FORM))) (T (FASD-RANDOM-FORM FORM)))) ;(DEFUN FASD-DECLARATION (DCL);    (AND (MEMQ (CAR DCL) '(SPECIAL UNSPECIAL :SPECIAL :UNSPECIAL));         (FASD-FORM DCL)));;; Dump something to eval some random form (which is the argument).(DEFUN FASD-RANDOM-FORM (FRM)    (FASD-EVAL1 FRM));;; Given the body of a DEFUN, dump stuff to perform it.(DEFUN FASD-FUNCTION (FUNCTION DEFINITION)  (FASD-STORE-FUNCTION-CELL FUNCTION (FASD-CONSTANT DEFINITION)));;; Given the body of a SETQ, dump stuff to perform it.(DEFUN FASD-SETQ (SETQ-FORM)  (DO ((PAIRS (CDR SETQ-FORM) (CDDR PAIRS)))      ((NULL PAIRS))    (CHECK-ARG PAIRS (ATOM (CAR PAIRS)) "a SETQ form")    (FASD-STORE-VALUE-CELL (CAR PAIRS) (FASD-FORM (CADR PAIRS)))));;; When dumping a dangerous package operation, purge the FASD-HASH-TABLE of any symbols ;;; affected by such operations so that a subsequent reference to an affected symbol will;;; not use indexing to the symbol in the FASL-TABLE.  This prevents various anomalies such ;;; as attempts to redefine a LISP function at load time after a SHADOW operation has been ;;; performed on that function name [SPR#2743].(defun fasd-dangerous-package-operation (form)  (let* ((symbols (cadr (cadr form))) (affected-symbols (if (listp symbols)       symbols       (list symbols)))(result (fasd-random-form form)))    (mapc #'(lambda (sym)      (remhash sym fasd-hash-table))  affected-symbols)    result))(DEFUN FASD-SYMEVAL (SEXP)  (BLOCK ()(FASD-START-GROUP NIL 0 FASL-OP-FETCH-SYMBOL-VALUE)(FASD-CONSTANT SEXP);(RETURN (FASD-TABLE-ADD FASD-TABLE-IGNORE))(RETURN (FASD-TABLE-NEXT-INDEX))))(DEFUN FASD-SYMBOL-VALUE (FILENAME SYMBOL &OPTIONAL FILE-ATTRIBUTE-PLIST)  "Write an XLD file named FILENAME containing SYMBOL's value.Loading the file will set the symbol back to the same value."  ;; 03/09/85 DNG - Set optimize flag for FASD-FORM to avoid evaluation  ;;                of SETQ form when the file is loaded so the Common Lisp  ;;                evaluator won't complain about the symbol not being  ;;                declared special.  ;; 10/06/86 DNG - Use FASD-TARGET instead of TARGET-PROCESSOR and allow it to  ;;    be specified by the pathname; return the truename of the file.  ;; 11/17/86 DNG - Add optional FILE-ATTRIBUTE-PLIST arg for use by FASD-FONT.  (LET* ((FASD-PACKAGE NIL) (OUTPATH (FS:MERGE-PATHNAME-DEFAULTS FILENAME FS:LOAD-PATHNAME-DEFAULTS      (TARGET-BINARY-FILE-TYPE FASD-TARGET))) (FASD-TARGET (PROCESSOR-TYPE-FOR-FILE OUTPATH)))    (WITH-OPEN-FILE      (FASD-STREAM OUTPATH   :CHARACTERS NIL :DIRECTION :OUTPUT :BYTE-SIZE 16.)      (LOCKING-RESOURCES(FASD-INITIALIZE)(FASD-START-FILE)(FASD-ATTRIBUTES-LIST (OR FILE-ATTRIBUTE-PLIST  '(:PACKAGE :USER)))(FASD-FORM `(SETQ ,SYMBOL ',(SYMBOL-VALUE SYMBOL)) T)(FASD-END-WHACK)(FASD-END-FILE))      (SEND FASD-STREAM :TRUENAME))))(DEFUN DUMP-FORMS-TO-FILE (FILENAME FORMS-LIST &OPTIONAL ATTRIBUTE-LIST)  "Write an XLD file named FILENAME which, when loaded, will execute the forms in FORMS-LIST.ATTRIBUTE-LIST is a file attribute list which controls, among other things,what package the file is dumped and loaded in (default is USER) and which modethe forms will be evaluated in (default is the current mode)."  ;; 03/09/85 DNG - Record the :MODE attribute in the file so when it is loaded,  ;;                the evaluation will be done in the same mode as when dumped.  ;; 10/06/86 DNG - Use FASD-TARGET instead of TARGET-PROCESSOR and allow it to  ;;be specified by the pathname; return the truename of the file.  (LET* ((OUTPATH (FS:MERGE-PATHNAME-DEFAULTS FILENAME FS:LOAD-PATHNAME-DEFAULTS      (TARGET-BINARY-FILE-TYPE FASD-TARGET))) (FASD-TARGET (PROCESSOR-TYPE-FOR-FILE OUTPATH)))    (WITH-OPEN-FILE      (FASD-STREAM OUTPATH   :CHARACTERS NIL :DIRECTION :OUTPUT :BYTE-SIZE 16.)      (LET ((FASD-PACKAGE NIL))(LOCKING-RESOURCES  (FASD-INITIALIZE)  (FASD-START-FILE)  (UNLESS (GETF ATTRIBUTE-LIST :MODE)    (SETQ ATTRIBUTE-LIST (LIST* :MODE (LISP-MODE) ATTRIBUTE-LIST)))  (FASD-ATTRIBUTES-LIST    (IF (GETF ATTRIBUTE-LIST :PACKAGE)ATTRIBUTE-LIST      (LIST* :PACKAGE :USER ATTRIBUTE-LIST)))  (DOLIST (FORM FORMS-LIST)    (IF (>= (FASD-TABLE-LENGTH) QC-FILE-WHACK-THRESHOLD)(FASD-END-WHACK))    (FASD-FORM FORM))  (FASD-END-WHACK) (FASD-END-FILE)))      (SEND FASD-STREAM :TRUENAME))))(DEFUN FASD-FONT (FONT-SYMBOL &OPTIONAL FILENAME)  "Write the font into an XLD file which defaults to SYS:FONTS;name-of-font.XLD."  ;; Updated 9/19/84 by D.N.G. from MIT patch 98.50 dated 4/28/84  ;; 10/6/86 DNG - Permit optional filename argument; return truename of file.  ;;11/17/86 DNG - Record :FONT-SYMBOL file attribute.  (LET ((TEM (SYMBOL-VALUE FONT-SYMBOL))TRUENAME)    (UNWIND-PROTECT(PROGN  (SETF (SYMBOL-VALUE FONT-SYMBOL) (TV::FONT-EVALUATE FONT-SYMBOL))  (SETQ TRUENAME(FASD-SYMBOL-VALUE (OR FILENAME       (FS:MAKE-PATHNAME :HOST "SYS" :DIRECTORY "FONTS" :NAME (SYMBOL-NAME FONT-SYMBOL)))   FONT-SYMBOL   `(:FONT-SYMBOL ,FONT-SYMBOL :PACKAGE :USER))))      (SETF (SYMBOL-VALUE FONT-SYMBOL) TEM))    TRUENAME))(DEFUN FASD-FILE-SYMBOLS-PROPERTIES (FILENAME SYMBOLS PROPERTIES     DUMP-VALUES-P DUMP-FUNCTIONS-P     NEW-SYMBOL-FUNCTION)  "Write an XLD file named FILENAME containing data on SYMBOLS.The data can include the symbols' values, function definitions, and properties.PROPERTIES is a list of which properties should be dumped.DUMP-VALUES-P says whether to dump their values.DUMP-FUNCTIONS-P says whether to dump their function definitions.NEW-SYMBOL-FUNCTION is a function to call whenever a new symbolnot previously seen is found in a value being dumped.  The functioncan cause the new symbol's data to be dumped like the specified symbols.When the NEW-SYMBOL-FUNCTION is called, FASD-SYMBOL-LIST will be a listof symbols waiting to be dumped, and FASD-ALREADY-DUMPED-SYMBOL-LIST alist of those already dumped.  To make a new symbol be dumped, push iton the former if it is not in either of those two."  ;; 10/06/86 DNG - Use FASD-TARGET instead of TARGET-PROCESSOR and allow it to  ;;    be specified by the pathname; return the truename of the file.  (LET* ((OUTPATH (FS:MERGE-PATHNAME-DEFAULTS FILENAME FS:LOAD-PATHNAME-DEFAULTS      (TARGET-BINARY-FILE-TYPE FASD-TARGET))) (FASD-TARGET (PROCESSOR-TYPE-FOR-FILE OUTPATH)))    (WITH-OPEN-FILE      (FASD-STREAM OUTPATH :CHARACTERS NIL :DIRECTION :OUTPUT :BYTE-SIZE 16.)      (LET ((FASD-PACKAGE NIL))(LOCKING-RESOURCES  (FASD-INITIALIZE)  (FASD-START-FILE)  (FASD-ATTRIBUTES-LIST '(:PACKAGE :USER))  (FASD-SYMBOLS-PROPERTIES SYMBOLS PROPERTIES DUMP-VALUES-P   DUMP-FUNCTIONS-P NEW-SYMBOL-FUNCTION)  (FASD-END-WHACK)  (FASD-END-FILE)))      (SEND FASD-STREAM :TRUENAME))));;; Take each symbol in SYMBOLS and do a FASD-SYMBOL-PROPERTIES on it.;;; The symbols already thus dumped are put on FASD-ALREADY-DUMPED-SYMBOL-LIST.;;; The NEW-SYMBOL-FUNCTION can add more symbols to FASD-SYMBOL-LIST;;; to cause them to be dumped as well.(DEFUN FASD-SYMBOLS-PROPERTIES (SYMBOLS PROPERTIES DUMP-VALUESDUMP-FUNCTIONS NEW-SYMBOL-FUNCTION)    (DO ((FASD-SYMBOL-LIST SYMBOLS) (FASD-ALREADY-DUMPED-SYMBOL-LIST) (SYMBOL))((NULL FASD-SYMBOL-LIST))(SETQ SYMBOL (CAR FASD-SYMBOL-LIST))(POP FASD-SYMBOL-LIST)(PUSH SYMBOL FASD-ALREADY-DUMPED-SYMBOL-LIST)(FASD-SYMBOL-PROPERTIES SYMBOL PROPERTIESDUMP-VALUES DUMP-FUNCTIONS NEW-SYMBOL-FUNCTION)));;; Dump into the FASD file the properties of SYMBOL in PROPERTIES,;;; and the value if DUMP-VALUES, and the function cell if DUMP-FUNCTIONS.;;; NEW-SYMBOL-FUNCTION will be called on appropriate symbols in the;;; structures which are dumped.(DEFUN FASD-SYMBOL-PROPERTIES (SYMBOL PROPERTIES DUMP-VALUES                                      DUMP-FUNCTIONS NEW-SYMBOL-FUNCTION &AUX TEM)(AND DUMP-VALUES             (BOUNDP SYMBOL)     (FASD-STORE-VALUE-CELL SYMBOL    (FASD-CONSTANT-TRACING-SYMBOLS (SYMBOL-VALUE SYMBOL)   NEW-SYMBOL-FUNCTION)))  (AND DUMP-FUNCTIONS             (FBOUNDP SYMBOL)     (FASD-STORE-FUNCTION-CELL SYMBOL       (FASD-CONSTANT-TRACING-SYMBOLS (SYMBOL-FUNCTION SYMBOL)       NEW-SYMBOL-FUNCTION)))(MAPC (FUNCTION (LAMBDA (PROP)  (AND (SETQ TEM (GET SYMBOL PROP));If this atom has this property,       (PROGN;dump a DEFPROP to be evalled. (FASD-START-GROUP NIL 0 FASL-OP-EVAL1) (PROGN   (FASD-START-GROUP NIL 1 #+Elroy FASL-OP-VM2-LIST #-Elroy FASL-OP-LIST)   (FASD-NIBBLE 4)      ;4 is the length of the DEFPROP form.   (FASD-CONSTANT 'DEFPROP);Don't use FASD-FORM, since we want to detect new symbols   (FASD-CONSTANT SYMBOL);in the value of the property.   (FASD-CONSTANT-TRACING-SYMBOLS TEM NEW-SYMBOL-FUNCTION)   (FASD-CONSTANT PROP)   (FASD-TABLE-NEXT-INDEX)) (FASD-TABLE-NEXT-INDEX)))))      PROPERTIES)) (DEFUN FASD-CONSTANT-TRACING-SYMBOLS (OBJECT FASD-NEW-SYMBOL-FUNCTION)    (FASD-CONSTANT OBJECT));;; Use this as the NEW-SYMBOL-FUNCTION, for nice results:;;; All the substructures of the structures being dumped are also dumped.(DEFUN FASD-SYMBOL-PUSH (SYMBOL)  (OR (MEMBER SYMBOL FASD-SYMBOL-LIST :TEST #'EQ)      (MEMBER SYMBOL FASD-ALREADY-DUMPED-SYMBOL-LIST :TEST #'EQ)      (PUSH SYMBOL FASD-SYMBOL-LIST))) (DEFUN CONVERT-FASL-DATA (INFILE &OPTIONAL OUTFILE)  "Convert a data file from one FASL type to another.  PossibleFASL types are XLD, XFASL, and QFASL.The output pathname defaults to XLD (unless INFILE is type XLD,in which case OUTFILE defaults to XFASL).There must not be any function definitions in the file; thisconverter doesn't check, but the loader will complain."  ;; 2/16/85 DNG - Original version.  ;; 1/21/86 DNG - Modify to handle ".XLD" files.  ;; 7/28/86 JK  - Additional changes to handle ".XLD" files. (LET* ((OLD-TYPE (LET ((INPATH (FS:PARSE-PATHNAME INFILE)))                      (OR (SEND INPATH :CANONICAL-TYPE)  :XFASL)))(OUTPATH (AND OUTFILE (PATHNAME OUTFILE)))(NEW-TYPE (OR (AND OUTPATH (SEND OUTPATH :CANONICAL-TYPE))       (IF (OR (EQ OLD-TYPE :XFASL)(EQ OLD-TYPE :QFASL))   :XLD :XFASL))))   (SETQ OUTPATH (SEND (FS:MERGE-PATHNAME-DEFAULTS (OR OUTPATH INFILE)    FS:LOAD-PATHNAME-DEFAULTS       NEW-TYPE):NEW-CANONICAL-TYPENEW-TYPE))  (WITH-OPEN-FILE (OSTREAM OUTPATH :CHARACTERS NIL :DIRECTION :OUTPUT)      (WITH-OPEN-FILE (ISTREAM (FS:MERGE-PATHNAME-DEFAULTS                                 INFILE FS:LOAD-PATHNAME-DEFAULTS OLD-TYPE)                               :CHARACTERS NIL :DIRECTION :INPUT :BYTE-SIZE 16.);; Read the first two nibbles containing the validation code.(SI:VALIDATE-BINARY-FILE ISTREAM NIL);; Write out the new validation code.(LET ((X (ASSOC NEW-TYPE SI::VALIDATE-BINARY-FILE :TEST #'EQ)))  (SEND OSTREAM :TYO (SECOND X))  (SEND OSTREAM :TYO (THIRD X)))         (DO ((NIBBLE (SEND ISTREAM :TYI))             (NEXT1 (SEND ISTREAM :TYI))             (NEXT2))            ((NULL NIBBLE))          (SETQ NEXT2 (SEND ISTREAM :TYI))          (AND (OR NEXT2                   (AND NEXT1 (NOT (ZEROP NEXT1)))   (NOT (ZEROP NIBBLE)))               (SEND OSTREAM :TYO NIBBLE))          (SETQ NIBBLE NEXT1                NEXT1 NEXT2)))    OUTPATH)))RY-AREA))      OBJECT    (SI:COPY-OBJECT-TREE OBJECT T)))(DEFUN BUILD-DEBUG-INFO (COMPILAND)  ;; Set up the debug info from the local declarations and other things.  ;; Note that the most frequently used information should be pushed last  ;; so it will be at the front of the list.  ;;  ;; 12/27/84 DNG - Save DEFUN-METHOD definitions on FILE-LOCAL-DECLARATIONS.  ;;  2/15/85 DNG - Remember function which redefines a