Fix FORMAT compilation on non-simple strings.
[sbcl.git] / src / code / target-load.lisp
blob4cc575227b7b9c8c11989ea355dd235a75788698
1 ;;;; that part of the loader is only needed on the target system
2 ;;;; (which is basically synonymous with "that part of the loader
3 ;;;; which is not needed by GENESIS")
5 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; more information.
7 ;;;;
8 ;;;; This software is derived from the CMU CL system, which was
9 ;;;; written at Carnegie Mellon University and released into the
10 ;;;; public domain. The software is in the public domain and is
11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
12 ;;;; files for more information.
14 (in-package "SB!FASL")
16 (defvar *load-source-default-type* "lisp"
17 "The source file types which LOAD looks for by default.")
19 (declaim (type (or pathname null) *load-truename* *load-pathname*))
20 (defvar *load-truename* nil
21 "the TRUENAME of the file that LOAD is currently loading")
22 (defvar *load-pathname* nil
23 "the defaulted pathname that LOAD is currently loading")
25 ;;;; LOAD-AS-SOURCE
27 ;;; Load a text stream. (Note that load-as-fasl is in another file.)
28 ;; We'd like, when entering the debugger as a result of an EVAL error,
29 ;; that the condition be annotated with the stream position.
30 ;; One way to do it is catch all conditions and encapsulate them in
31 ;; something new such as a LOADER-EVAL-ERROR and re-signal.
32 ;; The printer for the encapsulated condition has the data it needs to
33 ;; show the original condition and the line/col. That would unfortunately
34 ;; interfere with handlers that were bound around LOAD, since they would
35 ;; only receive the encapsulated condition, and not be able to test for
36 ;; things they're interested in, such as which redefinition warnings to ignore.
37 ;; Instead, printing a herald for any SERIOUS-CONDITION approximates
38 ;; the desired behavior closely enough without printing something for warnings.
39 ;; TODO: It would be supremely cool if, for toplevel PROGN, we could
40 ;; indicate the position of the specific subform that failed
41 (defun load-as-source (stream &key verbose print (context "loading"))
42 (maybe-announce-load stream verbose)
43 (let* ((pathname (ignore-errors (translate-logical-pathname stream)))
44 (native (when pathname (native-namestring pathname))))
45 (with-simple-restart (abort "Abort ~A file ~S." context native)
46 (labels ((condition-herald (c)
47 (declare (ignore c)) ; propagates up
48 (when (form-tracking-stream-p stream)
49 (let* ((startpos
50 (form-tracking-stream-form-start-char-pos stream))
51 (point (line/col-from-charpos stream startpos)))
52 (format *error-output* "~&While evaluating the form ~
53 starting at line ~D, column ~D~% of ~S:"
54 (car point) (cdr point)
55 (or pathname stream)))))
56 (eval-form (form index)
57 (with-simple-restart (continue "Ignore error and continue ~A file ~S."
58 context native)
59 (loop
60 (handler-bind ((serious-condition #'condition-herald))
61 (with-simple-restart (retry "Retry EVAL of current toplevel form.")
62 (if print
63 (let ((results (multiple-value-list (eval-tlf form index))))
64 (load-fresh-line)
65 (format t "~{~S~^, ~}~%" results))
66 (eval-tlf form index)))
67 (return))))))
68 (if pathname
69 (let* ((info (sb!c::make-file-source-info
70 pathname (stream-external-format stream)))
71 (sb!c::*source-info* info))
72 (setf (sb!c::source-info-stream info) stream)
73 (sb!c::do-forms-from-info ((form current-index) info
74 'sb!c::input-error-in-load)
75 (sb!c::with-source-paths
76 (sb!c::find-source-paths form current-index)
77 (eval-form form current-index))))
78 (let ((sb!c::*source-info* nil))
79 (do ((form (read stream nil *eof-object*)
80 (read stream nil *eof-object*)))
81 ((eq form *eof-object*))
82 (sb!c::with-source-paths
83 (eval-form form nil))))))))
86 ;;;; LOAD itself
88 (define-condition fasl-header-missing (invalid-fasl)
89 ((fhsss :reader invalid-fasl-fhsss :initarg :fhsss))
90 (:report
91 (lambda (condition stream)
92 (format stream "~@<File ~S has a fasl file type, but no fasl header:~%~
93 Expected ~S, but got ~S.~:@>"
94 (invalid-fasl-stream condition)
95 (invalid-fasl-expected condition)
96 (invalid-fasl-fhsss condition)))))
99 ;;; The following comment preceded the pre 1.0.12.36 definition of
100 ;;; LOAD; it may no longer be accurate:
102 ;; FIXME: Daniel Barlow's ilsb.tar ILISP-for-SBCL patches contain an
103 ;; implementation of "DEFUN SOURCE-FILE" which claims, in a comment,
104 ;; that CMU CL does not correctly record source file information when
105 ;; LOADing a non-compiled file. Check whether this bug exists in SBCL
106 ;; and fix it if so.
108 (defun call-with-load-bindings (function stream)
109 (let* (;; FIXME: we should probably document the circumstances
110 ;; where *LOAD-PATHNAME* and *LOAD-TRUENAME* aren't
111 ;; pathnames during LOAD. ANSI makes no exceptions here.
112 (*load-pathname* (handler-case (pathname stream)
113 ;; FIXME: it should probably be a type
114 ;; error to try to get a pathname for a
115 ;; stream that doesn't have one, but I
116 ;; don't know if we guarantee that.
117 (error () nil)))
118 (*load-truename* (when *load-pathname*
119 (handler-case (truename stream)
120 (file-error () nil))))
121 ;; Bindings used internally.
122 (*load-depth* (1+ *load-depth*)))
123 (funcall function)))
125 (defun load (pathspec &key (verbose *load-verbose*) (print *load-print*)
126 (if-does-not-exist t) (external-format :default))
127 "Load the file given by FILESPEC into the Lisp environment, returning
128 T on success."
129 (flet ((load-stream (stream faslp)
130 (when (and (fd-stream-p stream)
131 (eq (sb!impl::fd-stream-fd-type stream) :directory))
132 (error 'simple-file-error
133 :pathname (pathname stream)
134 :format-control
135 "Can't LOAD a directory: ~s."
136 :format-arguments (list (pathname stream))))
137 (dx-flet ((thunk ()
138 (let ( ;; Bindings required by ANSI.
139 (*readtable* *readtable*)
140 (*package* (sane-package))
141 ;; KLUDGE: I can't find in the ANSI spec where it says
142 ;; that DECLAIM/PROCLAIM of optimization policy should
143 ;; have file scope. CMU CL did this, and it seems
144 ;; reasonable, but it might not be right; after all,
145 ;; things like (PROCLAIM '(TYPE ..)) don't have file
146 ;; scope, and I can't find anything under PROCLAIM or
147 ;; COMPILE-FILE or LOAD or OPTIMIZE which justifies this
148 ;; behavior. Hmm. -- WHN 2001-04-06
149 (sb!c::*policy* sb!c::*policy*))
150 (if faslp
151 (load-as-fasl stream verbose print)
152 (sb!c:with-compiler-error-resignalling
153 (load-as-source stream :verbose verbose
154 :print print))))))
155 (call-with-load-bindings #'thunk stream))))
157 ;; Case 1: stream.
158 (when (streamp pathspec)
159 (return-from load (load-stream pathspec (fasl-header-p pathspec))))
161 (let ((pathname (pathname pathspec)))
162 ;; Case 2: Open as binary, try to process as a fasl.
163 (with-open-stream
164 (stream (or (open pathspec :element-type '(unsigned-byte 8)
165 :if-does-not-exist nil)
166 (when (null (pathname-type pathspec))
167 (let ((defaulted-pathname
168 (probe-load-defaults pathspec)))
169 (if defaulted-pathname
170 (progn (setq pathname defaulted-pathname)
171 (open pathname
172 :if-does-not-exist
173 (if if-does-not-exist :error nil)
174 :element-type '(unsigned-byte 8))))))
175 (if if-does-not-exist
176 (error 'simple-file-error
177 :pathname pathspec
178 :format-control
179 "~@<Couldn't load ~S: file does not exist.~@:>"
180 :format-arguments (list pathspec))
181 (return-from load nil))))
182 (let* ((real (probe-file stream))
183 (should-be-fasl-p
184 (and real (string-equal (pathname-type real) *fasl-file-type*))))
185 ;; Don't allow empty .fasls, and assume other empty files
186 ;; are source files.
187 (when (and (or should-be-fasl-p (not (eql 0 (file-length stream))))
188 (fasl-header-p stream :errorp should-be-fasl-p))
189 (return-from load (load-stream stream t)))))
191 ;; Case 3: Open using the given external format, process as source.
192 (with-open-file (stream pathname :external-format external-format
193 :class 'form-tracking-stream)
194 (load-stream stream nil)))))
196 ;; This implements the defaulting SBCL seems to have inherited from
197 ;; CMU. This routine does not try to perform any loading; all it does
198 ;; is return the pathname (not the truename) of a file to be loaded,
199 ;; or NIL if no such file can be found. This routine is supposed to
200 ;; signal an error if a fasl's timestamp is older than its source
201 ;; file, but we protect against errors in PROBE-FILE, because any of
202 ;; the ways that we might fail to find a defaulted file are reasons
203 ;; not to load it, but not worth exposing to the user who didn't
204 ;; expicitly ask us to load a file with a made-up name (e.g., the
205 ;; defaulted filename might exceed filename length limits).
206 (defun probe-load-defaults (pathname)
207 (destructuring-bind (defaulted-source-pathname
208 defaulted-source-truename
209 defaulted-fasl-pathname
210 defaulted-fasl-truename)
211 (loop for type in (list *load-source-default-type*
212 *fasl-file-type*)
213 as probe-pathname = (make-pathname :type type
214 :defaults pathname)
215 collect probe-pathname
216 collect (handler-case (probe-file probe-pathname)
217 (file-error () nil)))
218 (cond ((and defaulted-fasl-truename
219 defaulted-source-truename
220 (> (file-write-date defaulted-source-truename)
221 (file-write-date defaulted-fasl-truename)))
222 (restart-case
223 (error "The object file ~A is~@
224 older than the presumed source:~% ~A."
225 defaulted-fasl-truename
226 defaulted-source-truename)
227 (source () :report "load source file"
228 defaulted-source-pathname)
229 (object () :report "load object file"
230 defaulted-fasl-pathname)))
231 (defaulted-fasl-truename defaulted-fasl-pathname)
232 (defaulted-source-truename defaulted-source-pathname))))
234 ;;; Load a code object. BOX-NUM objects are popped off the stack for
235 ;;; the boxed storage section, then CODE-LENGTH bytes of code are read in.
236 (defun load-code (nfuns box-num code-length stack ptr fasl-input)
237 (declare (fixnum box-num code-length))
238 (declare (simple-vector stack) (type index ptr))
239 (let* ((debug-info-index (+ ptr box-num))
240 (immobile-p (svref stack (1+ debug-info-index)))
241 (code (sb!c:allocate-code-object immobile-p box-num code-length)))
242 (setf (%code-debug-info code) (svref stack debug-info-index))
243 (loop for i of-type index from sb!vm:code-constants-offset
244 for j of-type index from ptr below debug-info-index
245 do (setf (code-header-ref code i) (svref stack j)))
246 (with-pinned-objects (code)
247 (read-n-bytes (%fasl-input-stream fasl-input)
248 (code-instructions code) 0 code-length)
249 (sb!c::set-code-entrypoints
250 code (loop repeat nfuns collect (read-varint-arg fasl-input)))
251 (sb!c::apply-fasl-fixups stack code))
252 code))
254 ;;;; linkage fixups
256 ;;; how we learn about assembler routines at startup
257 (defvar *!initial-assembler-routines*)
259 (defun get-asm-routine (name &aux (code *assembler-routines*))
260 (awhen (gethash (the symbol name) (car (%code-debug-info code)))
261 (sap-int (sap+ (code-instructions code) (car it)))))
263 (defun !loader-cold-init ()
264 (let* ((code *assembler-routines*)
265 (size (%code-code-size code))
266 (vector (the simple-vector *!initial-assembler-routines*))
267 (count (length vector))
268 (ht (make-hash-table :test 'eq)))
269 ;; code-debug-info stores the name->addr hashtable, but readonly
270 ;; space can't point to dynamic space. indirect through a static cons
271 (setf (%code-debug-info code)
272 (rplaca (let ((ptr (sap-int sb!vm:*static-space-free-pointer*)))
273 (setf sb!vm:*static-space-free-pointer*
274 (int-sap (+ ptr (* sb!vm:n-word-bytes 2))))
275 (%make-lisp-obj (logior ptr sb!vm:list-pointer-lowtag)))
276 ht))
277 (dotimes (i count)
278 (destructuring-bind (name . offset) (svref vector i)
279 (let ((next-offset (if (< (1+ i) count) (cdr (svref vector (1+ i))) size)))
280 (aver (> next-offset offset))
281 ;; store inclusive bounds on PC offset range
282 (setf (gethash name ht) (cons offset (1- next-offset))))))))
284 (defun !warm-load (file)
285 (restart-case (let ((sb!c::*source-namestring*
286 (format nil "SYS:~A" (substitute #\; #\/ file))))
287 (load file))
288 (abort ()
289 :report "Abort building SBCL."
290 (sb!ext:exit :code 1))))
292 ;;; Remember where cold artifacts went, and put the warm ones there too
293 ;;; because it looks nicer not to scatter them throughout the source tree.
294 ;;; *t-o-prefix* isn't known to the compiler, and we need it to be
295 ;;; initialized from a constant, so use read-time eval.
296 (defvar *!target-obj-prefix* #.sb-cold::*target-obj-prefix*)