;;;; that part of the loader is only needed on the target system
;;;; (which is basically synonymous with "that part of the loader
;;;; which is not needed by GENESIS")

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB!FASL")

(defvar *load-source-default-type* "lisp"
  "The source file types which LOAD looks for by default.")

(declaim (type (or pathname null) *load-truename* *load-pathname*))
(defvar *load-truename* nil
  "the TRUENAME of the file that LOAD is currently loading")
(defvar *load-pathname* nil
  "the defaulted pathname that LOAD is currently loading")

;;;; LOAD-AS-SOURCE

;;; Load a text stream.  (Note that load-as-fasl is in another file.)
;; We'd like, when entering the debugger as a result of an EVAL error,
;; that the condition be annotated with the stream position.
;; One way to do it is catch all conditions and encapsulate them in
;; something new such as a LOADER-EVAL-ERROR and re-signal.
;; The printer for the encapsulated condition has the data it needs to
;; show the original condition and the line/col. That would unfortunately
;; interfere with handlers that were bound around LOAD, since they would
;; only receive the encapsulated condition, and not be able to test for
;; things they're interested in, such as which redefinition warnings to ignore.
;; Instead, printing a herald for any SERIOUS-CONDITION approximates
;; the desired behavior closely enough without printing something for warnings.
;; TODO: It would be supremely cool if, for toplevel PROGN, we could
;; indicate the position of the specific subform that failed
(defun load-as-source (stream &key verbose print (context "loading"))
  (maybe-announce-load stream verbose)
  (let* ((pathname (ignore-errors (translate-logical-pathname stream)))
         (native (when pathname (native-namestring pathname))))
    (with-simple-restart (abort "Abort ~A file ~S." context native)
     (labels ((condition-herald (c)
                (declare (ignore c)) ; propagates up
                (when (form-tracking-stream-p stream)
                  (let* ((startpos
                          (form-tracking-stream-form-start-char-pos stream))
                         (point (line/col-from-charpos stream startpos)))
                    (format *error-output* "~&While evaluating the form ~
 starting at line ~D, column ~D~%  of ~S:"
                            (car point) (cdr point)
                            (or pathname stream)))))
              (eval-form (form index)
               (with-simple-restart (continue "Ignore error and continue ~A file ~S."
                                              context native)
                 (loop
                  (handler-bind ((serious-condition #'condition-herald))
                   (with-simple-restart (retry "Retry EVAL of current toplevel form.")
                     (if print
                         (let ((results (multiple-value-list (eval-tlf form index))))
                           (load-fresh-line)
                           (format t "~{~S~^, ~}~%" results))
                         (eval-tlf form index)))
                   (return))))))
        (if pathname
            (let* ((info (sb!c::make-file-source-info
                          pathname (stream-external-format stream)))
                   (sb!c::*source-info* info))
              (setf (sb!c::source-info-stream info) stream)
              (sb!c::do-forms-from-info ((form current-index) info
                                         'sb!c::input-error-in-load)
                (sb!c::with-source-paths
                  (sb!c::find-source-paths form current-index)
                  (eval-form form current-index))))
            (let ((sb!c::*source-info* nil))
              (do ((form (read stream nil *eof-object*)
                         (read stream nil *eof-object*)))
                  ((eq form *eof-object*))
                (sb!c::with-source-paths
                  (eval-form form nil))))))))
  t)

;;;; LOAD itself

(define-condition fasl-header-missing (invalid-fasl)
  ((fhsss :reader invalid-fasl-fhsss :initarg :fhsss))
  (:report
   (lambda (condition stream)
     (format stream "~@<File ~S has a fasl file type, but no fasl header:~%~
                     Expected ~S, but got ~S.~:@>"
             (invalid-fasl-stream condition)
             (invalid-fasl-expected condition)
             (invalid-fasl-fhsss condition)))))


;;; The following comment preceded the pre 1.0.12.36 definition of
;;; LOAD; it may no longer be accurate:

;; FIXME: Daniel Barlow's ilsb.tar ILISP-for-SBCL patches contain an
;; implementation of "DEFUN SOURCE-FILE" which claims, in a comment,
;; that CMU CL does not correctly record source file information when
;; LOADing a non-compiled file. Check whether this bug exists in SBCL
;; and fix it if so.

(defun call-with-load-bindings (function stream)
           (let* (;; FIXME: we should probably document the circumstances
                  ;; where *LOAD-PATHNAME* and *LOAD-TRUENAME* aren't
                  ;; pathnames during LOAD.  ANSI makes no exceptions here.
                  (*load-pathname* (handler-case (pathname stream)
                                     ;; FIXME: it should probably be a type
                                     ;; error to try to get a pathname for a
                                     ;; stream that doesn't have one, but I
                                     ;; don't know if we guarantee that.
                                     (error () nil)))
                  (*load-truename* (when *load-pathname*
                                     (handler-case (truename stream)
                                       (file-error () nil))))
                  ;; Bindings used internally.
                  (*load-depth* (1+ *load-depth*)))
             (funcall function)))

(defun load (pathspec &key (verbose *load-verbose*) (print *load-print*)
             (if-does-not-exist t) (external-format :default))
  "Load the file given by FILESPEC into the Lisp environment, returning
   T on success."
  (flet ((load-stream (stream faslp)
           (when (and (fd-stream-p stream)
                      (eq (sb!impl::fd-stream-fd-type stream) :directory))
             (error 'simple-file-error
                    :pathname (pathname stream)
                    :format-control
                    "Can't LOAD a directory: ~s."
                    :format-arguments (list (pathname stream))))
           (dx-flet ((thunk ()
                       (let ( ;; Bindings required by ANSI.
                             (*readtable* *readtable*)
                             (*package* (sane-package))
                             ;; KLUDGE: I can't find in the ANSI spec where it says
                             ;; that DECLAIM/PROCLAIM of optimization policy should
                             ;; have file scope. CMU CL did this, and it seems
                             ;; reasonable, but it might not be right; after all,
                             ;; things like (PROCLAIM '(TYPE ..)) don't have file
                             ;; scope, and I can't find anything under PROCLAIM or
                             ;; COMPILE-FILE or LOAD or OPTIMIZE which justifies this
                             ;; behavior. Hmm. -- WHN 2001-04-06
                             (sb!c::*policy* sb!c::*policy*))
                         (if faslp
                             (load-as-fasl stream verbose print)
                             (sb!c:with-compiler-error-resignalling
                                 (load-as-source stream :verbose verbose
                                                        :print print))))))
             (call-with-load-bindings #'thunk stream))))

    ;; Case 1: stream.
    (when (streamp pathspec)
      (return-from load (load-stream pathspec (fasl-header-p pathspec))))

    (let ((pathname (pathname pathspec)))
      ;; Case 2: Open as binary, try to process as a fasl.
      (with-open-stream
          (stream (or (open pathspec :element-type '(unsigned-byte 8)
                                     :if-does-not-exist nil)
                      (when (null (pathname-type pathspec))
                        (let ((defaulted-pathname
                                (probe-load-defaults pathspec)))
                          (if defaulted-pathname
                              (progn (setq pathname defaulted-pathname)
                                     (open pathname
                                           :if-does-not-exist
                                           (if if-does-not-exist :error nil)
                                           :element-type '(unsigned-byte 8))))))
                      (if if-does-not-exist
                          (error 'simple-file-error
                                 :pathname pathspec
                                 :format-control
                                 "~@<Couldn't load ~S: file does not exist.~@:>"
                                 :format-arguments (list pathspec))
                          (return-from load nil))))
        (let* ((real (probe-file stream))
               (should-be-fasl-p
                (and real (string-equal (pathname-type real) *fasl-file-type*))))
          ;; Don't allow empty .fasls, and assume other empty files
          ;; are source files.
          (when (and (or should-be-fasl-p (not (eql 0 (file-length stream))))
                     (fasl-header-p stream :errorp should-be-fasl-p))
            (return-from load (load-stream stream t)))))

      ;; Case 3: Open using the given external format, process as source.
      (with-open-file (stream pathname :external-format external-format
                              :class 'form-tracking-stream)
        (load-stream stream nil)))))

;; This implements the defaulting SBCL seems to have inherited from
;; CMU.  This routine does not try to perform any loading; all it does
;; is return the pathname (not the truename) of a file to be loaded,
;; or NIL if no such file can be found.  This routine is supposed to
;; signal an error if a fasl's timestamp is older than its source
;; file, but we protect against errors in PROBE-FILE, because any of
;; the ways that we might fail to find a defaulted file are reasons
;; not to load it, but not worth exposing to the user who didn't
;; expicitly ask us to load a file with a made-up name (e.g., the
;; defaulted filename might exceed filename length limits).
(defun probe-load-defaults (pathname)
  (destructuring-bind (defaulted-source-pathname
                       defaulted-source-truename
                       defaulted-fasl-pathname
                       defaulted-fasl-truename)
      (loop for type in (list *load-source-default-type*
                              *fasl-file-type*)
            as probe-pathname = (make-pathname :type type
                                               :defaults pathname)
            collect probe-pathname
            collect (handler-case (probe-file probe-pathname)
                      (file-error () nil)))
    (cond ((and defaulted-fasl-truename
                defaulted-source-truename
                (> (file-write-date defaulted-source-truename)
                   (file-write-date defaulted-fasl-truename)))
           (restart-case
               (error "The object file ~A is~@
                       older than the presumed source:~%  ~A."
                      defaulted-fasl-truename
                      defaulted-source-truename)
             (source () :report "load source file"
                     defaulted-source-pathname)
             (object () :report "load object file"
                     defaulted-fasl-pathname)))
          (defaulted-fasl-truename defaulted-fasl-pathname)
          (defaulted-source-truename defaulted-source-pathname))))

;;; Load a code object. BOX-NUM objects are popped off the stack for
;;; the boxed storage section, then CODE-LENGTH bytes of code are read in.
(defun load-code (nfuns box-num code-length stack ptr fasl-input)
  (declare (fixnum box-num code-length))
  (declare (simple-vector stack) (type index ptr))
  (let* ((debug-info-index (+ ptr box-num))
         (immobile-p (svref stack (1+ debug-info-index)))
         (code (sb!c:allocate-code-object immobile-p box-num code-length)))
    (setf (%code-debug-info code) (svref stack debug-info-index))
    (loop for i of-type index from sb!vm:code-constants-offset
          for j of-type index from ptr below debug-info-index
          do (setf (code-header-ref code i) (svref stack j)))
    (with-pinned-objects (code)
      (read-n-bytes (%fasl-input-stream fasl-input)
                    (code-instructions code) 0 code-length)
      (sb!c::set-code-entrypoints
       code (loop repeat nfuns collect (read-varint-arg fasl-input)))
      (sb!c::apply-fasl-fixups stack code))
    code))

;;;; linkage fixups

;;; how we learn about assembler routines at startup
(defvar *!initial-assembler-routines*)

(defun get-asm-routine (name &aux (code *assembler-routines*))
  (awhen (gethash (the symbol name) (car (%code-debug-info code)))
    (sap-int (sap+ (code-instructions code) (car it)))))

(defun !loader-cold-init ()
  (let* ((code *assembler-routines*)
         (size (%code-code-size code))
         (vector (the simple-vector *!initial-assembler-routines*))
         (count (length vector))
         (ht (make-hash-table :test 'eq)))
    ;; code-debug-info stores the name->addr hashtable, but readonly
    ;; space can't point to dynamic space. indirect through a static cons
    (setf (%code-debug-info code)
          (rplaca (let ((ptr (sap-int sb!vm:*static-space-free-pointer*)))
                    (setf sb!vm:*static-space-free-pointer*
                          (int-sap (+ ptr (* sb!vm:n-word-bytes 2))))
                    (%make-lisp-obj (logior ptr sb!vm:list-pointer-lowtag)))
                  ht))
    (dotimes (i count)
      (destructuring-bind (name . offset) (svref vector i)
        (let ((next-offset (if (< (1+ i) count) (cdr (svref vector (1+ i))) size)))
          (aver (> next-offset offset))
          ;; store inclusive bounds on PC offset range
          (setf (gethash name ht) (cons offset (1- next-offset))))))))

(defun !warm-load (file)
  (restart-case (let ((sb!c::*source-namestring*
                       (format nil "SYS:~A" (substitute #\; #\/ file))))
                  (load file))
    (abort ()
      :report "Abort building SBCL."
      (sb!ext:exit :code 1))))

;;; Remember where cold artifacts went, and put the warm ones there too
;;; because it looks nicer not to scatter them throughout the source tree.
;;; *t-o-prefix* isn't known to the compiler, and we need it to be
;;; initialized from a constant, so use read-time eval.
(defvar *!target-obj-prefix* #.sb-cold::*target-obj-prefix*)
