(FILECREATED "12-Oct-86 17:33:01" {ERIS}<LISPCORE>SOURCES>FASL.;7
 73816  

      changes to:  (FUNCTIONS FASL::TABLE-STATS FASL::DUMP-ARRAY FASL:VALUE-DUMPABLE-P 
                          FASL:DUMP-VALUE)

      previous date: " 6-Oct-86 23:44:41" {ERIS}<LISPCORE>SOURCES>FASL.;6)


(* "
Copyright (c) 1986 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT FASLCOMS)

(RPAQQ FASLCOMS
 
       [(COMS (* ;;; "Common definitions.")
              (DECLARE: EVAL@COMPILE EVAL@LOAD DONTCOPY (FILES (LOADCOMP)
                                                               LLCHAR))
              (FNS FASL::SO-THAT-THE-FILE-WILL-GET-COMPILED)
              (STRUCTURES FASL:FASL-ERROR FASL:UNIMPLEMENTED-OPCODE FASL:OBJECT-NOT-DUMPABLE 
                     FASL:UNEXPECTED-END-OF-BLOCK FASL:INCONSISTENT-TABLE)
              (EXPORT (VARIABLES FASL:SIGNATURE))
              (VARIABLES FASL::CHECK-TABLE-SIZE FASL::FASL-EXTENDED FASL::END-MARK 
                     FASL::VERSION-RANGE FASL:CURRENT-VERSION)
              (FUNCTIONS FASL::TABLE-STATS))
        (COMS (* ;;; "Dumper.")
              (STRUCTURES FASL::HANDLE)
              (VARIABLES FASL::DUMMY-HANDLE)
              (VARIABLES FASL::+SMALLEST-FOUR-BYTE-INTEGER+ FASL::+LARGEST-FOUR-BYTE-INTEGER+)
              (VARIABLES FASL::*GATHER-DUMPER-STATS* FASL::*TABLE-ATTEMPTS* FASL::*TABLE-HITS*)
              (FUNCTIONS FASL::RESET-DUMPER-STATS)
              (FUNCTIONS DOTTED-LIST-LENGTH FASL::STATE-CASE FAT-STRING-P FASL::REMEMBER 
                     FASL::ELEMENTS-IDENTICAL-P FASL::END-BLOCK FASL::END-TEXT FASL::WRITE-OP 
                     FASL::LOOKUP-VALUE FASL::SAVE-VALUE)
              (FUNCTIONS FASL::DUMP-VALUE-FETCH FASL::DUMP-CHARACTER FASL::DUMP-SYMBOL 
                     FASL::DUMP-LIST FASL::DUMP-SIMPLE-VECTOR FASL::DUMP-ARRAY-DESCRIPTOR 
                     FASL::DUMP-BIT-ARRAY FASL::DUMP-GENERAL-ARRAY FASL::DUMP-ARRAY 
                     FASL::WRITE-INTEGER-BYTES FASL::INTEGER-BYTE-LIST FASL::DUMP-RATIONAL 
                     FASL::DUMP-COMPLEX FASL::DUMP-INTEGER FASL::DUMP-PACKAGE FASL::DUMP-DCODE 
                     FASL::DUMP-STRING FASL::DUMP-FLOAT32)
              (FUNCTIONS FASL:OPEN-FASL-HANDLE FASL:WITH-OPEN-HANDLE FASL:BEGIN-TEXT FASL:BEGIN-BLOCK 
                     FASL:VALUE-DUMPABLE-P FASL:DUMP-VALUE FASL:DUMP-FUNCTION-DEF FASL:DUMP-FUNCALL 
                     FASL:DUMP-EVAL FASL:CLOSE-FASL-HANDLE))
        (COMS (* ;;; "Reader.")
              (DEFINE-TYPES FASL-OPS)
              (STRUCTURES FASL::OPTABLE)
              (* ;; "This shouldn't have to be in here, but defstruct isn't complete yet.")
              (OPTIMIZERS FASL::OPTABLE-VECTOR)
              (FUNCTIONS FASL:MAKE-OPTABLE FASL::FASL-END-OF-BLOCK FASL:DEFOP FASL:DEFRANGE 
                     FASL::ADD-OP-TRANSLATION FASL:OPCODE-SEQUENCE FASL::FASL-EXTENDED 
                     FASL::SETESCAPE FASL::UNIMPLEMENTED-OPCODE)
              (VARIABLES FASL:*DEFAULT-OPTABLE* FASL::*CURRENT-OPTABLE* 
                     FASL::INITIAL-VALUE-TABLE-SIZE FASL::VALUE-TABLE-INCREMENT FASL::*VALUE-TABLE* 
                     FASL::*BLOCK-LEVEL* FASL::DEBUG-READER FASL::DEBUG-STREAM)
              (FUNCTIONS FASL:WITH-OPTABLE FASL:PROCESS-FILE FASL:CHECK-VERSION FASL:PROCESS-SEGMENT 
                     FASL:READ-TEXT FASL:PROCESS-BLOCK FASL:SKIP-TEXT FASL:NEXT-VALUE FASL::DO-OP 
                     FASL::NEW-VALUE-TABLE FASL::CLEAR-TABLE FASL::STORE-VALUE FASL::FETCH-VALUE 
                     FASL::COLLECT-LIST)
              (FASL-OPS FASL:FASL-SHORT-INTEGER FASL:FASL-NIL FASL:FASL-T FASL:FASL-INTEGER 
                     FASL:FASL-LARGE-INTEGER FASL:FASL-RATIO FASL:FASL-COMPLEX FASL:FASL-VECTOR 
                     FASL:FASL-CREATE-ARRAY FASL:FASL-INITIALIZE-ARRAY FASL:FASL-INITIALIZE-BIT-ARRAY 
                     FASL:FASL-THIN-STRING FASL:FASL-FAT-STRING FASL:FASL-CHARACTER 
                     FASL:FASL-LISP-SYMBOL FASL:FASL-KEYWORD-SYMBOL FASL:FASL-FIND-PACKAGE 
                     FASL:FASL-SYMBOL-IN-PACKAGE FASL:FASL-LIST FASL:FASL-LIST* FASL:FASL-DCODE 
                     FASL:FASL-TABLE-STORE FASL:FASL-TABLE-FETCH FASL:FASL-VERIFY-TABLE-SIZE 
                     FASL:FASL-EVAL FASL:FASL-FLOAT32 FASL:FASL-SETF-SYMBOL-FUNCTION 
                     FASL:FASL-FUNCALL))
        (PROP FILETYPE FASL)
        (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                            (NLAML)
                                                                            (LAMA 
                                                             FASL::SO-THAT-THE-FILE-WILL-GET-COMPILED
                                                                                  ])



(* ;;; "Common definitions.")


(DECLARE: EVAL@COMPILE EVAL@LOAD DONTCOPY 
(FILESLOAD (LOADCOMP)
       LLCHAR)
)
(DEFINEQ

(FASL::SO-THAT-THE-FILE-WILL-GET-COMPILED

  (CL:LAMBDA NIL))
)
(DEFINE-CONDITION FASL:FASL-ERROR
 CL:ERROR)

(DEFINE-CONDITION FASL:UNIMPLEMENTED-OPCODE
 FASL:FASL-ERROR :REPORT (FORMAT T 
                                                                          "Unimplemented FASL op: ~S"
                                                                           (
                                                                     FASL:UNIMPLEMENTED-OPCODE-OPNAME
                                                                            CONDITION))
                                                  OPNAME)

(DEFINE-CONDITION FASL:OBJECT-NOT-DUMPABLE
 FASL:FASL-ERROR :REPORT (FORMAT T 
                                                                          "Object not dumpable:~&~S"
                                                                          (
                                                                      FASL:OBJECT-NOT-DUMPABLE-OBJECT
                                                                           CONDITION))
                                                 OBJECT)

(DEFINE-CONDITION FASL:UNEXPECTED-END-OF-BLOCK
 FASL:FASL-ERROR :REPORT (FORMAT T 
                                                                "Unexpected FASL-END-OF-BLOCK at ~D."
                                                                              (GETFILEPTR
                                                                               (
                                                                  FASL:UNEXPECTED-END-OF-BLOCK-STREAM
                                                                                CONDITION)))
                                                     STREAM)

(DEFINE-CONDITION FASL:INCONSISTENT-TABLE
 FASL:FASL-ERROR :REPORT (FORMAT T 
                                           "Inconsistent FASL table size.~&Expected ~D but found ~D."
                                                                         (
                                                                     FASL:INCONSISTENT-TABLE-EXPECTED
                                                                          CONDITION)
                                                                         (CL:LENGTH
                                                                          (FASL::OPTABLE-VECTOR
                                                                           (
                                                                        FASL:INCONSISTENT-TABLE-TABLE
                                                                            CONDITION))))
                                                TABLE EXPECTED)

(* FOLLOWING DEFINITIONS EXPORTED)


(DEFCONSTANT FASL:SIGNATURE
 145 "First byte of a FASL file.")



(* END EXPORTED DEFINITIONS)

(DEFVAR FASL::CHECK-TABLE-SIZE
 T)

(DEFCONSTANT FASL::FASL-EXTENDED
 254)

(DEFCONSTANT FASL::END-MARK
 255)

(DEFCONSTANT FASL::VERSION-RANGE
 (QUOTE (2 . 2)) 
                                      "Handles (car version-range) <= version <= (cdr version-range)"
   )

(DEFCONSTANT FASL:CURRENT-VERSION
 2)

(DEFUN FASL::TABLE-STATS
 (TABLE) (LET ((ITEMS (LIST (CONS (QUOTE --TOTAL--)
                                                          (CL:LENGTH TABLE)))))
                                      (DOTIMES (I (CL:LENGTH TABLE)
                                                  ITEMS)
                                             (LET* ((TYPE (TYPE-OF (AREF TABLE I)))
                                                    (PAIR (OR (CL:FIND TYPE ITEMS :TEST (QUOTE 
                                                                                             CL:EQUAL
                                                                                               )
                                                                     :KEY
                                                                     (QUOTE CAR))
                                                              (CAR (CL:PUSH (CONS TYPE 0)
                                                                          ITEMS)))))
                                                   (INCF (CDR PAIR))))))




(* ;;; "Dumper.")


(DEFSTRUCT (FASL::HANDLE
 (:CONSTRUCTOR FASL::MAKE-HANDLE)) STREAM (STATE :BLOCK-END)
                                                                 (LAST-INDEX 0)
                                                                 (HASH (MAKE-HASH-TABLE :TEST
                                                                              (CL:FUNCTION EQ
))))

(DEFCONSTANT FASL::DUMMY-HANDLE
 (FASL::MAKE-HANDLE :STREAM (OPEN "{null}" :DIRECTION :OUTPUT)
                                       :STATE :BLOCK :HASH NIL) )

(DEFCONSTANT FASL::+SMALLEST-FOUR-BYTE-INTEGER+
 (- (CL:EXPT 2 31)) )

(DEFCONSTANT FASL::+LARGEST-FOUR-BYTE-INTEGER+
 (1- (CL:EXPT 2 31)) )

(DEFVAR FASL::*GATHER-DUMPER-STATS*
 NIL)

(DEFVAR FASL::*TABLE-ATTEMPTS*
 0 "Number of table lookups by the FASL dumper.")

(DEFVAR FASL::*TABLE-HITS*
 0 "Number of successful table lookups by the FASL dumper.")

(DEFUN FASL::RESET-DUMPER-STATS
 NIL (CL:SETQ FASL::*TABLE-ATTEMPTS* 0 FASL::*TABLE-HITS* 0))

(DEFUN DOTTED-LIST-LENGTH
 (X) (CL:DO ((N 0 (+ N 2))
                                      (FAST X (CDDR FAST))
                                      (SLOW X (CDR SLOW)))
                                     (NIL)
                                     (COND
                                        ((NULL FAST)
                                         (RETURN N))
                                        ((CL:ATOM FAST)
                                         (RETURN (VALUES N T)))
                                        ((NULL (CDR FAST))
                                         (RETURN (1+ N)))
                                        ((CL:ATOM (CDR FAST))
                                         (RETURN (VALUES (1+ N)
                                                        T)))
                                        ((AND (EQ FAST SLOW)
                                              (> N 0))
                                         (RETURN NIL)))))

(DEFMACRO FASL::STATE-CASE
 (&REST CLAUSES) (BQUOTE (ECASE (FASL::HANDLE-STATE HANDLE)
                                                          (\,@ CLAUSES))))

(DEFUN FAT-STRING-P
 (STRING) (COND
                                ((STRINGP STRING)
                                 (EQ (fetch
 (STRINGP TYP) of
 STRING)
                                     \ST.POS16))
                                (T (%%FAT-STRING-ARRAY-P STRING))))

(DEFMACRO FASL::REMEMBER
 (VALUE &BODY BODY) (LET ((REMEMBER-VAL (GENSYM)))
                                                 (BQUOTE (LET (((\, REMEMBER-VAL)
                                                                (\, VALUE)))
                                                              (CL:WHEN REMEMBER (FASL::WRITE-OP
                                                                                 HANDLE
                                                                                 (QUOTE 
                                                                                FASL:FASL-TABLE-STORE
                                                                                        )))
                                                              (\,@ BODY)
                                                              (CL:WHEN REMEMBER (FASL::SAVE-VALUE
                                                                                 HANDLE
                                                                                 (\, REMEMBER-VAL))))
                                                        )))

(DEFUN FASL::ELEMENTS-IDENTICAL-P
 (ARRAY) (LET* ((SEQ (\FLATTEN-ARRAY ARRAY))
                                                 (TESTELT (AREF SEQ 0)))
                                                (CL:EVERY (CL:FUNCTION (CL:LAMBDA (X)
                                                                              (EQL X TESTELT)))
                                                       SEQ)))

(DEFUN FASL::END-BLOCK
 (HANDLE) (FASL::STATE-CASE (:BLOCK (CL:WHEN FASL::CHECK-TABLE-SIZE
                                                                 (FASL::WRITE-OP HANDLE (QUOTE 
                                                                          FASL:FASL-VERIFY-TABLE-SIZE
                                                                                               ))
                                                                 (FASL:DUMP-VALUE HANDLE (
                                                                              FASL::HANDLE-LAST-INDEX
                                                                                          HANDLE)
                                                                        NIL))
                                                         (BOUT (FASL::HANDLE-STREAM HANDLE)
                                                               FASL::END-MARK)
                                                         (SETF (FASL::HANDLE-LAST-INDEX HANDLE)
                                                               0)
                                                         (SETF (FASL::HANDLE-HASH HANDLE)
                                                               (MAKE-HASH-TABLE :TEST (CL:FUNCTION
                                                                                       EQ
)))
                                                         (SETF (FASL::HANDLE-STATE HANDLE)
                                                               :BLOCK-END))))

(DEFUN FASL::END-TEXT
 (HANDLE) (FASL::STATE-CASE (:TEXT (BOUT (FASL::HANDLE-STREAM HANDLE)
                                                              FASL::END-MARK)
                                                        (SETF (FASL::HANDLE-STATE HANDLE)
                                                              :BLOCK))))

(DEFUN FASL::WRITE-OP
 (HANDLE OPNAME) (FASL::STATE-CASE (:BLOCK (LET ((STREAM (FASL::HANDLE-STREAM
                                                                               HANDLE))
                                                                      (OPSEQ (FASL:OPCODE-SEQUENCE
                                                                              OPNAME)))
                                                                     (CL:IF (NULL OPSEQ)
                                                                            (CL:ERROR (QUOTE 
                                                                            FASL:UNIMPLEMENTED-OPCODE
                                                                                             )
                                                                                   :OPNAME OPNAME)
                                                                            (DOLIST (OP OPSEQ)
                                                                                   (BOUT STREAM OP)))
                                                                     ))))

(DEFUN FASL::LOOKUP-VALUE
 (HANDLE VALUE) (GETHASH VALUE (FASL::HANDLE-HASH HANDLE)))

(DEFUN FASL::SAVE-VALUE
 (HANDLE VALUE) (SETF (GETHASH VALUE (FASL::HANDLE-HASH HANDLE))
                                             (FASL::HANDLE-LAST-INDEX HANDLE))
                                       (INCF (FASL::HANDLE-LAST-INDEX HANDLE)))

(DEFUN FASL::DUMP-VALUE-FETCH
 (HANDLE INDEX) (FASL::WRITE-OP HANDLE (QUOTE FASL:FASL-TABLE-FETCH))
                                             (FASL:DUMP-VALUE HANDLE INDEX NIL))

(DEFUN FASL::DUMP-CHARACTER
 (HANDLE CHAR REMEMBER) (DECLARE
 (IGNORE REMEMBER))
                                                             (* "Characters don't get remembered.")

                                                   (LET ((CODE (CHAR-CODE CHAR))
                                                         (STREAM (FASL::HANDLE-STREAM HANDLE)))
                                                        (FASL::WRITE-OP HANDLE (QUOTE 
                                                                                  FASL:FASL-CHARACTER
                                                                                      ))
                                                        (CL:IF (< CODE 256)
                                                               (BOUT STREAM CODE)
                                                               (PROGN (BOUT STREAM 255)
                                                                      (BOUT16 STREAM CODE)))))

(DEFUN FASL::DUMP-SYMBOL
 (HANDLE SYMBOL REMEMBER) 
(* ;; 

                  "No point in remembering the pname because SYMBOL-NAME always gives you a new one.")

   (LET ((PNAME (SYMBOL-NAME SYMBOL))
         (PACKAGE (SYMBOL-PACKAGE SYMBOL)))
        (FASL::REMEMBER SYMBOL (COND
                                  ((KEYWORDP SYMBOL)
                                   (FASL::WRITE-OP HANDLE (QUOTE FASL:FASL-KEYWORD-SYMBOL))
                                   (FASL:DUMP-VALUE HANDLE PNAME NIL))
                                  ((STRING-EQUAL (PACKAGE-NAME PACKAGE)
                                          "lisp")
                                   (FASL::WRITE-OP HANDLE (QUOTE FASL:FASL-LISP-SYMBOL))
                                   (FASL:DUMP-VALUE HANDLE PNAME NIL))
                                  (T (FASL::WRITE-OP HANDLE (QUOTE FASL:FASL-SYMBOL-IN-PACKAGE))
                                     (FASL:DUMP-VALUE HANDLE PNAME NIL)
                                     (FASL:DUMP-VALUE HANDLE PACKAGE REMEMBER))))))

(DEFUN FASL::DUMP-LIST
 (HANDLE LIST REMEMBER) (MULTIPLE-VALUE-BIND (LENGTH DOTTED)
                                                     (DOTTED-LIST-LENGTH LIST)
                                                     (CL:UNLESS LENGTH (CL:ERROR (QUOTE 
                                                                             FASL:OBJECT-NOT-DUMPABLE
                                                                                        )
                                                                              :OBJECT LIST))
                                                     (FASL::REMEMBER LIST (FASL::WRITE-OP
                                                                           HANDLE
                                                                           (CL:IF DOTTED (QUOTE
                                                                                          
                                                                                      FASL:FASL-LIST*
                                                                                          )
                                                                                  (QUOTE 
                                                                                       FASL:FASL-LIST
                                                                                         )))
                                                            (FASL:DUMP-VALUE HANDLE
                                                                   (CL:IF DOTTED (1+ LENGTH)
                                                                          LENGTH)
                                                                   NIL)
                                                            (DOTIMES (I LENGTH)
                                                                   (FASL:DUMP-VALUE HANDLE
                                                                          (CAR LIST))
                                                                   (CL:POP LIST))
                                                            (CL:WHEN DOTTED (FASL:DUMP-VALUE HANDLE 
                                                                                   LIST NIL)))))

(DEFUN FASL::DUMP-SIMPLE-VECTOR
 (HANDLE VECTOR REMEMBER) (LET ((LENGTH (CL:LENGTH VECTOR)))
                                                              (FASL::REMEMBER
                                                               VECTOR
                                                               (FASL::WRITE-OP HANDLE (QUOTE 
                                                                                     FASL:FASL-VECTOR
                                                                                             ))
                                                               (FASL:DUMP-VALUE HANDLE LENGTH 
                                                                      REMEMBER)
                                                               (DOTIMES (I LENGTH)
                                                                      (FASL:DUMP-VALUE HANDLE
                                                                             (SVREF VECTOR I)
                                                                             REMEMBER)))))

(DEFUN FASL::DUMP-ARRAY-DESCRIPTOR
 (HANDLE ARRAY REMEMBER &KEY (INITIAL-ELEMENT NIL USE-SINGLE-ELT))
   (FASL::REMEMBER ARRAY (FASL::WRITE-OP HANDLE (QUOTE FASL:FASL-CREATE-ARRAY))
          (FASL:DUMP-VALUE HANDLE (CL:IF (EQL (ARRAY-RANK ARRAY)
                                              1)
                                         (CAR (ARRAY-DIMENSIONS ARRAY))
                                         (ARRAY-DIMENSIONS ARRAY))
                 REMEMBER)
          (FASL:DUMP-VALUE HANDLE (BQUOTE (:ELEMENT-TYPE
                                           (\, (ARRAY-ELEMENT-TYPE ARRAY))
                                           :ADJUSTABLE
                                           (\, (ADJUSTABLE-ARRAY-P ARRAY))
                                           (\,@ (CL:WHEN (ARRAY-HAS-FILL-POINTER-P ARRAY)
                                                       (BQUOTE (:FILL-POINTER (\, (FILL-POINTER
                                                                                   ARRAY))))))
                                           (\,@ (CL:WHEN USE-SINGLE-ELT (BQUOTE (:INITIAL-ELEMENT
                                                                                 (\, INITIAL-ELEMENT)
                                                                                 ))))))
                 REMEMBER)))

(DEFUN FASL::DUMP-BIT-ARRAY
 (HANDLE ARRAY REMEMBER) (LET ((NBITS (ARRAY-TOTAL-SIZE ARRAY)))
                                                         (CL:UNLESS (CL:ZEROP (\ARRAY-OFFSET ARRAY))
                                                                (CL:ERROR (QUOTE 
                                                                             FASL:OBJECT-NOT-DUMPABLE
                                                                                 )
                                                                       :OBJECT ARRAY))
                                                         (FASL::REMEMBER ARRAY (FASL::WRITE-OP
                                                                                HANDLE
                                                                                (QUOTE 
                                                                       FASL:FASL-INITIALIZE-BIT-ARRAY
                                                                                       ))
                                                                (FASL:DUMP-VALUE HANDLE NBITS 
                                                                       REMEMBER)
                                                                (FASL::DUMP-ARRAY-DESCRIPTOR HANDLE 
                                                                       ARRAY REMEMBER)
                                                                (\BOUTS (FASL::HANDLE-STREAM HANDLE)
                                                                       (\ARRAY-BASE ARRAY)
                                                                       0
                                                                       (CEILING NBITS 8)))))

(DEFUN FASL::DUMP-GENERAL-ARRAY
 (HANDLE ARRAY REMEMBER)      (* 

                                     "Arrays don't get remembered. Displacement information is lost.")

   (LET* ((NELTS (ARRAY-TOTAL-SIZE ARRAY))
          (ELT-TYPE (ARRAY-ELEMENT-TYPE ARRAY)))
         (FASL::WRITE-OP HANDLE (QUOTE FASL:FASL-INITIALIZE-ARRAY))
         (FASL::DUMP-ARRAY-DESCRIPTOR HANDLE ARRAY NIL)
         (FASL:DUMP-VALUE HANDLE NELTS NIL)
         (LET ((INDIRECT (MAKE-ARRAY NELTS :DISPLACED-TO ARRAY :ELEMENT-TYPE ELT-TYPE)))
              (DOTIMES (I NELTS)
                     (FASL:DUMP-VALUE HANDLE (AREF INDIRECT I)
                            NIL)))))

(DEFUN FASL::DUMP-ARRAY
 (HANDLE ARRAY REMEMBER) (COND
                                                   ((DISPLACED-ARRAY-P ARRAY)
                                                    (CL:ERROR (QUOTE FASL:OBJECT-NOT-DUMPABLE)
                                                           :OBJECT ARRAY))
                                                   ((ADJUSTABLE-ARRAY-P ARRAY)
                                                    (FASL::DUMP-GENERAL-ARRAY HANDLE ARRAY REMEMBER))
                                                   ((TYPEP ARRAY (QUOTE (CL:ARRAY BIT)))
                                                    (FASL::DUMP-BIT-ARRAY HANDLE ARRAY REMEMBER))
                                                   ((TYPEP ARRAY (QUOTE VECTOR))
                                                    (FASL::DUMP-SIMPLE-VECTOR HANDLE ARRAY REMEMBER))
                                                   (T (FASL::DUMP-GENERAL-ARRAY HANDLE ARRAY REMEMBER
                                                             ))))

(DEFUN FASL::WRITE-INTEGER-BYTES
 (HANDLE NBYTES VALUE) (LET ((STREAM (FASL::HANDLE-STREAM HANDLE)))
                                                            (DOLIST (BYTE (FASL::INTEGER-BYTE-LIST
                                                                           VALUE NBYTES))
                                                                   (BOUT STREAM BYTE))))

(DEFUN FASL::INTEGER-BYTE-LIST
 (VALUE NBYTES) (CL:DO ((COUNT
 0 (1+ COUNT))
                                                      (RESULT NIL)
                                                      (N VALUE)
                                                      BYTE)
                                                     ((>= COUNT NBYTES)
                                                      RESULT)
                                                     (MULTIPLE-VALUE-SETQ (N BYTE)
                                                            (CL:FLOOR N 256))
                                                     (CL:PUSH BYTE RESULT)))

(DEFUN FASL::DUMP-RATIONAL
 (HANDLE VALUE REMEMBER) (DECLARE
 (IGNORE REMEMBER))
                                                   (FASL::WRITE-OP HANDLE (QUOTE FASL:FASL-RATIO))
                                                   (FASL:DUMP-VALUE HANDLE (NUMERATOR VALUE)
                                                          NIL)
                                                   (FASL:DUMP-VALUE HANDLE (DENOMINATOR VALUE)
                                                          NIL))

(DEFUN FASL::DUMP-COMPLEX
 (HANDLE VALUE REMEMBER) (DECLARE
 (IGNORE REMEMBER))
                                                  (FASL::WRITE-OP HANDLE (QUOTE FASL:FASL-COMPLEX))
                                                  (FASL:DUMP-VALUE HANDLE (REALPART VALUE)
                                                         NIL)
                                                  (FASL:DUMP-VALUE HANDLE (IMAGPART VALUE)
                                                         NIL))

(DEFUN FASL::DUMP-INTEGER
 (HANDLE VALUE REMEMBER) (DECLARE
 (IGNORE REMEMBER))
                                                  (COND
                                                     ((AND (<= 0 VALUE)
                                                           (< VALUE 128))
                                                      (BOUT (FASL::HANDLE-STREAM HANDLE)
                                                            VALUE))
                                                     ((AND (<= FASL::+SMALLEST-FOUR-BYTE-INTEGER+ 
                                                            VALUE FASL::+LARGEST-FOUR-BYTE-INTEGER+))
                                                      (FASL::WRITE-OP HANDLE (QUOTE FASL:FASL-INTEGER
                                                                                    ))
                                                      (FASL::WRITE-INTEGER-BYTES HANDLE 4 VALUE))
                                                     (T (FASL::WRITE-OP HANDLE (QUOTE 
                                                                              FASL:FASL-LARGE-INTEGER
                                                                                      ))
                                                        (LET* ((MINBITS (1+ (INTEGER-LENGTH VALUE)))
                                                               (NBYTES (CEILING (INTEGER-LENGTH
                                                                                 VALUE)
                                                                              8)))
                                                             (* "According to the book, MINBITS gives the minimum field width for this number in 2's complement representation.")

                                                              (FASL:DUMP-VALUE HANDLE NBYTES NIL)
                                                              (FASL::WRITE-INTEGER-BYTES HANDLE 
                                                                     NBYTES VALUE)))))

(DEFUN FASL::DUMP-PACKAGE
 (HANDLE PACKAGE REMEMBER) (FASL::REMEMBER PACKAGE (FASL::WRITE-OP
                                                                             HANDLE
                                                                             (QUOTE 
                                                                               FASL:FASL-FIND-PACKAGE
                                                                                    ))
                                                           (FASL:DUMP-VALUE HANDLE (PACKAGE-NAME
                                                                                    PACKAGE)
                                                                  REMEMBER)))

(DEFUN FASL::DUMP-DCODE
 (HANDLE DCODE REMEMBER) 
  (* ;; 

                                             "DCODEs don't get remembered because they are never EQ.")

   (LET ((STREAM (FASL::HANDLE-STREAM HANDLE)))
        (MACROLET ((DUMP-SEQ (SEQ DUMP-LENGTH &REST STUFF)
                          (BQUOTE (LET ((SEQ (\, SEQ)))
                                       (\,@ (AND DUMP-LENGTH (QUOTE ((FASL:DUMP-VALUE HANDLE
                                                                            (CL:LENGTH SEQ)
                                                                            REMEMBER)))))
                                       (CL:IF (CL:LISTP SEQ)
                                              (DOLIST (ELT SEQ)
                                                     (\,@ STUFF))
                                              (DOTIMES (INDEX (CL:LENGTH SEQ))
                                                     (LET ((ELT (AREF SEQ INDEX)))
                                                          (\,@ STUFF))))))))
               (FASL::WRITE-OP HANDLE (QUOTE FASL:FASL-DCODE))
               (FASL:DUMP-VALUE HANDLE (CL:LENGTH (DCODE-NAME-TABLE DCODE))
                      REMEMBER)
               (LET* ((CODE-ARRAY (DCODE-CODE-ARRAY DCODE))
                      (NBYTES (CL:LENGTH CODE-ARRAY)))
                     (FASL:DUMP-VALUE HANDLE NBYTES REMEMBER)
                     (DOTIMES (I NBYTES)
                            (BOUT STREAM (AREF CODE-ARRAY I))))
               (DUMP-SEQ (DCODE-NAME-TABLE DCODE)
                      NIL
                      (BOUT STREAM (CL:FIRST ELT))
                      (FASL:DUMP-VALUE HANDLE (SECOND ELT)
                             REMEMBER)
                      (FASL:DUMP-VALUE HANDLE (THIRD ELT)
                             REMEMBER))
               (FASL:DUMP-VALUE HANDLE (DCODE-FRAME-NAME DCODE)
                      REMEMBER)
               (BOUT STREAM (DCODE-NLOCALS DCODE))
               (BOUT STREAM (DCODE-NFREEVARS DCODE))
               (BOUT STREAM (DCODE-ARG-TYPE DCODE))
               (FASL:DUMP-VALUE HANDLE (DCODE-NUM-ARGS DCODE)
                      REMEMBER)
               (FASL:DUMP-VALUE HANDLE (DCODE-CLOSURE-P DCODE)
                      REMEMBER)
               (FASL:DUMP-VALUE HANDLE (DCODE-DEBUGGING-INFO DCODE)
                      REMEMBER)
               (MACROLET ((DUMP-FIXUPS (LIST)
                                 (BQUOTE (DUMP-SEQ (\, LIST)
                                                T
                                                (FASL:DUMP-VALUE HANDLE (CL:FIRST ELT))
                                                (FASL:DUMP-VALUE HANDLE (SECOND ELT))))))
                      (DUMP-FIXUPS (DCODE-FN-FIXUPS DCODE))
                      (DUMP-FIXUPS (DCODE-SYM-FIXUPS DCODE))
                      (DUMP-FIXUPS (DCODE-LIT-FIXUPS DCODE))
                      (DUMP-FIXUPS (DCODE-TYPE-FIXUPS DCODE))))
        NIL))

(DEFUN FASL::DUMP-STRING
 (HANDLE STRING REMEMBER)
   (FASL::REMEMBER STRING (LET ((STREAM (FASL::HANDLE-STREAM HANDLE))
                                (NCHARS (CL:LENGTH STRING)))
                               (COND
                                  ((FAT-STRING-P STRING)
                                   (FASL::WRITE-OP HANDLE (QUOTE FASL:FASL-FAT-STRING))
                                   (FASL:DUMP-VALUE HANDLE NCHARS REMEMBER)
                                   (CL:DO ((I 0 (1+ I))
                                           (CSET 0))
                                          ((>= I NCHARS))    (* "Always run-encode")

                                          (LET* ((CHAR (CHAR-CODE (CHAR STRING I)))
                                                 (NEW-CSET (LRSH CHAR 8)))
                                                (CL:UNLESS (EQL NEW-CSET CSET)
                                                       (CL:SETQ CSET NEW-CSET)
                                                       (BOUT STREAM 255)
                                                       (BOUT STREAM CSET))
                                                (BOUT STREAM (LOGAND CHAR 255)))))
                                  (T (FASL::WRITE-OP HANDLE (QUOTE FASL:FASL-THIN-STRING))
                                     (FASL:DUMP-VALUE HANDLE NCHARS REMEMBER)
                                                             (* ;; "should use \bouts")

                                     (DOTIMES (I NCHARS)
                                            (BOUT STREAM (CHAR-CODE (CHAR STRING I)))))))))

(DEFUN FASL::DUMP-FLOAT32
 (HANDLE NUMBER REMEMBER)           (* "Floats don't get remembered")

   (FASL::WRITE-OP HANDLE (QUOTE FASL:FASL-FLOAT32))
   (\BOUTS (FASL::HANDLE-STREAM HANDLE)
          NUMBER 0 4))

(DEFUN FASL:OPEN-FASL-HANDLE
 (NAME &REST OPEN-OPTIONS) (LET ((STREAM (CL:APPLY (CL:FUNCTION OPEN)
                                                                            NAME :DIRECTION :OUTPUT 
                                                                            OPEN-OPTIONS)))
                                                            (SETFILEPTR STREAM 0)
                                                            (BOUT STREAM FASL:SIGNATURE)
                                                            (BOUT16 STREAM FASL:CURRENT-VERSION)
                                                            (FASL::MAKE-HANDLE :STREAM STREAM)))

(DEFMACRO FASL:WITH-OPEN-HANDLE
 ((HANDLE FILENAME &REST OPEN-OPTIONS)
                                 &BODY
                                 (BODY DECLS)) (LET ((ABORT (GENSYM "FASL:WITH-OPEN-FASL-HANDLE")))
                                                    (BQUOTE (LET (((\, HANDLE)
                                                                   (FASL:OPEN-FASL-HANDLE
                                                                    (\, FILENAME)
                                                                    (\,@ OPEN-OPTIONS)))
                                                                  ((\, ABORT)
                                                                   T))
                                                                 (\,@ DECLS)
                                                                 (UNWIND-PROTECT
                                                                  (MULTIPLE-VALUE-PROG1
                                                                   (PROGN (\,@ BODY))
                                                                   (SETQ (\, ABORT)
                                                                    NIL))
                                                                  (CL:WHEN (\, HANDLE)
                                                                         (FASL:CLOSE-FASL-HANDLE
                                                                          (\, HANDLE)
                                                                          :ABORT
                                                                          (\, ABORT))))))))

(DEFUN FASL:BEGIN-TEXT
 (HANDLE) (FASL::STATE-CASE ((:TEXT :BLOCK-END))
                                       (:BLOCK (FASL::END-BLOCK HANDLE)))
                                (SETF (FASL::HANDLE-STATE HANDLE)
                                      :TEXT)
                                (FASL::HANDLE-STREAM HANDLE))

(DEFUN FASL:BEGIN-BLOCK
 (HANDLE) (FASL::STATE-CASE (:BLOCK-END (FASL:BEGIN-TEXT HANDLE)
                                                          (FASL::END-TEXT HANDLE))
                                        (:TEXT (FASL::END-TEXT HANDLE))
                                        (:BLOCK)))

(DEFUN FASL:VALUE-DUMPABLE-P
 (OBJ) 
          
          (* (COND ((TYPEP OBJ (QUOTE (OR SYMBOL NUMBER CHARACTER PACKAGE DCODE 

          SIMPLE-STRING))) (VALUES T T)) ((TYPEP OBJ

          (QUOTE EVAL-AT-LOAD)) (FASL:VALUE-DUMPABLE-P

          (EVAL-AT-LOAD-FORM OBJ))) ((TYPEP OBJ (QUOTE

          (OR CONS SIMPLE-ARRAY))) (VALUES T NIL))

          ((TYPEP OBJ (QUOTE CL:ARRAY)) (CL:IF (ARRAY-DISPLACED-P OBJ)

          (VALUES NIL T) (VALUES T NIL))) (T (VALUES NIL T))))

 (CONDITION-CASE (PROGN (FASL:DUMP-VALUE FASL::DUMMY-HANDLE OBJ NIL)
                        T)
        (FASL:OBJECT-NOT-DUMPABLE NIL NIL)))

(DEFUN FASL:DUMP-VALUE
 (HANDLE VALUE &OPTIONAL (REMEMBER T)
                              &AUX INDEX) (FASL::STATE-CASE
                                           (:BLOCK (COND
                                                      ((EQ VALUE NIL)
                                                       (FASL::WRITE-OP HANDLE (QUOTE FASL:FASL-NIL)))
                                                      ((EQ VALUE T)
                                                       (FASL::WRITE-OP HANDLE (QUOTE FASL:FASL-T)))
                                                      ((PROG1 (CL:SETQ INDEX (FASL::LOOKUP-VALUE
                                                                              HANDLE VALUE))
                                                              (CL:WHEN FASL::*GATHER-DUMPER-STATS*
                                                                     (INCF FASL::*TABLE-ATTEMPTS*)))
                                                       (CL:WHEN FASL::*GATHER-DUMPER-STATS*
                                                              (INCF FASL::*TABLE-HITS*))
                                                       (FASL::DUMP-VALUE-FETCH HANDLE INDEX))
                                                      (T (TYPECASE VALUE (INTEGER (FASL::DUMP-INTEGER
                                                                                   HANDLE VALUE 
                                                                                   REMEMBER))
                                                                (RATIONAL (FASL::DUMP-RATIONAL HANDLE 
                                                                                 VALUE REMEMBER))
                                                                (SINGLE-FLOAT (FASL::DUMP-FLOAT32
                                                                               HANDLE VALUE REMEMBER)
                                                                       )
                                                                (COMPLEX (FASL::DUMP-COMPLEX HANDLE 
                                                                                VALUE REMEMBER))
                                                                (CHARACTER (FASL::DUMP-CHARACTER
                                                                            HANDLE VALUE REMEMBER))
                                                                (SYMBOL (FASL::DUMP-SYMBOL HANDLE 
                                                                               VALUE REMEMBER))
                                                                (PACKAGE (FASL::DUMP-PACKAGE HANDLE 
                                                                                VALUE REMEMBER))
                                                                (CONS (FASL::DUMP-LIST HANDLE VALUE 
                                                                             REMEMBER))
                                                                (DCODE (FASL::DUMP-DCODE HANDLE VALUE 
                                                                              REMEMBER))
                                                                (STRING (FASL::DUMP-STRING HANDLE 
                                                                               VALUE REMEMBER))
                                                                (CL:ARRAY (FASL::DUMP-ARRAY HANDLE 
                                                                                 VALUE REMEMBER))
                                                                (EVAL-WHEN-LOAD (FASL:DUMP-EVAL
                                                                                 HANDLE
                                                                                 (EVAL-WHEN-LOAD-FORM
                                                                                  VALUE)))
                                                                (OTHERWISE (CL:ERROR (QUOTE 
                                                                             FASL:OBJECT-NOT-DUMPABLE
                                                                                            )
                                                                                  :OBJECT VALUE))))))
                                           ))

(DEFUN FASL:DUMP-FUNCTION-DEF
 (HANDLE DCODE NAME) (FASL::STATE-CASE (:BLOCK (FASL::WRITE-OP
                                                                             HANDLE
                                                                             (QUOTE 
                                                                       FASL:FASL-SETF-SYMBOL-FUNCTION
                                                                                    ))
                                                                           (FASL:DUMP-VALUE HANDLE 
                                                                                  NAME)
                                                                           (FASL:DUMP-VALUE HANDLE 
                                                                                  DCODE))))

(DEFUN FASL:DUMP-FUNCALL
 (HANDLE FUNCTION) (FASL::STATE-CASE (:BLOCK (FASL::WRITE-OP HANDLE
                                                                            (QUOTE FASL:FASL-FUNCALL)
                                                                            )
                                                                    (FASL:DUMP-VALUE HANDLE FUNCTION)
                                                                    )))

(DEFUN FASL:DUMP-EVAL
 (HANDLE FORM) (FASL::STATE-CASE (:BLOCK (FASL::WRITE-OP HANDLE (QUOTE 
                                                                                       FASL:FASL-EVAL
                                                                                            ))
                                                             (FASL:DUMP-VALUE HANDLE FORM))))

(DEFUN FASL:CLOSE-FASL-HANDLE
 (HANDLE &REST CLOSE-OPTIONS &KEY ABORT &ALLOW-OTHER-KEYS)
   (FASL::STATE-CASE (:TEXT (FASL::END-TEXT HANDLE)
                            (FASL::END-BLOCK HANDLE))
          (:BLOCK (FASL::END-BLOCK HANDLE))
          (:BLOCK-END))
   (SETF (FASL::HANDLE-STATE HANDLE)
         :CLOSED)
   (CL:APPLY (CL:FUNCTION CLOSE)
          (FASL::HANDLE-STREAM HANDLE)
          CLOSE-OPTIONS))




(* ;;; "Reader.")


(DEF-DEFINE-TYPE FASL-OPS
 "FASL file opcodes" )

(DEFSTRUCT (FASL::OPTABLE
 (:CONSTRUCTOR FASL::NEW-OPTABLE)) VECTOR OPNAMES NEXT)




(* ;; "This shouldn't have to be in here, but defstruct isn't complete yet.")


(DEFOPTIMIZER FASL::OPTABLE-VECTOR
 (X) (BQUOTE (FETCH
 (FASL::OPTABLE VECTOR) OF
 (\, X))))

(DEFUN FASL:MAKE-OPTABLE
 NIL (LET ((TABLE (FASL::NEW-OPTABLE))
                                   (VECTOR (MAKE-ARRAY 256 :INITIAL-ELEMENT (QUOTE 
                                                                           FASL::UNIMPLEMENTED-OPCODE
                                                                                   ))))
                                  (SETF (FASL::OPTABLE-VECTOR TABLE)
                                        VECTOR)
                                  (SETF (SVREF VECTOR FASL::END-MARK)
                                        (QUOTE FASL::FASL-END-OF-BLOCK))
                                  TABLE))

(DEFUN FASL::FASL-END-OF-BLOCK
 (STREAM OP) (CL:IF (CL:ZEROP FASL::*BLOCK-LEVEL*)
                                                  (THROW (QUOTE FASL-BLOCK-FINISHED))
                                                  (CL:ERROR (QUOTE FASL:UNEXPECTED-END-OF-BLOCK)
                                                         :STREAM STREAM)))

(DEFDEFINER FASL:DEFOP
 FASL-OPS (NAME (OPCODE &KEY (INDIRECT 0)
                                             (TABLE (QUOTE FASL:*DEFAULT-OPTABLE*)))
                                      &BODY
                                      (BODY DECLS DOC))
                             (CL:IF (CL:ZEROP INDIRECT)
                                    (BQUOTE (PROGN (DEFUN (\,
 NAME) (STREAM OPCODE)
                                                      (\, (OR DOC "FASL opcode implementation"))
                                                      (\,@ DECLS)
                                                      (\,@ BODY))

                                                   (SETF (CL:ELT (FASL::OPTABLE-VECTOR (\, TABLE))
                                                                (\, OPCODE))
                                                         (QUOTE (\, NAME)))
                                                   (FASL::ADD-OP-TRANSLATION (QUOTE (\, NAME))
                                                          (\, OPCODE)
                                                          (\, TABLE))))
                                    (BQUOTE (PROGN (CL:UNLESS (FASL::OPTABLE-NEXT (\, TABLE))
                                                          (SETF (FASL::OPTABLE-NEXT (\, TABLE))
                                                                (FASL:MAKE-OPTABLE))
                                                          (FASL::SETESCAPE (\, TABLE)))
                                                   (FASL:DEFOP (\,
 NAME) ((\, OPCODE)
                                                                          :INDIRECT
                                                                          (\, (1- INDIRECT))
                                                                          :TABLE
                                                                          (FASL::OPTABLE-NEXT
                                                                           (\, TABLE)))
                                                      (\, (OR DOC "FASL opcode implementation"))
                                                      (\,@ DECLS)
                                                      (\,@ BODY))
))))

(DEFDEFINER FASL:DEFRANGE

   FASL-OPS (NAME (FIRST-OPCODE &KEY (INDIRECT 0)
                         (TABLE (QUOTE FASL:*DEFAULT-OPTABLE*)))
                  RANGE OFFSET &BODY (BODY DECLS DOC))
         (CL:IF (CL:ZEROP INDIRECT)
                (BQUOTE (PROGN (DEFUN (\,
 NAME) (STREAM OPCODE) (\, (OR DOC 
                                                                        "FASL opcode implementation")
                                                                    )
                                                                (\,@ DECLS)
                                                                (\,@ BODY))

                               (LET ((PACKAGE (SYMBOL-PACKAGE (QUOTE (\, NAME))))
                                     (PNAME (SYMBOL-NAME (QUOTE (\, NAME)))))
                                    (DOTIMES (I (\, RANGE))
                                           (LET ((OPCODE (+ I (\, FIRST-OPCODE))))
                                                (SETF (CL:ELT (FASL::OPTABLE-VECTOR (\, TABLE))
                                                             OPCODE)
                                                      (QUOTE (\, NAME)))
                                                (FASL::ADD-OP-TRANSLATION
                                                 (INTERN (CONCATENATE (QUOTE STRING)
                                                                PNAME
                                                                (WRITE-TO-STRING (+ I (\, OFFSET))))
                                                        PACKAGE)
                                                 OPCODE
                                                 (\, TABLE)))))))
                (BQUOTE (PROGN (CL:UNLESS (FASL::OPTABLE-NEXT (\, TABLE))
                                      (SETF (FASL::OPTABLE-NEXT (\, TABLE))
                                            (FASL:MAKE-OPTABLE))
                                      (FASL::SETESCAPE (\, TABLE)))
                               (FASL:DEFRANGE (\,
 NAME) ((\, FIRST-OPCODE)
                                                         :INDIRECT
                                                         (\, (1- INDIRECT))
                                                         :TABLE
                                                         (FASL::OPTABLE-NEXT (\, TABLE)))
                                  (\, (OR DOC "FASL opcode implementation"))
                                  (\,@ DECLS)
                                  (\,@ BODY))
))))

(DEFUN FASL::ADD-OP-TRANSLATION
 (NAME OPCODE TABLE) (LET ((PAIR (CL:ASSOC NAME (FASL::OPTABLE-OPNAMES
                                                                                TABLE))))
                                                         (CL:IF PAIR (SETF (CDR PAIR)
                                                                           OPCODE)
                                                                (CL:PUSH (CONS NAME OPCODE)
                                                                       (FASL::OPTABLE-OPNAMES TABLE))
                                                                )))

(DEFUN FASL:OPCODE-SEQUENCE
 (OPNAME &OPTIONAL (TABLE FASL:*DEFAULT-OPTABLE*)
                                   &AUX ENTRY) (COND
                                                  ((NULL TABLE)
                                                   NIL)
                                                  ((CL:SETQ ENTRY (CL:ASSOC OPNAME (
                                                                                FASL::OPTABLE-OPNAMES
                                                                                    TABLE)))
                                                   (LIST (CDR ENTRY)))
                                                  ((CL:SETQ ENTRY (FASL:OPCODE-SEQUENCE OPNAME
                                                                         (FASL::OPTABLE-NEXT TABLE)))
                                                   (CONS FASL::FASL-EXTENDED ENTRY))
                                                  (T NIL)))

(DEFUN FASL::FASL-EXTENDED
 (STREAM OP) (FASL:WITH-OPTABLE (FASL::OPTABLE-NEXT FASL::*CURRENT-OPTABLE*
                                                                 )
                                              (FASL::DO-OP STREAM)))

(DEFUN FASL::SETESCAPE
 (TABLE) (SETF (SVREF (FASL::OPTABLE-VECTOR TABLE)
                                            FASL::FASL-EXTENDED)
                                     (CL:FUNCTION FASL::FASL-EXTENDED)))

(DEFUN FASL::UNIMPLEMENTED-OPCODE
 (STREAM OPCODE) (CL:ERROR (QUOTE FASL:UNIMPLEMENTED-OPCODE)
                                                         :OPNAME OPCODE))

(DEFVAR FASL:*DEFAULT-OPTABLE*
 (FASL:MAKE-OPTABLE) )

(DEFVAR FASL::*CURRENT-OPTABLE*
 NIL)

(DEFPARAMETER FASL::INITIAL-VALUE-TABLE-SIZE
 2048)

(DEFCONSTANT FASL::VALUE-TABLE-INCREMENT
 1024)

(DEFVAR FASL::*VALUE-TABLE*
 NIL)

(DEFVAR FASL::*BLOCK-LEVEL*
 0)

(DEFVAR FASL::DEBUG-READER
 NIL)

(DEFVAR FASL::DEBUG-STREAM
 NIL)

(DEFMACRO FASL:WITH-OPTABLE
 (TABLE &BODY BODY) (BQUOTE (LET ((FASL::*CURRENT-OPTABLE* (\, TABLE)))
                                                            (\,@ BODY))))

(DEFUN FASL:PROCESS-FILE
 (STREAM &KEY (TEXT-FN (CL:FUNCTION (LAMBDA (TEXT)
                                                                   (PRINC TEXT)
                                                                   (TERPRI))))
                                (ITEM-FN NIL)) "Calls FASL:PROCESS-SEGMENT with the approriate arguments for each segment in the file. The stream should be positioned at the beginning."
   (CL:UNLESS (EQL (BIN STREAM)
                   FASL:SIGNATURE)
          (CL:ERROR "Not a FASL file."))
   (FASL:CHECK-VERSION STREAM)
   (CL:DO NIL ((EOFP STREAM)
               (VALUES))
          (FASL:PROCESS-SEGMENT STREAM TEXT-FN ITEM-FN)))

(DEFUN FASL:CHECK-VERSION
 (STREAM) (LET ((VERSION (BIN16 STREAM)))
                                        (OR (AND (<= (CAR FASL::VERSION-RANGE)
                                                  VERSION)
                                                 (<= VERSION (CDR FASL::VERSION-RANGE)))
                                            (CL:ERROR "Version not supported: ~D." VERSION))))

(DEFUN FASL:PROCESS-SEGMENT
 (STREAM &OPTIONAL TEXT-FN ITEM-FN (OPTABLE FASL:*DEFAULT-OPTABLE*))
   (CL:IF TEXT-FN (FUNCALL TEXT-FN (FASL:READ-TEXT STREAM))
          (FASL:SKIP-TEXT STREAM))
   (FASL:PROCESS-BLOCK STREAM ITEM-FN OPTABLE))

(DEFUN FASL:READ-TEXT
 (STREAM) (CL:DO ((RESULT (MAKE-ARRAY 512 :ELEMENT-TYPE (QUOTE CHARACTER)
                                                      :ADJUSTABLE T :FILL-POINTER 0))
                                       (BYTE (BIN STREAM)
                                             (BIN STREAM)))
                                      ((EQL BYTE FASL::END-MARK)
                                       (CL:COERCE RESULT (QUOTE STRING)))
                                      (VECTOR-PUSH-EXTEND (CODE-CHAR BYTE)
                                             RESULT)))

(DEFUN FASL:PROCESS-BLOCK
 (STREAM &OPTIONAL ITEM-FN (OPTABLE FASL:*DEFAULT-OPTABLE*))
   (CATCH (QUOTE FASL-BLOCK-FINISHED)
          (FASL:WITH-OPTABLE OPTABLE (CL:DO ((FASL::*VALUE-TABLE* (FASL::NEW-VALUE-TABLE))
                                             VAL)
                                            NIL
                                            (SETF VAL (FASL::DO-OP STREAM 0))
                                            (CL:WHEN ITEM-FN (FUNCALL ITEM-FN VAL))))))

(DEFUN FASL:SKIP-TEXT
 (STREAM) (CL:DO ((BYTE (BIN STREAM)))
                                      ((EQL BYTE FASL::END-MARK)
                                       (VALUES))))

(DEFMACRO FASL:NEXT-VALUE
 NIL (QUOTE (FASL::DO-OP STREAM)))

(DEFUN FASL::DO-OP
 (STREAM &OPTIONAL (FASL::*BLOCK-LEVEL* (1+ FASL::*BLOCK-LEVEL*)))
   (LET ((OP (BIN STREAM))
         VAL)
        (CL:WHEN FASL::DEBUG-READER (FORMAT FASL::DEBUG-STREAM "~VT~A (~3O)~%%" (ITIMES 
                                                                                  FASL::*BLOCK-LEVEL* 
                                                                                       4)
                                           (CAR (RASSOC OP (FASL::OPTABLE-OPNAMES 
                                                                  FASL::*CURRENT-OPTABLE*)))
                                           OP))
        (CL:SETQ VAL (FUNCALL (SVREF (FASL::OPTABLE-VECTOR FASL::*CURRENT-OPTABLE*)
                                     OP)
                            STREAM OP))
        (CL:WHEN FASL::DEBUG-READER (FORMAT FASL::DEBUG-STREAM "~VTValue: ~S~%%" (ITIMES 
                                                                                  FASL::*BLOCK-LEVEL* 
                                                                                        4)
                                           VAL))
        (RETURN-FROM FASL::DO-OP VAL)))

(DEFUN FASL::NEW-VALUE-TABLE
 NIL (MAKE-ARRAY FASL::INITIAL-VALUE-TABLE-SIZE :FILL-POINTER 0 
                                        :EXTENDABLE T))

(DEFUN FASL::CLEAR-TABLE
 (&OPTIONAL (TABLE FASL::*VALUE-TABLE*)) (SETF (FILL-POINTER TABLE)
                                                                       0))

(DEFUN FASL::STORE-VALUE
 (OBJ &OPTIONAL (TABLE FASL::*VALUE-TABLE*)) 

                                                  (* ;; 

 "This may want to change to another representation if we can't make VECTOR-PUSH-EXTEND fast enough.")

   (VECTOR-PUSH-EXTEND OBJ TABLE FASL::VALUE-TABLE-INCREMENT)
   OBJ)

(DEFUN FASL::FETCH-VALUE
 (INDEX &OPTIONAL (TABLE FASL::*VALUE-TABLE*)) (AREF TABLE INDEX))

(DEFUN FASL::COLLECT-LIST
 (STREAM NELTS DOTTED) (CL:IF (AND DOTTED (EQL NELTS 2))
                                                       (RETURN-FROM FASL::COLLECT-LIST
                                                              (CONS (FASL::DO-OP STREAM)
                                                                    (FASL::DO-OP STREAM))))
                                                (CL:WHEN DOTTED (DECF NELTS))
                                                (LET ((RESULT (to
 NELTS collect
 (FASL::DO-OP STREAM))
                                                             ))

                                                  (* ;; 

                                                "Assume dotted and other than a simple cons is rare.")

                                                     (CL:WHEN DOTTED (SETF (CDR (LAST RESULT))
                                                                           (FASL::DO-OP STREAM)))
                                                     (RETURN-FROM FASL::COLLECT-LIST RESULT)))

(FASL:DEFRANGE FASL:FASL-SHORT-INTEGER
 (0) 128 0 OPCODE)

(FASL:DEFOP FASL:FASL-NIL
 (128) NIL)

(FASL:DEFOP FASL:FASL-T
 (129) T)

(FASL:DEFOP FASL:FASL-INTEGER
 (130) (IPLUS (LLSH (BIN STREAM)
                                                 24)
                                           (LLSH (BIN STREAM)
                                                 16)
                                           (LLSH (BIN STREAM)
                                                 8)
                                           (BIN STREAM)))

(FASL:DEFOP FASL:FASL-LARGE-INTEGER
 (131) (LET ((NBYTES (FASL:NEXT-VALUE))
                                                (FIRST-TIME T)
                                                (MASK 0))
                                               (CL:DO ((OFFSET (ITIMES (1- NBYTES)
                                                                      8)
                                                              (- OFFSET 8))
                                                       (RESULT 0)
                                                       BYTE)
                                                      ((< OFFSET 0)
                                                       (CL:IF (CL:ZEROP MASK)
                                                              RESULT
                                                              (- (1+ RESULT))))
                                                      (SETF BYTE (BIN STREAM))
                                                      (CL:WHEN FIRST-TIME (SETF FIRST-TIME NIL)
                                                             (CL:WHEN (> BYTE 127)
                                                                    (CL:SETQ MASK 255)))
                                                      (SETF (LDB (BYTE 8 OFFSET)
                                                                 RESULT)
                                                            (LOGXOR BYTE MASK)))))

(FASL:DEFOP FASL:FASL-RATIO
 (134) (/ (FASL:NEXT-VALUE)
                                     (FASL:NEXT-VALUE)))

(FASL:DEFOP FASL:FASL-COMPLEX
 (135) (COMPLEX (FASL:NEXT-VALUE)
                                           (FASL:NEXT-VALUE)))

(FASL:DEFOP FASL:FASL-VECTOR
 (136) (LET* ((NELTS (FASL:NEXT-VALUE))
                                          (VECTOR (MAKE-ARRAY NELTS :INITIAL-ELEMENT NIL)))
                                         (DOTIMES (I NELTS VECTOR)
                                                (SETF (AREF VECTOR I)
                                                      (FASL:NEXT-VALUE)))))

(FASL:DEFOP FASL:FASL-CREATE-ARRAY
 (137) (CL:APPLY (CL:FUNCTION MAKE-ARRAY)
                                                (FASL:NEXT-VALUE)
                                                (FASL:NEXT-VALUE)))

(FASL:DEFOP FASL:FASL-INITIALIZE-ARRAY
 (138) (LET* ((ARRAY (FASL:NEXT-VALUE))
                                                    (INDIRECT (%%FLATTEN-ARRAY ARRAY))
                                                    (NELTS (FASL:NEXT-VALUE)))
                                                   (DOTIMES (I NELTS ARRAY)
                                                          (SETF (AREF INDIRECT I)
                                                                (FASL:NEXT-VALUE)))))

(FASL:DEFOP FASL:FASL-INITIALIZE-BIT-ARRAY
 (139)
   (LET* ((ARRAY (FASL::DO-OP STREAM))
          (BASE (%%ARRAY-BASE ARRAY))
          (NBITS (FASL::DO-OP STREAM)))
         (MULTIPLE-VALUE-BIND (NBYTES LEFTOVER)
                (CL:FLOOR NBITS 8)
                (CL:UNLESS (CL:ZEROP LEFTOVER)
                       (CL:DO* ((INITIAL (ITIMES NBYTES 8))
                                (INDIRECT (%%FLATTEN-ARRAY ARRAY))
                                (LAST-BYTE (BIN STREAM))
                                (I 0 (1+ I)))
                              ((= I LEFTOVER))
                              (SETF (BIT INDIRECT (+ INITIAL I))
                                    (LET ((BS (BYTE 1 (- 7 I))))
                                         (LDB BS LAST-BYTE)))))
                ARRAY)))

(FASL:DEFOP FASL:FASL-THIN-STRING
 (140) (LET* ((NCHARS (FASL:NEXT-VALUE))
                                               (STRING (ALLOCSTRING NCHARS)))
                                              (\BINS STREAM (fetch
 (STRINGP BASE) of
 STRING)
                                                     0 NCHARS)
                                              STRING))

(FASL:DEFOP FASL:FASL-FAT-STRING
 (141) (LET* ((NCHARS (FASL:NEXT-VALUE))
                                              (STRING (ALLOCSTRING NCHARS)))
                                             (CHARSET STREAM 0)
                                             (UNWIND-PROTECT (DOTIMES (I NCHARS STRING)
                                                                    (SETF (SVREF STRING I)
                                                                          (CODE-CHAR (READCCODE
                                                                                      STREAM))))
                                                    (CHARSET STREAM 0))))

(FASL:DEFOP FASL:FASL-CHARACTER
 (142) (LET ((CODE (BIN STREAM)))
                                           (CODE-CHAR (CL:IF (EQL CODE 255)
                                                             (BIN16 STREAM)
                                                             CODE))))

(FASL:DEFOP FASL:FASL-LISP-SYMBOL
 (143) (INTERN (FASL:NEXT-VALUE)
                                               (FIND-PACKAGE "LISP")))

(FASL:DEFOP FASL:FASL-KEYWORD-SYMBOL
 (144) (INTERN (FASL:NEXT-VALUE)
                                                  (FIND-PACKAGE "KEYWORD")))

(FASL:DEFOP FASL:FASL-FIND-PACKAGE
 (145) (FIND-PACKAGE (FASL:NEXT-VALUE)))

(FASL:DEFOP FASL:FASL-SYMBOL-IN-PACKAGE
 (146) (INTERN (FASL:NEXT-VALUE)
                                                     (FASL:NEXT-VALUE)))

(FASL:DEFOP FASL:FASL-LIST
 (147) (FASL::COLLECT-LIST STREAM (FASL:NEXT-VALUE)
                                        NIL))

(FASL:DEFOP FASL:FASL-LIST*
 (148) (FASL::COLLECT-LIST STREAM (FASL:NEXT-VALUE)
                                         T))

(FASL:DEFOP FASL:FASL-DCODE
 (150) 
                (* ;;; "DIRE WARNING!!! Be sure you have your pointy hat with lots of stars on if you're going to muck around with this code. Due to unfortunately unaviodaple performace requirements, this code duplicates INTERN-DCODE. If you make a change here, you should probably change the corresponding code there.")

   (LET ((OVERHEADBYTES (CL:* (fetch
 (FNHEADER OVERHEADWORDS) of
 T)
                              BYTESPERWORD))
         NT-COUNT RAW-CODE START-PC CLOSURE-INFO)
        (SETF NT-COUNT (FASL:NEXT-VALUE))
        (LET ((CODE-LEN (FASL:NEXT-VALUE)))
             (MULTIPLE-VALUE-SETQ (RAW-CODE START-PC)
                    (ALLOCATE-CODE-BLOCK NT-COUNT CODE-LEN))
             (\BINS STREAM RAW-CODE START-PC CODE-LEN)
             (replace
 (FNHEADER STARTPC) of
 RAW-CODE with
 START-PC))

                                                  (* ;; "Set up the free variable lookup name table.")

        (CL:DO* ((I 0 (1+ I))
                 (INDEX OVERHEADBYTES (+ INDEX BYTESPERWORD))

                                                  (* ;; 

                         "NTSIZE and NTBYTESIZE the sizes of half the table in words and bytes resp.")

                 (NTSIZE (CEIL (1+ NT-COUNT)
                               WORDSPERQUAD))
                 (NTBYTESIZE (CL:* NTSIZE BYTESPERWORD))
                 PFI OFFSET NAME FVAROFFSET)
               ((>= I NT-COUNT)
                (replace
 (FNHEADER FVAROFFSET) of
 RAW-CODE with
 (OR FVAROFFSET 0))
                (replace
 (FNHEADER NTSIZE) of
 RAW-CODE with
 NTSIZE))
               (SETF PFI (BIN STREAM))
               (SETF OFFSET (FASL:NEXT-VALUE))
               (SETF NAME (FASL:NEXT-VALUE))
               (FIXUP-WORD RAW-CODE INDEX (\LOLOC NAME))
               (FIXUP-WORD RAW-CODE (+ INDEX NTBYTESIZE)
                      (+ (LLSH PFI 14)
                         OFFSET))
               (CL:WHEN (AND (NULL FVAROFFSET)
                             (= PFI +FVAR-CODE+))
                      (SETF FVAROFFSET (CL:FLOOR INDEX BYTESPERWORD))))

                                                  (* ;; 

                                           "Fill in the fixed-size fields at the front of the block.")

        (LET ((FRAME-NAME (FASL:NEXT-VALUE)))
             (UNINTERRUPTABLY
                 (\ADDREF FRAME-NAME)
                 (replace
 (FNHEADER #FRAMENAME) of
 RAW-CODE with
 FRAME-NAME)))
        (LET ((NLOCALS (BIN STREAM))
              (NFREEVARS (BIN STREAM)))
             (replace
 (FNHEADER NLOCALS) of
 RAW-CODE with
 NLOCALS)
             (replace
 (FNHEADER PV) of
 RAW-CODE with
 (1- (CEILING (+ NLOCALS NFREEVARS)
                                                                CELLSPERQUAD))))
        (replace
 (FNHEADER ARGTYPE) of
 RAW-CODE with
 (BIN STREAM))
        (replace
 (FNHEADER NA) of
 RAW-CODE with
 (FASL:NEXT-VALUE))
        (SETF CLOSURE-INFO (FASL:NEXT-VALUE))
        (replace
 (FNHEADER CLOSUREP) of
 RAW-CODE with
 (EQ CLOSURE-INFO :CLOSURE))
        (replace
 (FNHEADER FIXED) of
 RAW-CODE with
 T)

                                                  (* ;; "Fill in debugging info. It goes into the spare cell just before the code: it's -3 instead of -bytespercell to right-justify the pointer in the cell. Aren't you glad I told you this?")

        (FIXUP-PTR RAW-CODE (- START-PC 3)
               (FASL:NEXT-VALUE))
                            (* ;; "Do fixups")

        (CL:DO ((FN-FIXUP-COUNT (FASL:NEXT-VALUE))
                (I 0 (1+ I))
                OFFSET VALUE)
               ((>= I FN-FIXUP-COUNT))
               (SETF OFFSET (FASL:NEXT-VALUE))
               (SETF VALUE (FASL:NEXT-VALUE))
               (FIXUP-WORD RAW-CODE (+ START-PC OFFSET)
                      (\LOLOC VALUE)))
        (CL:DO ((SYM-FIXUP-COUNT (FASL:NEXT-VALUE))
                (I 0 (1+ I))
                OFFSET VALUE)
               ((>= I SYM-FIXUP-COUNT))
               (SETF OFFSET (FASL:NEXT-VALUE))
               (SETF VALUE (FASL:NEXT-VALUE))
               (FIXUP-WORD RAW-CODE (+ START-PC OFFSET)
                      (\LOLOC VALUE)))
        (CL:DO ((LIT-FIXUP-COUNT (FASL:NEXT-VALUE))
                (I 0 (1+ I))
                OFFSET VALUE)
               ((>= I LIT-FIXUP-COUNT))
               (SETF OFFSET (FASL:NEXT-VALUE))
               (SETF VALUE (FASL:NEXT-VALUE))
               (FIXUP-PTR RAW-CODE (+ START-PC OFFSET)
                      (CL:IF (DCODE-P VALUE)
                             (INTERN-DCODE VALUE)
                             VALUE)))
        (CL:DO ((TYPE-FIXUP-COUNT (FASL:NEXT-VALUE))
                (I 0 (1+ I))
                OFFSET VALUE)
               ((>= I TYPE-FIXUP-COUNT))
               (SETF OFFSET (FASL:NEXT-VALUE))
               (SETF VALUE (FASL:NEXT-VALUE))
               (FIXUP-WORD RAW-CODE (+ START-PC OFFSET)
                      (\RESOLVE.TYPENUMBER VALUE)))

                                                  (* ;; 

                                              "Finally, wrap this up in a closure-object if desired.")

        (CL:IF (EQ CLOSURE-INFO :FUNCTION)
               (MAKE-COMPILED-CLOSURE RAW-CODE NIL)
               RAW-CODE)))

(FASL:DEFOP FASL:FASL-TABLE-STORE
 (152) (FASL::STORE-VALUE (FASL:NEXT-VALUE)))

(FASL:DEFOP FASL:FASL-TABLE-FETCH
 (153) (FASL::FETCH-VALUE (FASL:NEXT-VALUE)))

(FASL:DEFOP FASL:FASL-VERIFY-TABLE-SIZE
 (154) (LET ((EXPECTED (FASL:NEXT-VALUE)))
                                                   (OR (EQL EXPECTED (CL:LENGTH FASL::*VALUE-TABLE*))
                                                       (CL:ERROR (QUOTE FASL:INCONSISTENT-TABLE)
                                                              :TABLE FASL::*VALUE-TABLE* :EXPECTED 
                                                              EXPECTED))))

(FASL:DEFOP FASL:FASL-EVAL
 (155) (CL:EVAL (FASL:NEXT-VALUE)))

(FASL:DEFOP FASL:FASL-FLOAT32
 (132) (LET ((RESULT (NCREATE (QUOTE FLOATP))))
                                         (\BINS STREAM RESULT 0 4)
                                         RESULT))

(FASL:DEFOP FASL:FASL-SETF-SYMBOL-FUNCTION
 (156) (SETF (SYMBOL-FUNCTION (FASL:NEXT-VALUE))
                                                       (FASL:NEXT-VALUE)))

(FASL:DEFOP FASL:FASL-FUNCALL
 (157) (FUNCALL (FASL:NEXT-VALUE)))


(PUTPROPS FASL FILETYPE
 COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 FASL::SO-THAT-THE-FILE-WILL-GET-COMPILED)
)
(PUTPROPS FASL COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (4918 4994 (FASL::SO-THAT-THE-FILE-WILL-GET-COMPILED 4928 . 4992)))))
STOP