;;; a helper function for LOAD: Load the stuff in a file when we have
;;; the name.
+;;;
+;;; FIXME: with the addition of the EXTERNAL-FORMAT argument, this
+;;; interface has become truly sucky.
(defun internal-load (pathname truename if-does-not-exist verbose print
- &optional contents)
+ &optional contents external-format)
(declare (type (member nil :error) if-does-not-exist))
(unless truename
(if if-does-not-exist
(return-from internal-load nil)))
(let ((*load-truename* truename)
- (*load-pathname* pathname))
+ (*load-pathname* (merge-pathnames pathname)))
(case contents
(:source
(with-open-file (stream truename
:direction :input
- :if-does-not-exist if-does-not-exist)
+ :if-does-not-exist if-does-not-exist
+ :external-format external-format)
(load-as-source stream verbose print)))
(:binary
(with-open-file (stream truename
:element-type '(unsigned-byte 8))
(load-as-fasl stream verbose print)))
(t
- (let ((first-line (with-open-file (stream truename :direction :input)
- (read-line stream nil)))
- (fhsss *fasl-header-string-start-string*))
+ (let* ((fhsss *fasl-header-string-start-string*)
+ (first-line (make-array (length fhsss)
+ :element-type '(unsigned-byte 8)))
+ (read-length
+ (with-open-file (stream truename
+ :direction :input
+ :element-type '(unsigned-byte 8))
+ (read-sequence first-line stream))))
(cond
- ((and first-line
- (>= (length (the simple-string first-line))
- (length fhsss))
- (string= first-line fhsss :end1 (length fhsss)))
- (internal-load pathname truename if-does-not-exist verbose print
- :binary))
- (t
- (when (string= (pathname-type truename) *fasl-file-type*)
- (error 'fasl-header-missing
- :stream (namestring truename)
- :fhsss first-line
- :expected fhsss))
- (internal-load pathname truename if-does-not-exist verbose print
- :source))))))))
+ ((and (= read-length (length fhsss))
+ (do ((i 0 (1+ i)))
+ ((= i read-length) t)
+ (when (/= (char-code (aref fhsss i)) (aref first-line i))
+ (return))))
+ (internal-load pathname truename if-does-not-exist verbose print
+ :binary))
+ (t
+ (when (string= (pathname-type truename) *fasl-file-type*)
+ (error 'fasl-header-missing
+ :stream (namestring truename)
+ :fhsss first-line
+ :expected fhsss))
+ (internal-load pathname truename if-does-not-exist verbose print
+ :source external-format))))))))
;;; a helper function for INTERNAL-LOAD-DEFAULT-TYPE: Try the default
;;; file type TYPE and return (VALUES PATHNAME TRUENAME) for a match,
;;; a helper function for LOAD: Handle the case of INTERNAL-LOAD where
;;; the file does not exist.
-(defun internal-load-default-type (pathname if-does-not-exist verbose print)
+(defun internal-load-default-type
+ (pathname if-does-not-exist verbose print external-format)
(declare (type (member nil :error) if-does-not-exist))
(multiple-value-bind (src-pn src-tn)
(try-default-type pathname *load-source-default-type*)
(> (file-write-date src-tn) (file-write-date obj-tn)))
(restart-case
(error "The object file ~A is~@
- older than the presumed source:~% ~A."
+ older than the presumed source:~% ~A."
(namestring obj-tn)
(namestring src-tn))
- ;; FIXME: In CMU CL one of these was a CONTINUE case.
- ;; There's not one now. I don't remember how restart-case
- ;; works very well, make sure that it doesn't do anything
- ;; weird when we don't specify the CONTINUE case.
(source () :report "load source file"
(internal-load src-pn src-tn if-does-not-exist verbose print
- :source))
+ :source external-format))
(object () :report "load object file"
(internal-load src-pn obj-tn if-does-not-exist verbose print
:binary))))
(obj-tn
(internal-load obj-pn obj-tn if-does-not-exist verbose print :binary))
(src-pn
- (internal-load src-pn src-tn if-does-not-exist verbose print :source))
+ (internal-load src-pn src-tn if-does-not-exist
+ verbose print :source external-format))
(t
- (internal-load pathname nil if-does-not-exist verbose print nil))))))
+ (internal-load pathname nil if-does-not-exist
+ verbose print nil external-format))))))
;;; This function mainly sets up special bindings and then calls
;;; sub-functions. We conditionally bind the switches with PROGV so
#!+sb-doc
"Load the file given by FILESPEC into the Lisp environment, returning
T on success."
- (declare (ignore external-format))
(let ((*load-depth* (1+ *load-depth*))
;; KLUDGE: I can't find in the ANSI spec where it says that
;; DECLAIM/PROCLAIM of optimization policy should have file
(probed-file (probe-file physical-pathname)))
(if (or probed-file
(pathname-type physical-pathname))
- (internal-load physical-pathname
- probed-file
- internal-if-does-not-exist
- verbose
- print)
- (internal-load-default-type pathname
- internal-if-does-not-exist
- verbose
- print)))))))
+ (internal-load
+ physical-pathname probed-file internal-if-does-not-exist
+ verbose print nil external-format)
+ (internal-load-default-type
+ pathname internal-if-does-not-exist
+ verbose print external-format)))))))
\f
;;; Load a code object. BOX-NUM objects are popped off the stack for
;;; the boxed storage section, then SIZE bytes of code are read in.
\f
;;;; linkage fixups
-;;; how we learn about assembler routines and foreign symbols at startup
+;;; how we learn about assembler routines at startup
(defvar *!initial-assembler-routines*)
-(defvar *!initial-foreign-symbols*)
+
(defun !loader-cold-init ()
+ (/show0 "/!loader-cold-init")
(dolist (routine *!initial-assembler-routines*)
- (setf (gethash (car routine) *assembler-routines*) (cdr routine)))
- (dolist (symbol *!initial-foreign-symbols*)
- (setf (gethash (car symbol) *static-foreign-symbols*) (cdr symbol))))
-
-(declaim (ftype (function (string) (unsigned-byte #.sb!vm:n-machine-word-bits))
- foreign-symbol-address-as-integer))
-
-
-;;; SB!SYS:GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS is in foreign.lisp, on
-;;; platforms that have dynamic loading
-(defun foreign-symbol-address-as-integer-or-nil (foreign-symbol)
- (or (find-foreign-symbol-in-table foreign-symbol *static-foreign-symbols*)
- (sb!sys:get-dynamic-foreign-symbol-address foreign-symbol)))
-
-(defun foreign-symbol-address-as-integer (foreign-symbol)
- (or (foreign-symbol-address-as-integer-or-nil foreign-symbol)
- (error "unknown foreign symbol: ~S" foreign-symbol)))
-
-(defun foreign-symbol-address (symbol)
- (int-sap (foreign-symbol-address-as-integer
- (sb!vm:extern-alien-name symbol))))
+ (setf (gethash (car routine) *assembler-routines*) (cdr routine))))
projects / sbcl.git / blobdiff