home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / load.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  33.7 KB  |  1,090 lines
  1. ;;; -*- Log: code.log; Package: Lisp -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: load.lisp,v 1.39 92/02/22 00:09:10 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Loader for Spice Lisp.
  15. ;;; Written by Skef Wholey and Rob MacLachlan.
  16. ;;;
  17. (in-package "LISP")
  18. (export '(load *load-verbose* *load-print* *load-truename* *load-pathname*))
  19.  
  20. (in-package "EXTENSIONS")
  21. (export '(*load-if-source-newer* *load-source-types* *load-object-types*))
  22.  
  23. (in-package "SYSTEM")
  24. (export 'foreign-symbol-address)
  25.  
  26. (in-package "LISP")
  27.  
  28.  
  29. ;;;; Variables:
  30.  
  31. ;;; Public:
  32.  
  33. (defvar *load-if-source-newer* :load-object
  34.   "The default for the :IF-SOURCE-NEWER argument to load."))
  35.  
  36. (declaim (type (member :load-object :load-source :query :compile)
  37.            *load-if-source-newer*))
  38.  
  39. (defvar *load-source-types* '("lisp" "l" "cl" "lsp" nil)
  40.   "The source file types which LOAD recognizes.")
  41.  
  42. (defvar *load-object-types*
  43.   '(#.(c:backend-fasl-file-type c:*backend*) "fasl")
  44.   "A list of the object file types recognized by LOAD.")
  45.  
  46. (declaim (list *load-source-types* *load-object-types*))
  47.  
  48. (defvar *load-verbose* t
  49.   "The default for the :VERBOSE argument to Load.")
  50.  
  51. (defvar *load-print* ()
  52.   "The default for the :PRINT argument to Load.")
  53.  
  54. (defvar *load-truename* nil
  55.   "The TRUENAME of the file that LOAD is currently loading.")
  56.  
  57. (defvar *load-pathname* nil
  58.   "The defaulted pathname that LOAD is currently loading.")
  59.  
  60. (declaim (type (or pathname null) *load-truename* *load-pathname*)) 
  61.  
  62.  
  63. ;;; Internal state variables:
  64.  
  65. (defvar *load-depth* 0
  66.   "Count of the number of recursive loads.")
  67. (defvar *fasl-file* ()
  68.   "The fasl file we're reading from.")
  69. (defvar *current-code-format*
  70.   "The code format that we think we are loading.")
  71.  
  72.  
  73. ;;; LOAD-FRESH-LINE -- internal.
  74. ;;;
  75. ;;; Output the corrent number of semicolons after a fresh-line.
  76. ;;; 
  77. (defconstant semicolons ";;;;;;;;;;;;;;;;")
  78. ;;;
  79. (defun load-fresh-line ()
  80.   (fresh-line)
  81.   (do ((count *load-depth* (- count (length semicolons))))
  82.       ((< count (length semicolons))
  83.        (unless (zerop count)
  84.      (write-string semicolons *standard-output* :end count)))
  85.     (write-string semicolons))
  86.   (write-char #\space))
  87.  
  88.  
  89. ;;;; The Fop-Table:
  90. ;;;
  91. ;;;    The table is implemented as a simple-vector indexed by the table
  92. ;;; offset.  We may need to have several, since load can be called recursively.
  93.  
  94. (defvar *free-fop-tables* (list (make-array 1000))
  95.   "List of free fop tables for the fasloader.")
  96.  
  97. (defvar *current-fop-table* ()
  98.   "The current fop table.")
  99.  
  100. (defvar *current-fop-table-size* ()
  101.   "The length of the current fop table.")
  102.  
  103. (defvar *current-fop-table-index* ()
  104.   "Index in the fop-table of the next entry to be used.")
  105.  
  106. (defun grow-fop-table ()
  107.   (let* ((new-size (* *current-fop-table-size* 2))
  108.      (new-table (make-array new-size)))
  109.     (declare (fixnum new-size) (simple-vector new-table))
  110.     (replace new-table (the simple-vector *current-fop-table*))
  111.     (setq *current-fop-table* new-table)
  112.     (setq *current-fop-table-size* new-size)))
  113.  
  114. (defmacro push-table (thing)
  115.   (let ((n-index (gensym)))
  116.     `(let ((,n-index *current-fop-table-index*))
  117.        (declare (fixnum ,n-index))
  118.        (when (= ,n-index (the fixnum *current-fop-table-size*))
  119.      (grow-fop-table))
  120.        (setq *current-fop-table-index* (1+ ,n-index))
  121.        (setf (svref *current-fop-table* ,n-index) ,thing))))
  122.  
  123. ;;;; The Fop-Stack:
  124. ;;;
  125. ;;;  The is also in a simple-vector, but it grows down, since it is somewhat 
  126. ;;; cheaper to test for overflow that way.
  127. ;;;
  128. (defvar *fop-stack* (make-array 100)
  129.   "The fop stack (we only need one!).")
  130.  
  131. (defvar *fop-stack-pointer* 100
  132.   "The index of the most recently pushed item on the fop-stack.")
  133.  
  134. (defvar *fop-stack-pointer-on-entry* ()
  135.   "The current index into the fop stack when we last recursively entered LOAD.")
  136.  
  137.  
  138. (defun grow-fop-stack ()
  139.   (let* ((size (length (the simple-vector *fop-stack*)))
  140.      (new-size (* size 2))
  141.      (new-stack (make-array new-size)))
  142.     (declare (fixnum size new-size) (simple-vector new-stack))
  143.     (replace new-stack (the simple-vector *fop-stack*) :start1 size)
  144.     (incf *fop-stack-pointer-on-entry* size)
  145.     (setq *fop-stack-pointer* size)
  146.     (setq *fop-stack* new-stack)))
  147.  
  148. ;;; With-Fop-Stack  --  Internal
  149. ;;;
  150. ;;;    Cache information about the fop-stack in local variables.  Define
  151. ;;; a local macro to pop from the stack.  Push the result of evaluation if
  152. ;;; specified.
  153. ;;;
  154. (defmacro with-fop-stack (pushp &body forms)
  155.   (let ((n-stack (gensym))
  156.     (n-index (gensym))
  157.     (n-res (gensym)))
  158.     `(let ((,n-stack *fop-stack*)
  159.        (,n-index *fop-stack-pointer*))
  160.        (declare (simple-vector ,n-stack) (fixnum ,n-index))
  161.        (macrolet ((pop-stack ()
  162.             `(prog1
  163.               (svref ,',n-stack ,',n-index)
  164.               (setq ,',n-index (1+ ,',n-index))))
  165.           (call-with-popped-things (fun n)
  166.             (let ((n-start (gensym)))
  167.               `(let ((,n-start (+ ,',n-index ,n)))
  168.              (setq ,',n-index ,n-start)
  169.              (,fun ,@(make-list n :initial-element
  170.                         `(svref ,',n-stack
  171.                             (decf ,n-start))))))))
  172.      ,(if pushp
  173.           `(let ((,n-res (progn ,@forms)))
  174.          (when (zerop ,n-index)
  175.            (grow-fop-stack)
  176.            (setq ,n-index *fop-stack-pointer*
  177.              ,n-stack *fop-stack*))
  178.          (decf ,n-index)
  179.          (setq *fop-stack-pointer* ,n-index)
  180.          (setf (svref ,n-stack ,n-index) ,n-res))
  181.           `(prog1
  182.         (progn ,@forms)
  183.         (setq *fop-stack-pointer* ,n-index)))))))
  184.  
  185. ;;; FOP database:
  186.  
  187. (defvar fop-codes (make-array 256)
  188.   "Vector indexed by a FaslOP that yields the FOP's name.")
  189.  
  190. (defvar fop-functions
  191.   (make-array 256 :initial-element #'(lambda () (error "Losing FOP!")))
  192.   "Vector indexed by a FaslOP that yields a function of 0 arguments which
  193.   will perform the operation.")
  194.  
  195.  
  196. ;;; Define-FOP  --  Internal
  197. ;;;
  198. ;;;    Defines Name as a fasl operation, with op-code op.  If pushp is :nope,
  199. ;;; the the body neither pushes or pops the fop stack.  If it is nil, then
  200. ;;; the body may pop, but the result is ignored.  If it is true, the the result
  201. ;;; is pushed on the stack.
  202. ;;;
  203. (defmacro define-fop ((name op &optional (pushp t)) &rest forms)
  204.   `(progn
  205.     (defun ,name ()
  206.       ,(if (eq pushp :nope)
  207.        `(progn ,@forms)
  208.        `(with-fop-stack ,pushp ,@forms)))
  209.     (setf (svref fop-codes ,op) ',name)
  210.     (setf (get ',name 'fop-code) ,op)
  211.     (setf (svref fop-functions ,op) #',name)))
  212.  
  213. ;;; Clone-Fop  --  Internal
  214. ;;;
  215. ;;;    Defines a pair of fops which are identical except in that one reads
  216. ;;; a four byte argument and the other reads a one byte argument.  The
  217. ;;; argument can be accessed by using the Clone-Arg macro.
  218. ;;;
  219. (defmacro clone-fop ((name op &optional (pushp t))
  220.               (small-name small-op) &rest forms)
  221.   `(progn
  222.     (macrolet ((clone-arg () '(read-arg 4)))
  223.       (define-fop (,name ,op ,pushp) ,@forms))
  224.     (macrolet ((clone-arg () '(read-arg 1)))
  225.       (define-fop (,small-name ,small-op ,pushp) ,@forms))))
  226.  
  227. ;;;; Utilities for reading from the fasl file.
  228.  
  229. (proclaim '(inline read-byte))
  230.  
  231. ;;; Fast-Read-U-Integer  --  Internal
  232. ;;;
  233. ;;;    Expands into code to read an N-byte unsigned integer using
  234. ;;; fast-read-byte.
  235. ;;;
  236. (defmacro fast-read-u-integer (n)
  237.   (do ((res '(fast-read-byte)
  238.         `(logior (fast-read-byte)
  239.              (ash ,res 8)))
  240.        (cnt 1 (1+ cnt)))
  241.       ((>= cnt n) res)))
  242.  
  243. ;;; Fast-Read-Variable-U-Integer  --  Internal
  244. ;;;
  245. ;;;    Like Fast-Read-U-Integer, but the size may be determined at run time.
  246. ;;;
  247. (defmacro fast-read-variable-u-integer (n)
  248.   (let ((n-pos (gensym))
  249.     (n-res (gensym))
  250.     (n-cnt (gensym)))
  251.     `(do ((,n-pos 8 (+ ,n-pos 8))
  252.       (,n-cnt (1- ,n) (1- ,n-cnt))
  253.       (,n-res
  254.        (fast-read-byte)
  255.        (dpb (fast-read-byte) (byte 8 ,n-pos) ,n-res)))
  256.      ((zerop ,n-cnt) ,n-res))))
  257.  
  258. ;;; Fast-Read-S-Integer  --  Internal
  259. ;;;
  260. ;;;    Read a signed integer.
  261. ;;;
  262. (defmacro fast-read-s-integer (n)
  263.   (let ((n-last (gensym)))
  264.     (do ((res `(let ((,n-last (fast-read-byte)))
  265.          (if (zerop (logand ,n-last #x80))
  266.              ,n-last
  267.              (logior ,n-last #x-100)))
  268.           `(logior (fast-read-byte)
  269.                (ash ,res 8)))
  270.      (cnt 1 (1+ cnt)))
  271.     ((>= cnt n) res))))
  272.  
  273. ;;; Read-Arg  --  Internal
  274. ;;;
  275. ;;;    Read an N-byte unsigned integer from the *fasl-file*
  276. ;;;
  277. (defmacro read-arg (n)
  278.   (if (= n 1)
  279.       `(read-byte *fasl-file*)
  280.       `(prepare-for-fast-read-byte *fasl-file*
  281.      (prog1
  282.       (fast-read-u-integer ,n)
  283.       (done-with-fast-read-byte)))))
  284.  
  285. ;;; Fasload:
  286.  
  287. (defun do-load-verbose (stream)
  288.   (when *load-verbose*
  289.     (load-fresh-line)
  290.     (let ((name (file-name stream)))
  291.       (if name
  292.       (format t "Loading ~S.~%" name)
  293.       (format t "Loading stuff from ~S.~%" stream)))))
  294.  
  295. (defun fasload (stream)
  296.   (when (zerop (file-length stream))
  297.     (error "Attempt to load an empty FASL FILE:~%  ~S" (namestring stream)))
  298.   (do-load-verbose stream)
  299.   (let* ((*fasl-file* stream)
  300.      (*current-fop-table* (pop *free-fop-tables*))
  301.      (*current-fop-table-size* ())
  302.      (*fop-stack-pointer-on-entry* *fop-stack-pointer*))
  303.     (if (null *current-fop-table*)
  304.     (setq *current-fop-table* (make-array 1000)))
  305.     (setq *current-fop-table-size*
  306.       (length (the simple-vector *current-fop-table*)))
  307.     (unwind-protect 
  308.       (do ((loaded-group (load-group stream) (load-group stream)))
  309.       ((not loaded-group)))
  310.       (setq *fop-stack-pointer* *fop-stack-pointer-on-entry*)
  311.       (push *current-fop-table* *free-fop-tables*)
  312.       ;;
  313.       ;; Nil out the stack and table, so we don't hold onto garbage.
  314.       (dotimes (i *fop-stack-pointer-on-entry*)
  315.     (declare (fixnum i))
  316.     (setf (svref *fop-stack* i) nil))
  317.       (let ((tab *current-fop-table*))
  318.     (dotimes (i (length tab))
  319.       (declare (fixnum i))
  320.       (setf (svref tab i) nil)))))
  321.   t)
  322.  
  323. #|
  324.  
  325. (defvar *fop-counts* (make-array 256 :initial-element 0))
  326. (defvar *fop-times* (make-array 256 :initial-element 0))
  327. (defvar *print-fops* nil)
  328.  
  329. (defun clear-counts ()
  330.   (fill (the simple-vector *fop-counts*) 0)
  331.   (fill (the simple-vector *fop-times*) 0)
  332.   t)
  333.  
  334. (defun analyze-counts ()
  335.   (let ((counts ())
  336.     (total-count 0)
  337.     (times ())
  338.     (total-time 0))
  339.     (macrolet ((breakdown (lvar tvar vec)
  340.          `(progn
  341.            (dotimes (i 255)
  342.              (declare (fixnum i))
  343.              (let ((n (svref ,vec i)))
  344.                (push (cons (svref fop-codes i) n) ,lvar)
  345.                (incf ,tvar n)))
  346.            (setq ,lvar (subseq (sort ,lvar #'(lambda (x y)
  347.                                (> (cdr x) (cdr y))))
  348.                        0 10)))))
  349.          
  350.       (breakdown counts total-count *fop-counts*)
  351.       (breakdown times total-time *fop-times*)
  352.       (format t "Total fop count is ~D~%" total-count)
  353.       (dolist (c counts)
  354.     (format t "~30S: ~4D~%" (car c) (cdr c)))
  355.       (format t "~%Total fop time is ~D~%" (/ (float total-time) 60.0))
  356.       (dolist (m times)
  357.     (format t "~30S: ~6,2F~%" (car m) (/ (float (cdr m)) 60.0))))))
  358. |#
  359.  
  360. ;;; Load-Group  --  Internal
  361. ;;;
  362. ;;; Load-Group returns t if it successfully loads a group from the file,
  363. ;;; or () if EOF was encountered while trying to read from the file.
  364. ;;; Dispatch to the right function for each fop.  Special-case fop-byte-push
  365. ;;; since it is real common.
  366. ;;;
  367. (defun load-group (file)
  368.   (when (check-header file)
  369.     (catch 'group-end
  370.       (let ((*current-code-format* nil)
  371.         (*current-fop-table-index* 0))
  372.     (loop
  373.       (let ((byte (read-byte file)))
  374.         (if (eql byte 3)
  375.         (let ((index *fop-stack-pointer*))
  376.           (when (zerop index)
  377.             (grow-fop-stack)
  378.             (setq index *fop-stack-pointer*))
  379.           (decf index)
  380.           (setq *fop-stack-pointer* index)
  381.           (setf (svref *fop-stack* index)
  382.             (svref *current-fop-table* (read-byte file))))
  383.         (funcall (svref fop-functions byte)))))))))
  384.  
  385.  
  386. ;;; Check-Header returns t if t succesfully read a header from the file,
  387. ;;; or () if EOF was hit before anything was read.  An error is signaled
  388. ;;; if garbage is encountered.
  389.  
  390. (defun check-header (file)
  391.   (let ((byte (read-byte file NIL '*eof*)))
  392.     (cond ((eq byte '*eof*) ())
  393.       ((eq byte (char-code #\F))
  394.        (do ((byte (read-byte file) (read-byte file))
  395.         (count 1 (1+ count)))
  396.            ((= byte 255) t)
  397.          (declare (fixnum byte))
  398.          (if (and (< count 9)
  399.               (not (eql byte (char-code (schar "FASL FILE" count)))))
  400.          (error "Bad FASL file format."))))
  401.       (t (error "Bad FASL file format.")))))
  402.  
  403.  
  404. ;;; Load-S-Integer loads a signed integer Length bytes long from the File.
  405.  
  406. (defun load-s-integer (length)  
  407.   (declare (fixnum length))
  408.   (do* ((index length (1- index))
  409.     (byte 0 (read-byte *fasl-file*))
  410.     (result 0 (+ result (ash byte bits)))
  411.     (bits 0 (+ bits 8)))
  412.        ((= index 0)
  413.     (if (logbitp 7 byte)    ; look at sign bit
  414.         (- result (ash 1 bits))
  415.         result))
  416.     (declare (fixnum index byte bits))))
  417.  
  418.  
  419. ;;; Sloload:
  420.  
  421. ;;; Something not EQ to anything read from a file:
  422.  
  423. (defconstant load-eof-value '(()))
  424.  
  425. ;;; Sloload loads a text file into the given Load-Package.
  426.  
  427. (defun sloload (stream)
  428.   (do-load-verbose stream)
  429.   (do ((sexpr (read stream nil load-eof-value)
  430.           (read stream nil load-eof-value)))
  431.       ((eq sexpr load-eof-value))
  432.     (if *load-print*
  433.     (let ((results (multiple-value-list (eval sexpr))))
  434.       (load-fresh-line)
  435.       (format t "~{~S~^, ~}~%" results))
  436.     (eval sexpr)))
  437.   t)
  438.  
  439.  
  440. ;;; LOAD  --  Public
  441. ;;;
  442. ;;;    This function mainly sets up special bindings and then calls
  443. ;;; sub-functions.  We conditionally bind the switches with PROGV so that
  444. ;;; people can set them in their init files and have the values take effect.
  445. ;;; If the compiler is loaded, we make the compiler-policy local to LOAD by
  446. ;;; binding it to itself.
  447. ;;;
  448. (defun load (filename &key (verbose nil verbose-p) (print nil print-p)
  449.               (if-source-newer nil if-source-newer-p)
  450.               (if-does-not-exist :error) contents)
  451.   "Loads the file named by Filename into the Lisp environment.  The file type
  452.    (a.k.a extension) is defaulted if missing.  These options are defined:
  453.  
  454.    :IF-SOURCE-NEWER <keyword>
  455.     If the file type is not specified, and both source and object files
  456.         exist, then this argument controls which is loaded:
  457.         :LOAD-OBJECT - load object file (default),
  458.         :LOAD-SOURCE - load the source file,
  459.         :COMPILE - compile the source and then load the object file, or
  460.         :QUERY - ask the user which to load.
  461.  
  462.    :IF-DOES-NOT-EXIST {:ERROR | NIL}
  463.        If :ERROR (the default), signal an error if the file can't be located.
  464.        If NIL, simply return NIL (LOAD normally returns T.)
  465.  
  466.    :VERBOSE {T | NIL}
  467.        If true (the default), print a line describing each file loaded.
  468.  
  469.    :PRINT {T | NIL}
  470.        If true, print information about loaded values.  When loading the
  471.        source, the result of evaluating each top-level form is printed.
  472.  
  473.    :CONTENTS {NIL | :SOURCE | :BINARY}
  474.        Forces the input to be interpreted as a source or object file, instead
  475.        of guessing based on the file type.  Probably only necessary if you have
  476.        source files with a \"fasl\" type.
  477.  
  478.    The variables *LOAD-VERBOSE*, *LOAD-PRINT* and EXT:*LOAD-IF-SOURCE-NEWER*
  479.    determine the defaults for the corresponding keyword arguments.  These
  480.    variables are also bound to the specified argument values, so specifying a
  481.    keyword affects nested loads.  The variables EXT:*LOAD-SOURCE-TYPES* and
  482.    EXT:*LOAD-OBJECT-TYPES* determine the file types that we use for defaulting
  483.    when none is specified."
  484.   (declare (type (or null (member :source :binary)) contents))
  485.   (collect ((vars)
  486.         (vals))
  487.     (macrolet ((frob (wot)
  488.          `(when ,(concat-pnames wot '-p)
  489.             (vars ',(intern (format nil "*LOAD-~A*" wot)))
  490.             (vals ,wot))))
  491.       (frob if-source-newer)
  492.       (frob verbose)
  493.       (frob print))
  494.  
  495.     (when (boundp 'c::*default-cookie*)
  496.       (vars 'c::*default-cookie* 'c::*default-interface-cookie*)
  497.       (vals c::*default-cookie* c::*default-interface-cookie*))
  498.  
  499.     (progv (vars) (vals)
  500.       (let ((*package* *package*)
  501.         (*readtable* *readtable*)
  502.         (*load-depth* (1+ *load-depth*)))
  503.     (values 
  504.      (with-simple-restart (continue "Return NIL from load of ~S." filename)
  505.        (if (streamp filename)
  506.            (if (or (eq contents :binary)
  507.                (and (null contents)
  508.                 (equal (stream-element-type filename)
  509.                    '(unsigned-byte 8))))
  510.            (fasload filename)
  511.            (sloload filename))
  512.            (let ((pn (merge-pathnames (pathname filename)
  513.                       *default-pathname-defaults*)))
  514.          (cond ((wild-pathname-p pn)
  515.             (dolist (file (directory pn) t)
  516.               (internal-load pn file if-does-not-exist contents)))
  517.                ((pathname-type pn)
  518.             (internal-load pn (probe-file pn) if-does-not-exist
  519.                        contents))
  520.                (t
  521.             (internal-load-default-type
  522.              pn if-does-not-exist)))))))))))
  523.  
  524.  
  525. ;;; INTERNAL-LOAD  --  Internal
  526. ;;;
  527. ;;;    Load the stuff in a file when we have got the name.
  528. ;;;
  529. (defun internal-load (pathname truename if-does-not-exist contents)
  530.   (unless truename
  531.     (return-from
  532.      internal-load
  533.      (ecase if-does-not-exist
  534.        (:error
  535.     (restart-case (error "~S does not exist." (namestring pathname))
  536.       (check-again () :report "See if it exists now."
  537.         (load pathname))
  538.       (use-value () :report "Prompt for a new name."
  539.         (write-string "New name: " *query-io*)
  540.         (force-output *query-io*)
  541.         (load (read-line *query-io*)))))
  542.        ((nil) nil))))
  543.  
  544.   (let ((*load-truename* truename)
  545.     (*load-pathname* pathname))
  546.     (case contents
  547.       (:source
  548.        (with-open-file (file truename
  549.                  :direction :input
  550.                  :if-does-not-exist if-does-not-exist)
  551.      (sloload file)))
  552.       (:binary
  553.        (with-open-file (file truename
  554.                  :direction :input
  555.                  :if-does-not-exist if-does-not-exist
  556.                  :element-type '(unsigned-byte 8))
  557.      (fasload file)))
  558.       (t
  559.        (let ((first-line (with-open-file (file truename :direction :input)
  560.                (read-line file nil))))
  561.      (cond
  562.       ((and first-line
  563.         (>= (length first-line) 9)
  564.         (string= first-line "FASL FILE" :end1 9))
  565.        (internal-load pathname truename if-does-not-exist :binary))
  566.       (t
  567.        (when (member (pathname-type truename) *load-object-types*
  568.              :test #'string=)
  569.          (cerror
  570.           "Load it as a source file."
  571.           "File has a fasl file type, but no fasl file header:~%  ~S"
  572.           (namestring truename)))
  573.        (internal-load pathname truename if-does-not-exist :source))))))))
  574.  
  575.  
  576. ;;; TRY-DEFAULT-TYPES  --  Internal
  577. ;;;
  578. (defun try-default-types (pathname types)
  579.   (dolist (type types (values nil nil))
  580.     (let* ((pn (make-pathname :type type :defaults pathname))
  581.        (tn (probe-file pn)))
  582.       (when tn (return (values pn tn))))))
  583.  
  584.  
  585. ;;; INTERNAL-LOAD-DEFAULT-TYPE  --  Internal
  586. ;;;
  587. ;;;    Handle the case of INTERNAL-LOAD where the file does not exist.
  588. ;;;
  589. (defun internal-load-default-type (pathname if-does-not-exist)
  590.   (multiple-value-bind
  591.       (src-pn src-tn)
  592.       (try-default-types pathname *load-source-types*)
  593.     (multiple-value-bind
  594.     (obj-pn obj-tn)
  595.     (try-default-types pathname *load-object-types*)
  596.       (cond
  597.        ((and obj-tn src-tn
  598.          (> (file-write-date src-tn) (file-write-date obj-tn)))
  599.     (ecase *load-if-source-newer*
  600.       (:load-object
  601.        (warn "Loading object file ~A,~@
  602.           which is older than the presumed source:~%  ~A."
  603.          (namestring obj-tn) (namestring src-tn))
  604.        (internal-load obj-pn obj-tn if-does-not-exist :binary))
  605.       (:load-source
  606.        (warn "Loading source file ~A,~@
  607.           which is newer than the presumed object file:~%  ~A."
  608.          (namestring src-tn) (namestring obj-tn))
  609.        (internal-load src-pn src-tn if-does-not-exist :source))
  610.       (:compile
  611.        (let ((obj-tn (compile-file src-pn)))
  612.          (unless obj-tn
  613.            (error "Compile of source failed, cannot load object."))
  614.          (internal-load src-pn obj-tn :error :binary)))
  615.       (:query
  616.        (restart-case
  617.            (error "Object file ~A is~@
  618.                older than the presumed source:~%  ~A."
  619.               (namestring obj-tn) (namestring src-tn))
  620.          (continue () :report "load source file"
  621.            (internal-load src-pn src-tn if-does-not-exist :source))
  622.          (load-object () :report "load object file"
  623.            (internal-load src-pn obj-tn if-does-not-exist :binary))))))
  624.        (obj-tn
  625.     (internal-load obj-pn obj-tn if-does-not-exist :binary))
  626.        (src-pn
  627.     (internal-load src-pn src-tn if-does-not-exist :source))
  628.        (t
  629.     (internal-load pathname nil if-does-not-exist nil))))))
  630.  
  631.  
  632. ;;;; Actual FOP definitions:
  633.  
  634. (define-fop (fop-nop 0 :nope))
  635. (define-fop (fop-pop 1 nil) (push-table (pop-stack)))
  636. (define-fop (fop-pop-for-effect 65 nil) (pop-stack))
  637. (define-fop (fop-push 2) (svref *current-fop-table* (read-arg 4)))
  638. (define-fop (fop-byte-push 3) (svref *current-fop-table* (read-arg 1)))
  639.  
  640. (define-fop (fop-empty-list 4) ())
  641. (define-fop (fop-truth 5) t)
  642. (define-fop (fop-misc-trap 66)
  643.         (%primitive make-other-immediate-type 0 vm:unbound-marker-type))
  644.  
  645. (define-fop (fop-character 68)
  646.   (code-char (read-arg 3)))
  647. (define-fop (fop-short-character 69)
  648.   (code-char (read-arg 1)))
  649.  
  650. (clone-fop (fop-struct 48)
  651.        (fop-small-struct 49)
  652.   (let* ((size (clone-arg))
  653.      (res (make-structure size)))
  654.     (declare (type index size))
  655.     (do ((n (1- size) (1- n)))
  656.     ((minusp n))
  657.       (declare (type (integer -1 #.most-positive-fixnum) n))
  658.       (setf (structure-ref res n) (pop-stack)))
  659.     res))
  660.  
  661. (define-fop (fop-end-group 64 :nope) (throw 'group-end t))
  662. (define-fop (fop-end-header 255)
  663.   (error "Fop-End-Header was executed???"))
  664.  
  665. ;;; In the normal loader, we just ignore these.  Genesis overwrites
  666. ;;; fop-maybe-cold-load with something that knows when to revert to
  667. ;;; cold-loading or not.
  668. ;;; 
  669. (define-fop (fop-normal-load 81 :nope))
  670. (define-fop (fop-maybe-cold-load 82 :nope))
  671.  
  672. (define-fop (fop-verify-table-size 62 :nope)
  673.   (if (/= *current-fop-table-index* (read-arg 4))
  674.       (error "Fasl table of improper size.  Bug!")))
  675. (define-fop (fop-verify-empty-stack 63 :nope)
  676.   (if (/= *fop-stack-pointer* *fop-stack-pointer-on-entry*)
  677.       (error "Fasl stack not empty.  Bug!")))
  678.  
  679. ;;;; Loading symbols:
  680.  
  681. (defvar *load-symbol-buffer* (make-string 100))
  682. (defvar *load-symbol-buffer-size* 100)
  683.    
  684. (macrolet ((frob (name code name-size package)
  685.          (let ((n-package (gensym))
  686.            (n-size (gensym))
  687.            (n-buffer (gensym)))
  688.            `(define-fop (,name ,code)
  689.           (prepare-for-fast-read-byte *fasl-file*
  690.             (let ((,n-package ,package)
  691.               (,n-size (fast-read-u-integer ,name-size)))
  692.               (when (> ,n-size *load-symbol-buffer-size*)
  693.             (setq *load-symbol-buffer*
  694.                   (make-string (setq *load-symbol-buffer-size*
  695.                          (* ,n-size 2)))))
  696.               (done-with-fast-read-byte)
  697.               (let ((,n-buffer *load-symbol-buffer*))
  698.             (read-n-bytes *fasl-file* ,n-buffer 0 ,n-size)
  699.             (push-table (intern* ,n-buffer ,n-size ,n-package)))))))))
  700.   (frob fop-symbol-save 6 4 *package*)
  701.   (frob fop-small-symbol-save 7 1 *package*)
  702.   (frob fop-lisp-symbol-save 75 4 *lisp-package*)
  703.   (frob fop-lisp-small-symbol-save 76 1 *lisp-package*)
  704.   (frob fop-keyword-symbol-save 77 4 *keyword-package*)
  705.   (frob fop-keyword-small-symbol-save 78 1 *keyword-package*)
  706.  
  707.   (frob fop-symbol-in-package-save 8 4
  708.     (svref *current-fop-table* (fast-read-u-integer 4)))
  709.   (frob fop-small-symbol-in-package-save 9 1
  710.     (svref *current-fop-table* (fast-read-u-integer 4)))
  711.   (frob fop-symbol-in-byte-package-save 10 4
  712.     (svref *current-fop-table* (fast-read-u-integer 1)))
  713.   (frob fop-small-symbol-in-byte-package-save 11 1
  714.     (svref *current-fop-table* (fast-read-u-integer 1))))
  715.  
  716. (clone-fop (fop-uninterned-symbol-save 12)
  717.        (fop-uninterned-small-symbol-save 13)
  718.   (let* ((arg (clone-arg))
  719.      (res (make-string arg)))
  720.     (read-n-bytes *fasl-file* res 0 arg)
  721.     (push-table (make-symbol res))))
  722.  
  723. (define-fop (fop-package 14)
  724.   (let ((name (pop-stack)))
  725.     (or (find-package name)
  726.     (error "The package ~S does not exist." name))))
  727.  
  728. ;;;; Loading numbers:
  729.  
  730. (clone-fop (fop-integer 33)
  731.        (fop-small-integer 34)
  732.   (load-s-integer (clone-arg)))
  733.  
  734. (define-fop (fop-word-integer 35)
  735.   (prepare-for-fast-read-byte *fasl-file*
  736.     (prog1
  737.      (fast-read-s-integer 4)
  738.      (done-with-fast-read-byte))))
  739. (define-fop (fop-byte-integer 36)
  740.   (prepare-for-fast-read-byte *fasl-file*
  741.     (prog1
  742.      (fast-read-s-integer 1)
  743.      (done-with-fast-read-byte))))
  744.  
  745. (define-fop (fop-ratio 70)
  746.   (let ((den (pop-stack)))
  747.     (%make-ratio (pop-stack) den)))
  748.  
  749. (define-fop (fop-complex 71)
  750.   (let ((im (pop-stack)))
  751.     (%make-complex (pop-stack) im)))
  752.  
  753. (define-fop (fop-single-float 46)
  754.   (make-single-float (load-s-integer 4)))
  755.  
  756. (define-fop (fop-double-float 47)
  757.   (let ((lo (ldb (byte 32 0) (load-s-integer 4))))
  758.     (make-double-float (load-s-integer 4) lo)))
  759.  
  760.  
  761. ;;;; Loading lists:
  762.  
  763. (define-fop (fop-list 15)
  764.   (do ((res () (cons (pop-stack) res))
  765.        (n (read-arg 1) (1- n)))
  766.       ((zerop n) res)))
  767.  
  768. (define-fop (fop-list* 16)
  769.   (do ((res (pop-stack) (cons (pop-stack) res))
  770.        (n (read-arg 1) (1- n)))
  771.       ((zerop n) res)))
  772.  
  773. (macrolet ((frob (name op fun n)
  774.          `(define-fop (,name ,op)
  775.         (call-with-popped-things ,fun ,n))))
  776.  
  777.   (frob fop-list-1 17 list 1)
  778.   (frob fop-list-2 18 list 2)
  779.   (frob fop-list-3 19 list 3)
  780.   (frob fop-list-4 20 list 4)
  781.   (frob fop-list-5 21 list 5)
  782.   (frob fop-list-6 22 list 6)
  783.   (frob fop-list-7 23 list 7)
  784.   (frob fop-list-8 24 list 8)
  785.  
  786.   (frob fop-list*-1 25 list* 2)
  787.   (frob fop-list*-2 26 list* 3)
  788.   (frob fop-list*-3 27 list* 4)
  789.   (frob fop-list*-4 28 list* 5)
  790.   (frob fop-list*-5 29 list* 6)
  791.   (frob fop-list*-6 30 list* 7)
  792.   (frob fop-list*-7 31 list* 8)
  793.   (frob fop-list*-8 32 list* 9))
  794.  
  795.  
  796. ;;;; Loading arrays:
  797. ;;;
  798.  
  799. (clone-fop (fop-string 37)
  800.        (fop-small-string 38)
  801.   (let* ((arg (clone-arg))
  802.      (res (make-string arg)))
  803.     (read-n-bytes *fasl-file* res 0 arg)
  804.     res))
  805.  
  806. (clone-fop (fop-vector 39)
  807.        (fop-small-vector 40)
  808.   (let* ((size (clone-arg))
  809.      (res (make-array size)))
  810.     (declare (fixnum size))
  811.     (do ((n (1- size) (1- n)))
  812.     ((minusp n))
  813.       (setf (svref res n) (pop-stack)))
  814.     res))
  815.  
  816. (clone-fop (fop-uniform-vector 41)
  817.        (fop-small-uniform-vector 42)
  818.   (make-array (clone-arg) :initial-element (pop-stack)))
  819.  
  820. (define-fop (fop-array 83)
  821.   (let* ((rank (read-arg 4))
  822.      (vec (pop-stack))
  823.      (length (length vec))
  824.      (res (make-array-header vm:simple-array-type rank)))
  825.     (declare (simple-array vec)
  826.          (type (unsigned-byte 24) rank))
  827.     (set-array-header res vec length length 0
  828.               (do ((i rank (1- i))
  829.                (dimensions () (cons (pop-stack) dimensions)))
  830.               ((zerop i) dimensions))
  831.               nil)
  832.     res))
  833.  
  834. (define-fop (fop-single-float-vector 84)
  835.   (let* ((length (read-arg 4))
  836.      (result (make-array length :element-type 'single-float)))
  837.     (read-n-bytes *fasl-file* result 0 (* length vm:word-bytes))
  838.     result))
  839.  
  840. (define-fop (fop-double-float-vector 85)
  841.   (let* ((length (read-arg 4))
  842.      (result (make-array length :element-type 'double-float)))
  843.     (read-n-bytes *fasl-file* result 0 (* length vm:word-bytes 2))
  844.     result))
  845.  
  846.  
  847. ;;; FOP-INT-VECTOR  --  Internal
  848. ;;;
  849. ;;; *** NOT *** the FOP-INT-VECTOR as currently documented in rtguts.  Size
  850. ;;; must be a directly supported I-vector element size, with no extra bits.
  851. ;;; This must be packed according to the local byte-ordering, allowing us to
  852. ;;; directly read the bits.
  853. ;;;
  854. (define-fop (fop-int-vector 43)
  855.   (prepare-for-fast-read-byte *fasl-file*
  856.     (let* ((len (fast-read-u-integer 4))
  857.        (size (fast-read-byte))
  858.        (res (case size
  859.           (1 (make-array len :element-type 'bit))
  860.           (2 (make-array len :element-type '(unsigned-byte 2)))
  861.           (4 (make-array len :element-type '(unsigned-byte 4)))
  862.           (8 (make-array len :element-type '(unsigned-byte 8)))
  863.           (16 (make-array len :element-type '(unsigned-byte 16)))
  864.           (32 (make-array len :element-type '(unsigned-byte 32)))
  865.           (t (error "Losing i-vector element size: ~S" size)))))
  866.       (declare (type index len))
  867.       (done-with-fast-read-byte)
  868.       (read-n-bytes *fasl-file* res 0 (ceiling (* size len) vm:byte-bits))
  869.       res)))
  870.  
  871.  
  872. (define-fop (fop-uniform-int-vector 44)
  873.   (prepare-for-fast-read-byte *fasl-file*
  874.     (let* ((n (fast-read-u-integer 4))
  875.        (size (fast-read-byte))
  876.        (value (fast-read-variable-u-integer (ceiling size 8))))
  877.       (done-with-fast-read-byte)
  878.       (make-array n :element-type `(unsigned-byte ,size)
  879.           :initial-element value))))
  880.  
  881. (define-fop (fop-eval 53)
  882.   (let ((result (eval (pop-stack))))
  883.     (when *load-print*
  884.       (load-fresh-line)
  885.       (prin1 result)
  886.       (terpri))
  887.     result))
  888.  
  889. (define-fop (fop-eval-for-effect 54 nil)
  890.   (let ((result (eval (pop-stack))))
  891.     (when *load-print*
  892.       (load-fresh-line)
  893.       (prin1 result)
  894.       (terpri))))
  895.  
  896. (define-fop (fop-funcall 55)
  897.   (let ((arg (read-arg 1)))
  898.     (if (zerop arg)
  899.     (funcall (pop-stack))
  900.     (do ((args () (cons (pop-stack) args))
  901.          (n arg (1- n)))
  902.         ((zerop n) (apply (pop-stack) args))))))
  903.  
  904. (define-fop (fop-funcall-for-effect 56 nil)
  905.   (let ((arg (read-arg 1)))
  906.     (if (zerop arg)
  907.     (funcall (pop-stack))
  908.     (do ((args () (cons (pop-stack) args))
  909.          (n arg (1- n)))
  910.         ((zerop n) (apply (pop-stack) args))))))
  911.  
  912. ;;;; Fixing up circularities.
  913. (define-fop (fop-rplaca 200 nil)
  914.   (let ((obj (svref *current-fop-table* (read-arg 4)))
  915.     (idx (read-arg 4))
  916.     (val (pop-stack)))
  917.     (setf (car (nthcdr idx obj)) val)))
  918.  
  919.  
  920. (define-fop (fop-rplacd 201 nil)
  921.   (let ((obj (svref *current-fop-table* (read-arg 4)))
  922.     (idx (read-arg 4))
  923.     (val (pop-stack)))
  924.     (setf (cdr (nthcdr idx obj)) val)))
  925.  
  926. (define-fop (fop-svset 202 nil)
  927.   (let* ((obi (read-arg 4))
  928.      (obj (svref *current-fop-table* obi))
  929.      (idx (read-arg 4))
  930.      (val (pop-stack)))
  931.     (if (structurep obj)
  932.     (setf (c::structure-ref obj idx) val)
  933.     (setf (svref obj idx) val))))
  934.  
  935. (define-fop (fop-structset 204 nil)
  936.   (setf (c::structure-ref (svref *current-fop-table* (read-arg 4))
  937.               (read-arg 4))
  938.     (pop-stack)))
  939.  
  940. (define-fop (fop-nthcdr 203 t)
  941.   (nthcdr (read-arg 4) (pop-stack)))
  942.  
  943. ;;;; Loading functions:
  944.  
  945. (define-fop (fop-code-format 57 :nope)
  946.   (setf *current-code-format*
  947.     (cons (read-arg 1) (read-arg 1))))
  948.  
  949. ;;; Load-Code loads a code object.  NItems objects are popped off the stack for
  950. ;;; the boxed storage section, then Size bytes of code are read in.
  951. ;;;
  952. (defmacro load-code (nitems size)
  953.   `(if *current-code-format*
  954.        (let ((implementation (car *current-code-format*))
  955.          (version (cdr *current-code-format*)))
  956.      (unless (= implementation
  957.             #.(c:backend-fasl-file-implementation c:*backend*))
  958.        (error "~A was compiled for a ~A, but this is a ~A"
  959.           *Fasl-file*
  960.           (or (elt c:fasl-file-implementations implementation)
  961.               "unknown machine")
  962.           (or (elt c:fasl-file-implementations
  963.                #.(c:backend-fasl-file-implementation c:*backend*))
  964.               "unknown machine")))
  965.      (unless (= version #.(c:backend-fasl-file-version c:*backend*))
  966.        (error "~A was compiled for fasl-file version ~A, ~
  967.                but this is version ~A"
  968.         *Fasl-file* version #.(c:backend-fasl-file-version c:*backend*)))
  969.      (let ((box-num ,nitems)
  970.            (code-length ,size))
  971.        (declare (fixnum box-num code-length))
  972.        (let ((code (%primitive allocate-code-object box-num code-length))
  973.          (index (+ vm:code-trace-table-offset-slot box-num)))
  974.          (setf (code-header-ref code vm:code-debug-info-slot) (pop-stack))
  975.          (dotimes (i box-num)
  976.            (declare (fixnum i))
  977.            (setf (code-header-ref code (decf index)) (pop-stack)))
  978.          (system:without-gcing
  979.           (read-n-bytes *fasl-file* (code-instructions code) 0
  980.                 code-length))
  981.          code)))
  982.        (error
  983.     "Code Format not set?  Can't load code until after FOP-CODE-FORMAT.")))
  984.  
  985. (define-fop (fop-code 58)
  986.   (load-code (read-arg 4) (read-arg 4)))
  987.  
  988. (define-fop (fop-small-code 59)
  989.   (load-code (read-arg 1) (read-arg 2)))
  990.  
  991.  
  992. ;;; Now a NOOP except in cold load... 
  993. (define-fop (fop-fset 74 nil)
  994.   (pop-stack)
  995.   (pop-stack))
  996.  
  997.  
  998. ;;; Modify a slot in a Constants object.
  999. ;;;
  1000. (clone-fop (fop-alter-code 140 nil) (fop-byte-alter-code 141)
  1001.   (let ((value (pop-stack))
  1002.     (code (pop-stack)))
  1003.     (setf (code-header-ref code (clone-arg)) value)
  1004.     (undefined-value)))
  1005.  
  1006. (define-fop (fop-function-entry 142)
  1007.   (let ((type (pop-stack))
  1008.     (arglist (pop-stack))
  1009.     (name (pop-stack))
  1010.     (code-object (pop-stack))
  1011.     (offset (read-arg 4)))
  1012.     (declare (type index offset))
  1013.     (unless (zerop (logand offset vm:lowtag-mask))
  1014.       (error "Unaligned function object, offset = #x~X." offset))
  1015.     (let ((fun (%primitive compute-function code-object offset)))
  1016.       (%primitive set-function-self fun fun)
  1017.       (%primitive set-function-next fun
  1018.           (%primitive code-entry-points code-object))
  1019.       (%primitive set-code-entry-points code-object fun)
  1020.       (%primitive set-function-name fun name)
  1021.       (%primitive set-function-arglist fun arglist)
  1022.       (%primitive set-function-type fun type)
  1023.       (when *load-print*
  1024.     (load-fresh-line)
  1025.     (format t "~S defined~%" fun))
  1026.       fun)))
  1027.  
  1028.  
  1029. ;;;; Linkage fixups.
  1030.  
  1031. ;;; These two variables are initially filled in by Genesis.
  1032.  
  1033. (defvar *initial-assembler-routines*)
  1034. (defvar *initial-foreign-symbols*)
  1035.  
  1036. (defvar *assembler-routines* (make-hash-table :test #'eq))
  1037. (defvar *foreign-symbols* (make-hash-table :test #'equal))
  1038.  
  1039. (defun loader-init ()
  1040.   (dolist (routine *initial-assembler-routines*)
  1041.     (setf (gethash (car routine) *assembler-routines*) (cdr routine)))
  1042.   (dolist (symbol *initial-foreign-symbols*)
  1043.     (setf (gethash (car symbol) *foreign-symbols*) (cdr symbol)))
  1044.   (makunbound '*initial-assembler-routines*)
  1045.   (makunbound '*initial-foreign-symbols*))
  1046.  
  1047. (defun foreign-symbol-address (symbol)
  1048.   (multiple-value-bind
  1049.       (value found)
  1050.       (gethash (vm:extern-alien-name symbol) *foreign-symbols* 0)
  1051.     (unless found
  1052.       (error "Unknown foreign symbol: ~S" symbol))
  1053.     (int-sap value)))
  1054.  
  1055. (define-fop (fop-foreign-fixup 147)
  1056.   (let* ((kind (pop-stack))
  1057.      (code-object (pop-stack))
  1058.      (len (read-arg 1))
  1059.      (sym (make-string len)))
  1060.     (read-n-bytes *fasl-file* sym 0 len)
  1061.     (multiple-value-bind
  1062.     (value found)
  1063.     (gethash sym *foreign-symbols* 0)
  1064.       (unless found
  1065.     (error "Unknown foreign symbol: ~S" sym))
  1066.       (vm:fixup-code-object code-object (read-arg 4) value kind))
  1067.     code-object))
  1068.  
  1069. (define-fop (fop-assembler-code 144)
  1070.   (error "Cannot load assembler code."))
  1071.  
  1072. (define-fop (fop-assembler-routine 145)
  1073.   (error "Cannot load assembler code."))
  1074.  
  1075. (define-fop (fop-assembler-fixup 148)
  1076.   (let ((routine (pop-stack))
  1077.     (kind (pop-stack))
  1078.     (code-object (pop-stack)))
  1079.     (multiple-value-bind
  1080.     (value found)
  1081.     (gethash routine *assembler-routines*)
  1082.       (unless found
  1083.     (error "Undefined assembler routine: ~S" routine))
  1084.       (vm:fixup-code-object code-object (read-arg 4) value kind))
  1085.     code-object))
  1086.  
  1087.  
  1088.  
  1089. (proclaim '(maybe-inline read-byte))
  1090.