(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