(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE "FASL")

(il:filecreated "21-Nov-86 16:19:43" il:{eris}<lispcore>sources>fasl.\;19
 58420  

      il:|changes| il:|to:|  (fasl-ops fasl-symbol-in-package)
                             (il:vars il:faslcoms)
                             (il:functions dump-symbol)

      il:|previous| il:|date:| "15-Nov-86 19:57:26" il:{eris}<lispcore>sources>fasl.\;18)


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

(il:prettycomprint il:faslcoms)

(il:rpaqq il:faslcoms
 
          ((il:coms (il:* il:|;;;| "Common definitions.")
                  (il:declare\: il:eval@compile il:eval@load il:dontcopy (il:files (il:loadcomp)
                                                                                il:llchar))
                  (il:structures fasl-error unimplemented-opcode object-not-dumpable 
                         unexpected-end-of-block inconsistent-table)
                  (il:variables signature)
                  (il:variables check-table-size fasl-extended end-mark version-range current-version
                         )
                  (il:functions table-stats))
           (il:coms (il:* il:|;;;| "Dumper.")
                  (il:structures handle)
                  (il:variables dummy-handle)
                  (il:variables +smallest-four-byte-integer+ +largest-four-byte-integer+)
                  (il:variables *gather-dumper-stats* *table-attempts* *table-hits*)
                  (il:functions reset-dumper-stats)
                  (il:functions dotted-list-length state-case fat-string-p remember 
                         elements-identical-p end-block end-text write-op lookup-value save-value)
                  (il:functions dump-value-fetch dump-character dump-symbol dump-list 
                         dump-simple-vector dump-array-descriptor dump-bit-array dump-general-array 
                         dump-array write-integer-bytes integer-byte-list dump-rational dump-complex 
                         dump-integer dump-package dump-dcode dump-string dump-float32)
                  (il:functions open-fasl-handle with-open-handle begin-text begin-block 
                         value-dumpable-p dump-value dump-function-def dump-funcall dump-eval 
                         close-fasl-handle))
           (il:coms (il:* il:|;;;| "Reader.")
                  (il:define-types fasl-ops)
                  (il:structures optable)
                  (il:functions make-optable fasl-end-of-block defop defrange add-op-translation 
                         opcode-sequence fasl-extended setescape unimplemented-opcode)
                  (il:variables *default-optable* *current-optable* initial-value-table-size 
                         value-table-increment *value-table* *block-level* debug-reader debug-stream)
                  (il:functions with-optable process-file check-version process-segment read-text 
                         process-block skip-text next-value do-op new-value-table clear-table 
                         store-value fetch-value collect-list)
                  (fasl-ops fasl-short-integer fasl-nil fasl-t fasl-integer fasl-large-integer 
                         fasl-ratio fasl-complex fasl-vector fasl-create-array fasl-initialize-array 
                         fasl-initialize-bit-array fasl-thin-string fasl-fat-string fasl-character 
                         fasl-lisp-symbol fasl-keyword-symbol fasl-find-package 
                         fasl-symbol-in-package fasl-list fasl-list* fasl-interlisp-symbol fasl-dcode 
                         fasl-table-store fasl-table-fetch fasl-verify-table-size fasl-eval 
                         fasl-float32 fasl-setf-symbol-function fasl-funcall))
           (il:* il:|;;| "Arrange for the correct compiler to be used")
           (il:prop il:filetype il:fasl)
           (il:* il:|;;| "Arrange for the proper makefile environment")
           (il:prop il:makefile-environment il:fasl)))



(il:* il:|;;;| "Common definitions.")


(il:declare\: il:eval@compile il:eval@load il:dontcopy 
(il:filesload (il:loadcomp)
       il:llchar)
)

(xcl:define-condition fasl-error
 error)


(xcl:define-condition unimplemented-opcode
 fasl-error :report (format t "Unimplemented FASL op: ~S" 
                                                                     opname)
                                                 opname)


(xcl:define-condition object-not-dumpable
 fasl-error :report (format t "Object not dumpable:~&~S" 
                                                                    object)
                                                object)


(xcl:define-condition unexpected-end-of-block
 fasl-error :report (format t 
                                                                "Unexpected FASL-END-OF-BLOCK at ~D."
                                                                        (il:getfileptr stream))
                                                    stream)


(xcl:define-condition inconsistent-table
 fasl-error :report (format t 
                                           "Inconsistent FASL table size.~&Expected ~D but found ~D." 
                                                                   expected (length (optable-vector
                                                                                     table)))
                                               table expected)


(defconstant signature
 145 "First byte of a FASL file.")


(defvar check-table-size
 t)


(defconstant fasl-extended
 254)


(defconstant end-mark
 255)


(defconstant version-range
 '(2 . 3) "Handles (car version-range) <= version <= (cdr version-range)"
   )


(defconstant current-version
 3)


(defun table-stats
 (table) (let ((items (list (cons '--total-- (length table)))))
                                (dotimes (i (length table)
                                            items)
                                       (let* ((type (type-of (aref table i)))
                                              (pair (or (find type items :test 'equal :key
                                                              'car)
                                                        (car (push (cons type 0)
                                                                   items)))))
                                             (incf (cdr pair))))))




(il:* il:|;;;| "Dumper.")



(defstruct (handle
 (:constructor make-handle)) stream (state :block-end)
                                                     (last-index 0)
                                                     (hash (make-hash-table :test #'eq)))


(defconstant dummy-handle
 (make-handle :stream (open "{null}" :direction :output)
                                 :state :block :hash nil) )


(defconstant +smallest-four-byte-integer+
 (- (expt 2 31)) )


(defconstant +largest-four-byte-integer+
 (1- (expt 2 31)) )


(defvar *gather-dumper-stats*
 nil)


(defvar *table-attempts*
 0 "Number of table lookups by the FASL dumper.")


(defvar *table-hits*
 0 "Number of successful table lookups by the FASL dumper.")


(defun reset-dumper-stats
 nil (setq *table-attempts* 0 *table-hits* 0))


(defun dotted-list-length
 (x) (do ((n 0 (+ n 2))
                                   (fast x (cddr fast))
                                   (slow x (cdr slow)))
                                  (nil)
                                  (cond
                                     ((null fast)
                                      (return n))
                                     ((atom fast)
                                      (return (values n t)))
                                     ((null (cdr fast))
                                      (return (1+ n)))
                                     ((atom (cdr fast))
                                      (return (values (1+ n)
                                                     t)))
                                     ((and (eq fast slow)
                                           (> n 0))
                                      (return nil)))))


(defmacro state-case
 (&rest clauses) `(ecase (handle-state handle)
                                             ,@clauses))


(defun fat-string-p
 (string) (cond
                                ((il:stringp string)
                                 (eq (il:fetch
 (il:stringp il:typ) il:of
 string)
                                     il:\\st.pos16))
                                (t (il:%fat-string-array-p string))))


(defmacro remember
 (value &body body) (let ((remember-val (il:gensym)))
                                           `(let ((,remember-val ,value))
                                                 (when remember (write-op handle 'fasl-table-store))
                                                 ,@body
                                                 (when remember (save-value handle ,remember-val)))))


(defun elements-identical-p
 (array) (let* ((seq (il:%flatten-array array))
                                           (testelt (aref seq 0)))
                                          (every #'(lambda (x)
                                                          (eql x testelt)) seq)))


(defun end-block
 (handle) (state-case (:block (when check-table-size (write-op handle '
                                                                            fasl-verify-table-size)
                                                    (dump-value handle (handle-last-index handle)
                                                           nil))
                                             (il:bout (handle-stream handle)
                                                    end-mark)
                                             (setf (handle-last-index handle)
                                                   0)
                                             (setf (handle-hash handle)
                                                   (make-hash-table :test #'eq))
                                             (setf (handle-state handle)
                                                   :block-end))))


(defun end-text
 (handle) (state-case (:text (il:bout (handle-stream handle)
                                                   end-mark)
                                            (setf (handle-state handle)
                                                  :block))))


(defun write-op
 (handle opname) (state-case (:block (let ((stream (handle-stream handle))
                                                          (opseq (opcode-sequence opname)))
                                                         (if (null opseq)
                                                             (error 'unimplemented-opcode :opname 
                                                                    opname)
                                                             (dolist (op opseq)
                                                                    (il:bout stream op)))))))


(defun lookup-value
 (handle value) (let ((hash-table (handle-hash handle)))
                                        (and hash-table (il:gethash value hash-table))))


(defun save-value
 (handle value) (let ((hash-table (handle-hash handle)))
                                      (unless (null hash-table)
                                             (setf (il:gethash value hash-table)
                                                   (handle-last-index handle))
                                             (incf (handle-last-index handle)))))


(defun dump-value-fetch
 (handle index) (write-op handle 'fasl-table-fetch)
                                       (dump-value handle index nil))


(defun dump-character
 (handle char remember) (declare
 (ignore remember))
                                                             (il:* il:|;;| 

                                                             "Characters don't get remembered.")

                                             (let ((code (char-code char))
                                                   (stream (handle-stream handle)))
                                                  (write-op handle 'fasl-character)
                                                  (if (< code 256)
                                                      (il:bout stream code)
                                                      (progn (il:bout stream 255)
                                                             (il:bout16 stream code)))))


(defun dump-symbol
 (handle symbol remember)                  (il:* il:|;;| 

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

   (let* ((pname (symbol-name symbol))
          (package (symbol-package symbol))
          (pkg-name (and package (package-name package))))
         (remember symbol (cond
                             ((keywordp symbol)
                              (write-op handle 'fasl-keyword-symbol)
                              (dump-value handle pname nil))
                             ((equal pkg-name "LISP")
                              (write-op handle 'fasl-lisp-symbol)
                              (dump-value handle pname nil))
                             ((equal pkg-name "INTERLISP")
                              (write-op handle 'fasl-interlisp-symbol)
                              (dump-value handle pname nil))
                             (t (write-op handle 'fasl-symbol-in-package)
                                (dump-value handle pname nil)
                                (dump-value handle package remember))))))


(defun dump-list
 (handle list remember) (multiple-value-bind (length dotted)
                                               (dotted-list-length list)
                                               (unless length (error 'object-not-dumpable :object 
                                                                     list))
                                               (remember list (write-op handle (if dotted
                                                                                   'fasl-list*
                                                                                   'fasl-list))
                                                      (dump-value handle (if dotted (1+ length)
                                                                             length)
                                                             nil)
                                                      (dotimes (i length)
                                                             (dump-value handle (car list))
                                                             (pop list))
                                                      (when dotted (dump-value handle list nil)))))


(defun dump-simple-vector
 (handle vector remember) (let ((length (length vector)))
                                                        (remember vector (write-op handle
                                                                                'fasl-vector)
                                                               (dump-value handle length remember)
                                                               (dotimes (i length)
                                                                      (dump-value handle
                                                                             (svref vector i)
                                                                             remember)))))


(defun dump-array-descriptor
 (handle array remember &key (initial-element nil use-single-elt))
   (remember array (write-op handle 'fasl-create-array)
          (dump-value handle (if (eql (array-rank array)
                                      1)
                                 (car (array-dimensions array))
                                 (array-dimensions array))
                 remember)
          (dump-value handle `(:element-type ,(array-element-type array) :adjustable
                                     ,(adjustable-array-p array)
                                     ,@(when (array-has-fill-pointer-p array)
                                             `(:fill-pointer ,(fill-pointer array)))
                                     ,@(when use-single-elt `(:initial-element ,initial-element))) 
                 remember)))


(defun dump-bit-array
 (handle array remember) (let ((nbits (array-total-size array)))
                                                   (unless (zerop (il:%array-offset array))
                                                          (error 'object-not-dumpable :object array))
                                                   (remember array (write-op handle '
                                                                          fasl-initialize-bit-array)
                                                          (dump-value handle nbits remember)
                                                          (dump-array-descriptor handle array 
                                                                 remember)
                                                          (il:\\bouts (handle-stream handle)
                                                                 (il:%array-base array)
                                                                 0
                                                                 (ceiling nbits 8)))))


(defun dump-general-array
 (handle array remember)            (il:* il:|;;| 

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

   (let* ((nelts (array-total-size array))
          (elt-type (array-element-type array)))
         (write-op handle 'fasl-initialize-array)
         (dump-array-descriptor handle array nil)
         (dump-value handle nelts nil)
         (let ((indirect (make-array nelts :displaced-to array :element-type elt-type)))
              (dotimes (i nelts)
                     (dump-value handle (aref indirect i)
                            nil)))))


(defun dump-array
 (handle array remember) (cond
                                             ((xcl:displaced-array-p array)
                                              (error 'object-not-dumpable :object array))
                                             ((adjustable-array-p array)
                                              (dump-general-array handle array remember))
                                             ((typep array '(array bit))
                                              (dump-bit-array handle array remember))
                                             ((typep array 'vector)
                                              (dump-simple-vector handle array remember))
                                             (t (dump-general-array handle array remember))))


(defun write-integer-bytes
 (handle nbytes value) (let ((stream (handle-stream handle)))
                                                      (dolist (byte (integer-byte-list value nbytes))
                                                             (il:bout stream byte))))


(defun integer-byte-list
 (value nbytes) (do ((count 0 (1+ count))
                                             (result nil)
                                             (n value)
                                             byte)
                                            ((>= count nbytes)
                                             result)
                                            (multiple-value-setq (n byte)
                                                   (floor n 256))
                                            (push byte result)))


(defun dump-rational
 (handle value remember) (declare
 (ignore remember))
                                             (write-op handle 'fasl-ratio)
                                             (dump-value handle (numerator value)
                                                    nil)
                                             (dump-value handle (denominator value)
                                                    nil))


(defun dump-complex
 (handle value remember) (declare
 (ignore remember))
                                            (write-op handle 'fasl-complex)
                                            (dump-value handle (realpart value)
                                                   nil)
                                            (dump-value handle (imagpart value)
                                                   nil))


(defun dump-integer
 (handle value remember) (declare
 (ignore remember))
                                            (cond
                                               ((and (<= 0 value)
                                                     (< value 128))
                                                (il:bout (handle-stream handle)
                                                       value))
                                               ((and (<= +smallest-four-byte-integer+ value 
                                                      +largest-four-byte-integer+))
                                                (write-op handle 'fasl-integer)
                                                (write-integer-bytes handle 4 value))
                                               (t (write-op handle 'fasl-large-integer)
                                                  (let* ((minbits (1+ (integer-length value)))
                                                         (nbytes (ceiling (integer-length value)
                                                                        8)))
                                                             (il:* il:|;;| "According to the book, MINBITS gives the minimum field width for this number in 2's complement representation.")

                                                        (dump-value handle nbytes nil)
                                                        (write-integer-bytes handle nbytes value)))))


(defun dump-package
 (handle package remember) (remember package (write-op handle 'fasl-find-package)
                                                     (dump-value handle (package-name package)
                                                            remember)))


(defun dump-dcode
 (handle dcode remember)                    (il:* il:|;;| 

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

   (let ((stream (handle-stream handle)))
        (macrolet ((dump-seq (seq dump-length &rest stuff)
                          `(let ((seq ,seq))
                                ,@(and dump-length '((dump-value handle (length seq)
                                                            remember)))
                                (if (listp seq)
                                    (dolist (elt seq)
                                           ,@stuff)
                                    (dotimes (index (length seq))
                                           (let ((elt (aref seq index)))
                                                ,@stuff))))))
               (write-op handle 'fasl-dcode)
               (dump-value handle (length (d-assem::dcode-name-table dcode))
                      remember)
               (let* ((code-array (d-assem::dcode-code-array dcode))
                      (nbytes (length code-array)))
                     (dump-value handle nbytes remember)
                     (dotimes (i nbytes)
                            (il:bout stream (aref code-array i))))
               (dump-seq (d-assem::dcode-name-table dcode)
                      nil
                      (il:bout stream (first elt))
                      (dump-value handle (second elt)
                             remember)
                      (dump-value handle (third elt)
                             remember))
               (dump-value handle (d-assem::dcode-frame-name dcode)
                      remember)
               (il:bout stream (d-assem::dcode-nlocals dcode))
               (il:bout stream (d-assem::dcode-nfreevars dcode))
               (il:bout stream (d-assem::dcode-arg-type dcode))
               (dump-value handle (d-assem::dcode-num-args dcode)
                      remember)
               (dump-value handle (d-assem::dcode-closure-p dcode)
                      remember)
               (dump-value handle (d-assem::dcode-debugging-info dcode)
                      remember)
               (macrolet ((dump-fixups (list)
                                 `(dump-seq ,list t (dump-value handle (first elt))
                                         (dump-value handle (second elt)))))
                      (dump-fixups (d-assem::dcode-fn-fixups dcode))
                      (dump-fixups (d-assem::dcode-sym-fixups dcode))
                      (dump-fixups (d-assem::dcode-lit-fixups dcode))
                      (dump-fixups (d-assem::dcode-type-fixups dcode))))
        nil))


(defun dump-string
 (handle string remember)
   (remember string (let ((stream (handle-stream handle))
                          (nchars (length string)))
                         (cond
                            ((fat-string-p string)
                             (write-op handle 'fasl-fat-string)
                             (dump-value handle nchars remember)
                             (do ((i 0 (1+ i))
                                  (cset 0))
                                 ((>= i nchars))             (il:* il:\; "Always run-encode")

                                 (let* ((char (char-code (char string i)))
                                        (new-cset (il:lrsh char 8)))
                                       (unless (eql new-cset cset)
                                              (setq cset new-cset)
                                              (il:bout stream 255)
                                              (il:bout stream cset))
                                       (il:bout stream (logand char 255)))))
                            (t (write-op handle 'fasl-thin-string)
                               (dump-value handle nchars remember)
                                                             (il:* il:|;;| "should use \\bouts")

                               (dotimes (i nchars)
                                      (il:bout stream (char-code (char string i)))))))))


(defun dump-float32
 (handle number remember)                 (il:* il:\; 

                                                             "Floats don't get remembered")

   (write-op handle 'fasl-float32)
   (il:\\bouts (handle-stream handle)
          number 0 4))


(defun open-fasl-handle
 (name &rest open-options) (let ((stream (apply #'open name :direction :output 
                                                                       open-options)))
                                                       (il:setfileptr stream 0)
                                                       (il:bout stream signature)
                                                       (il:bout16 stream current-version)
                                                       (make-handle :stream stream)))


(defmacro with-open-handle
 ((handle filename &rest open-options)
                            &body
                            (body decls)) (let ((abort (il:gensym "FASL:WITH-OPEN-FASL-HANDLE")))
                                               `(let ((,handle (open-fasl-handle ,filename
                                                                      ,@open-options))
                                                      (,abort t))
                                                     ,@decls
                                                     (unwind-protect (multiple-value-prog1
                                                                      (progn ,@body)
                                                                      (setq ,abort nil))
                                                            (when ,handle (close-fasl-handle
                                                                           ,handle :abort
                                                                           ,abort))))))


(defun begin-text
 (handle) (state-case ((:text :block-end))
                                  (:block (end-block handle)))
                           (setf (handle-state handle)
                                 :text)
                           (handle-stream handle))


(defun begin-block
 (handle) (state-case (:block-end (begin-text handle)
                                               (end-text handle))
                                   (:text (end-text handle))
                                   (:block)))


(defun value-dumpable-p
 (obj) (xcl:condition-case (progn (dump-value dummy-handle obj nil)
                                                         t)
                                     (object-not-dumpable nil nil)))


(defun dump-value
 (handle value &optional (remember t)
                         &aux index) (state-case (:block (cond
                                                            ((eq value nil)
                                                             (write-op handle 'fasl-nil))
                                                            ((eq value t)
                                                             (write-op handle 'fasl-t))
                                                            ((prog1 (setq index (lookup-value handle 
                                                                                       value))
                                                                    (when *gather-dumper-stats*
                                                                          (incf *table-attempts*)))
                                                             (when *gather-dumper-stats* (incf 
                                                                                         *table-hits*
                                                                                               ))
                                                             (dump-value-fetch handle index))
                                                            (t (typecase value
                                                                      (integer (dump-integer handle 
                                                                                      value remember)
                                                                             )
                                                                      (rational (dump-rational handle 
                                                                                       value remember
                                                                                       ))
                                                                      (single-float (dump-float32
                                                                                     handle value 
                                                                                     remember))
                                                                      (complex (dump-complex handle 
                                                                                      value remember)
                                                                             )
                                                                      (character (dump-character
                                                                                  handle value 
                                                                                  remember))
                                                                      (symbol (dump-symbol handle 
                                                                                     value remember))
                                                                      (package (dump-package handle 
                                                                                      value remember)
                                                                             )
                                                                      (cons (dump-list handle value 
                                                                                   remember))
                                                                      (d-assem:dcode (dump-dcode
                                                                                      handle value 
                                                                                      remember))
                                                                      (string (dump-string handle 
                                                                                     value remember))
                                                                      (array (dump-array handle value 
                                                                                    remember))
                                                                      (compiler::eval-when-load
                                                                       (dump-eval handle (
                                                                        compiler::eval-when-load-form
                                                                                          value)))
                                                                      (otherwise (error '
                                                                                  object-not-dumpable 
                                                                                        :object value
                                                                                        ))))))))


(defun dump-function-def
 (handle dcode name) (state-case (:block (write-op handle '
                                                                        fasl-setf-symbol-function)
                                                                (dump-value handle name)
                                                                (dump-value handle dcode))))


(defun dump-funcall
 (handle function) (state-case (:block (write-op handle 'fasl-funcall)
                                                         (dump-value handle function))))


(defun dump-eval
 (handle form) (state-case (:block (write-op handle 'fasl-eval)
                                                  (dump-value handle form))))


(defun close-fasl-handle
 (handle &rest close-options &key abort &allow-other-keys)
   (state-case (:text (end-text handle)
                      (end-block handle))
          (:block (end-block handle))
          (:block-end))
   (setf (handle-state handle)
         :closed)
   (apply #'close (handle-stream handle)
          close-options))




(il:* il:|;;;| "Reader.")



(xcl:def-define-type fasl-ops
 "FASL file opcodes" )


(defstruct (optable
 (:constructor new-optable)) vector opnames next)


(defun make-optable
 nil (let ((table (new-optable))
                              (vector (make-array 256 :initial-element 'unimplemented-opcode)))
                             (setf (optable-vector table)
                                   vector)
                             (setf (svref vector end-mark)
                                   'fasl-end-of-block)
                             table))


(defun fasl-end-of-block
 (stream op) (if (zerop *block-level*)
                                         (throw 'fasl-block-finished nil)
                                         (error 'unexpected-end-of-block :stream stream)))


(xcl:defdefiner defop
 fasl-ops (il:name (opcode &key (indirect 0)
                                               (table '*default-optable*))
                                      &body
                                      (body decls doc))
                            (if (zerop indirect)
                                `(progn (defun (il:\\\,
 il:name) (stream opcode) ,(or doc 
                                                                         "FASL opcode implementation"
                                                                                      ) ,@decls
                                                                                       ,@body)

                                        (setf (elt (optable-vector ,table)
                                                   ,opcode)
                                              ',il:name)
                                        (add-op-translation ',il:name ,opcode ,table))
                                `(progn (unless (optable-next ,table)
                                               (setf (optable-next ,table)
                                                     (make-optable))
                                               (setescape ,table))
                                        (defop (il:\\\,
 il:name) (,opcode :indirect
                                                                        ,(1- indirect) :table
                                                                        (optable-next ,table))
                                           ,(or doc "FASL opcode implementation") ,@decls
                                                 ,@body)
)))


(xcl:defdefiner defrange

   fasl-ops (il:name (first-opcode &key (indirect 0)
                            (table '*default-optable*))
                   range offset &body (body decls doc))
         (if (zerop indirect)
             `(progn (defun (il:\\\,
 il:name) (stream opcode) ,(or doc "FASL opcode implementation")
                                                              ,@decls
                                                              ,@body)

                     (let ((package (symbol-package ',il:name))
                           (pname (symbol-name ',il:name)))
                          (dotimes (i ,range)
                                 (let ((opcode (+ i ,first-opcode)))
                                      (setf (elt (optable-vector ,table)
                                                 opcode)
                                            ',il:name)
                                      (add-op-translation (intern (concatenate
                                                                   'string pname
                                                                   (write-to-string
                                                                    (+ i ,offset)))
                                                                 package)
                                             opcode
                                             ,table)))))
             `(progn (unless (optable-next ,table)
                            (setf (optable-next ,table)
                                  (make-optable))
                            (setescape ,table))
                     (defrange (il:\\\,
 il:name) (,first-opcode :indirect ,(1- indirect) :table
                                                        (optable-next ,table)) ,(or doc 
                                                                         "FASL opcode implementation"
                                                                                    ) ,@decls
                                                                                     ,@body)
)))


(defun add-op-translation
 (name opcode table) (let ((pair (assoc name (optable-opnames table))))
                                                   (if pair (setf (cdr pair)
                                                                  opcode)
                                                       (push (cons name opcode)
                                                             (optable-opnames table)))))


(defun opcode-sequence
 (opname &optional (table *default-optable*)
                              &aux entry) (cond
                                             ((null table)
                                              nil)
                                             ((setq entry (assoc opname (optable-opnames table)))
                                              (list (cdr entry)))
                                             ((setq entry (opcode-sequence opname (optable-next
                                                                                   table)))
                                              (cons fasl-extended entry))
                                             (t nil)))


(defun fasl-extended
 (stream op) (with-optable (optable-next *current-optable*)
                                        (do-op stream)))


(defun setescape
 (table) (setf (svref (optable-vector table)
                                      fasl-extended)
                               #'fasl-extended))


(defun unimplemented-opcode
 (stream opcode) (error 'unimplemented-opcode :opname opcode))


(defvar *default-optable*
 (make-optable) )


(defvar *current-optable*
 nil)


(defparameter initial-value-table-size
 2048)


(defconstant value-table-increment
 1024)


(defvar *value-table*
 nil)


(defvar *block-level*
 0)


(defvar debug-reader
 nil)


(defvar debug-stream
 nil)


(defmacro with-optable
 (table &body body) `(let ((*current-optable* ,table))
                                                ,@body))


(defun process-file
 (stream &key (text-fn #'(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."
   (unless (eql (il:bin stream)
                signature)
          (error "Not a FASL file."))
   (check-version stream)
   (do nil ((il:eofp stream)
            (values))
       (process-segment stream text-fn item-fn)))


(defun check-version
 (stream) (let ((version (il:bin16 stream)))
                                   (or (and (<= (car version-range)
                                             version)
                                            (<= version (cdr version-range)))
                                       (error "Version not supported: ~D." version))))


(defun process-segment
 (stream &optional text-fn item-fn (optable *default-optable*))
   (if text-fn (funcall text-fn (read-text stream))
       (skip-text stream))
   (process-block stream item-fn optable))


(defun read-text
 (stream) (do ((result (make-array 512 :element-type 'character :adjustable t 
                                              :fill-pointer 0))
                               (byte (il:bin stream)
                                     (il:bin stream)))
                              ((eql byte end-mark)
                               (coerce result 'string))
                              (vector-push-extend (code-char byte)
                                     result)))


(defun process-block
 (stream &optional item-fn (optable *default-optable*))
   (catch 'fasl-block-finished (with-optable optable (do ((*value-table* (new-value-table))
                                                          val)
                                                         nil
                                                         (setf val (do-op stream 0))
                                                         (when item-fn (funcall item-fn val))))))


(defun skip-text
 (stream) (do ((byte (il:bin stream)))
                              ((eql byte end-mark)
                               (values))))


(defmacro next-value
 nil '(do-op stream))


(defun do-op
 (stream &optional (*block-level* (1+ *block-level*)))
   (let ((op (il:bin stream))
         val)
        (when debug-reader (format debug-stream "~VT~A (~3O)~%" (* *block-level* 4)
                                  (car (rassoc op (optable-opnames *current-optable*)))
                                  op))
        (setq val (funcall (svref (optable-vector *current-optable*)
                                  op)
                         stream op))
        (when debug-reader (format debug-stream "~VTValue: ~S~%" (* *block-level* 4)
                                  val))
        (return-from do-op val)))


(defun new-value-table
 nil (make-array initial-value-table-size :fill-pointer 0 :extendable t))


(defun clear-table
 (&optional (table *value-table*)) (setf (fill-pointer table)
                                                           0))


(defun store-value
 (obj &optional (table *value-table*))     (il:* il:|;;| 

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

   (vector-push-extend obj table value-table-increment)
   obj)


(defun fetch-value
 (index &optional (table *value-table*)) (aref table index))


(defun collect-list
 (stream nelts dotted) (if (and dotted (eql nelts 2))
                                              (return-from collect-list (cons (do-op stream)
                                                                              (do-op stream))))
                                          (when dotted (decf nelts))
                                          (let ((result (il:|to|
 nelts il:|collect|
 (do-op stream))))
                                                             (il:* il:|;;| 

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

                                               (when dotted (setf (cdr (last result))
                                                                  (do-op stream)))
                                               (return-from collect-list result)))


(defrange fasl-short-integer
 (0) 128 0 opcode)


(defop fasl-nil
 (128) nil)


(defop fasl-t
 (129) t)


(defop fasl-integer
 (130) (+ (il:llsh (il:bin stream)
                                    24)
                             (il:llsh (il:bin stream)
                                    16)
                             (il:llsh (il:bin stream)
                                    8)
                             (il:bin stream)))


(defop fasl-large-integer
 (131) (let ((nbytes (next-value))
                                      (first-time t)
                                      (mask 0))
                                     (do ((offset (* (1- nbytes)
                                                     8)
                                                 (- offset 8))
                                          (result 0)
                                          byte)
                                         ((< offset 0)
                                          (if (zerop mask)
                                              result
                                              (- (1+ result))))
                                         (setf byte (il:bin stream))
                                         (when first-time (setf first-time nil)
                                               (when (> byte 127)
                                                     (setq mask 255)))
                                         (setf (ldb (byte 8 offset)
                                                    result)
                                               (logxor byte mask)))))


(defop fasl-ratio
 (134) (/ (next-value)
                           (next-value)))


(defop fasl-complex
 (135) (complex (next-value)
                                 (next-value)))


(defop fasl-vector
 (136) (let* ((nelts (next-value))
                                (vector (make-array nelts :initial-element nil)))
                               (dotimes (i nelts vector)
                                      (setf (aref vector i)
                                            (next-value)))))


(defop fasl-create-array
 (137) (apply #'make-array (next-value)
                                      (next-value)))


(defop fasl-initialize-array
 (138) (let* ((array (next-value))
                                          (indirect (il:%flatten-array array))
                                          (nelts (next-value)))
                                         (dotimes (i nelts array)
                                                (setf (aref indirect i)
                                                      (next-value)))))


(defop fasl-initialize-bit-array
 (139)
   (let* ((array (do-op stream))
          (base (il:%array-base array))
          (nbits (do-op stream)))
         (multiple-value-bind (nbytes leftover)
                (floor nbits 8)
                (unless (zerop leftover)
                       (do* ((initial (* nbytes 8))
                             (indirect (il:%flatten-array array))
                             (last-byte (il:bin stream))
                             (i 0 (1+ i)))
                            ((= i leftover))
                            (setf (bit indirect (+ initial i))
                                  (let ((bs (byte 1 (- 7 i))))
                                       (ldb bs last-byte)))))
                array)))


(defop fasl-thin-string
 (140) (let* ((nchars (next-value))
                                     (string (il:allocstring nchars)))
                                    (il:\\bins stream (il:fetch
 (il:stringp il:base) il:of
 string)
                                           0 nchars)
                                    string))


(defop fasl-fat-string
 (141) (let* ((nchars (next-value))
                                    (string (il:allocstring nchars)))
                                   (il:charset stream 0)
                                   (unwind-protect (dotimes (i nchars string)
                                                          (setf (svref string i)
                                                                (code-char (il:readccode stream))))
                                          (il:charset stream 0))))


(defop fasl-character
 (142) (let ((code (il:bin stream)))
                                 (code-char (if (eql code 255)
                                                (il:bin16 stream)
                                                code))))


(defop fasl-lisp-symbol
 (143) (intern (next-value)
                                     (find-package "LISP")))


(defop fasl-keyword-symbol
 (144) (intern (next-value)
                                        (find-package "KEYWORD")))


(defop fasl-find-package
 (145) (find-package (next-value)))


(defop fasl-symbol-in-package
 (146) (let* ((pname (next-value))
                                           (package (next-value)))
                                          (if (null package)
                                              (make-symbol pname)
                                              (intern pname package))))


(defop fasl-list
 (147) (collect-list stream (next-value)
                              nil))


(defop fasl-list*
 (148) (collect-list stream (next-value)
                               t))


(defop fasl-interlisp-symbol
 (149) (intern (next-value)
                                          (find-package "INTERLISP")))


(defop fasl-dcode
 (150)                                      (il:* il:|;;;| "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 unaviodable performance requirements, this code duplicates D-ASSEM:INTERN-DCODE. If you make a change here, you should probably change the corresponding code there.")

   (let ((overheadbytes (* (il:fetch
 (il:fnheader il:overheadwords) il:of
 t)
                           il:bytesperword))
         nt-count raw-code start-pc closure-info)
        (setf nt-count (next-value))
        (let ((code-len (next-value)))
             (multiple-value-setq (raw-code start-pc)
                    (d-assem:allocate-code-block nt-count code-len))
             (il:\\bins stream raw-code start-pc code-len)
             (il:replace
 (il:fnheader il:startpc) il:of
 raw-code il:with
 start-pc))
                                                             (il:* il:|;;| 

                                                        "Set up the free variable lookup name table.")

        (do* ((i 0 (1+ i))
              (index overheadbytes (+ index il:bytesperword))(il:* il:|;;| 

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

              (ntsize (il:ceil (1+ nt-count)
                             il:wordsperquad))
              (ntbytesize (* ntsize il:bytesperword))
              pfi offset name fvaroffset)
             ((>= i nt-count)
              (il:replace
 (il:fnheader il:fvaroffset) il:of
 raw-code il:with
 (or fvaroffset 0))
              (il:replace
 (il:fnheader il:ntsize) il:of
 raw-code il:with
 ntsize))
             (setf pfi (il:bin stream))
             (setf offset (next-value))
             (setf name (next-value))
             (d-assem:fixup-word raw-code index (il:\\loloc name))
             (d-assem:fixup-word raw-code (+ index ntbytesize)
                    (+ (il:llsh pfi 14)
                       offset))
             (when (and (null fvaroffset)
                        (= pfi d-assem:+fvar-code+))
                   (setf fvaroffset (floor index il:bytesperword))))
                                                             (il:* il:|;;| 

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

        (let ((frame-name (next-value)))
             (il:uninterruptably
                 (il:\\addref frame-name)
                 (il:replace
 (il:fnheader il:\#framename) il:of
 raw-code il:with
 frame-name)))
        (let ((nlocals (il:bin stream))
              (nfreevars (il:bin stream)))
             (il:replace
 (il:fnheader il:nlocals) il:of
 raw-code il:with
 nlocals)
             (il:replace
 (il:fnheader il:pv) il:of
 raw-code il:with
 (1- (ceiling (+ nlocals nfreevars
                                                                                    )
                                                                               il:cellsperquad))))
        (il:replace
 (il:fnheader il:argtype) il:of
 raw-code il:with
 (il:bin stream))
        (il:replace
 (il:fnheader il:na) il:of
 raw-code il:with
 (next-value))
        (setf closure-info (next-value))
        (il:replace
 (il:fnheader il:closurep) il:of
 raw-code il:with
 (eq closure-info :closure))
        (il:replace
 (il:fnheader il:fixed) il:of
 raw-code il:with
 t)
                                                             (il:* il:|;;| "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?")

        (d-assem:fixup-ptr raw-code (- start-pc 3)
               (next-value))                                 (il:* il:|;;| "Do fixups")

        (do ((fn-fixup-count (next-value))
             (i 0 (1+ i))
             offset value)
            ((>= i fn-fixup-count))
            (setf offset (next-value))
            (setf value (next-value))
            (d-assem:fixup-word raw-code (+ start-pc offset)
                   (il:\\loloc value)))
        (do ((sym-fixup-count (next-value))
             (i 0 (1+ i))
             offset value)
            ((>= i sym-fixup-count))
            (setf offset (next-value))
            (setf value (next-value))
            (d-assem:fixup-word raw-code (+ start-pc offset)
                   (il:\\loloc value)))
        (do ((lit-fixup-count (next-value))
             (i 0 (1+ i))
             offset value)
            ((>= i lit-fixup-count))
            (setf offset (next-value))
            (setf value (next-value))
            (d-assem:fixup-ptr raw-code (+ start-pc offset)
                   value))
        (do ((type-fixup-count (next-value))
             (i 0 (1+ i))
             offset value)
            ((>= i type-fixup-count))
            (setf offset (next-value))
            (setf value (next-value))
            (d-assem:fixup-word raw-code (+ start-pc offset)
                   (il:\\resolve.typenumber value)))         (il:* il:|;;| 

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

        (if (eq closure-info :function)
            (il:make-compiled-closure raw-code nil)
            raw-code)))


(defop fasl-table-store
 (152) (store-value (next-value)))


(defop fasl-table-fetch
 (153) (fetch-value (next-value)))


(defop fasl-verify-table-size
 (154) (let ((expected (next-value)))
                                         (or (eql expected (length *value-table*))
                                             (error 'inconsistent-table :table *value-table* 
                                                    :expected expected))))


(defop fasl-eval
 (155) (eval (next-value)))


(defop fasl-float32
 (132) (let ((result (il:ncreate 'il:floatp)))
                               (il:\\bins stream result 0 4)
                               result))


(defop fasl-setf-symbol-function
 (156) (setf (symbol-function (next-value))
                                             (next-value)))


(defop fasl-funcall
 (157) (funcall (next-value)))




(il:* il:|;;| "Arrange for the correct compiler to be used")



(il:putprops il:fasl il:filetype
 compile-file)



(il:* il:|;;| "Arrange for the proper makefile environment")



(il:putprops il:fasl il:makefile-environment
 (:readtable "XCL" :package "FASL"))
(il:putprops il:fasl il:copyright ("Xerox Corporation" 1986))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop