1.0.37.57: better DEFMETHOD pretty-printing
[sbcl/pkhuong.git] / src / code / target-load.lisp
blob55a585d7b3f6017a9e43d3e8f032c7ccede85a3e
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 #!+sb-doc
18 "The source file types which LOAD looks for by default.")
20 (declaim (type (or pathname null) *load-truename* *load-pathname*))
21 (defvar *load-truename* nil
22 #!+sb-doc
23 "the TRUENAME of the file that LOAD is currently loading")
24 (defvar *load-pathname* nil
25 #!+sb-doc
26 "the defaulted pathname that LOAD is currently loading")
28 ;;;; LOAD-AS-SOURCE
30 ;;; Load a text stream. (Note that load-as-fasl is in another file.)
31 (defun load-as-source (stream verbose print)
32 (maybe-announce-load stream verbose)
33 (macrolet ((do-sexprs ((sexpr stream) &body body)
34 (aver (symbolp sexpr))
35 (with-unique-names (source-info)
36 (once-only ((stream stream))
37 `(if (handler-case (pathname stream)
38 (error () nil))
39 (let ((,source-info (sb!c::make-file-source-info
40 (pathname ,stream)
41 (stream-external-format ,stream))))
42 (setf (sb!c::source-info-stream ,source-info) ,stream)
43 (sb!c::do-forms-from-info ((,sexpr) ,source-info)
44 ,@body))
45 (do ((,sexpr (read ,stream nil *eof-object*)
46 (read ,stream nil *eof-object*)))
47 ((eq ,sexpr *eof-object*))
48 ,@body))))))
49 (do-sexprs (sexpr stream)
50 (if print
51 (let ((results (multiple-value-list (eval sexpr))))
52 (load-fresh-line)
53 (format t "~{~S~^, ~}~%" results))
54 (eval sexpr)))
55 t))
57 ;;;; LOAD itself
59 (define-condition fasl-header-missing (invalid-fasl)
60 ((fhsss :reader invalid-fasl-fhsss :initarg :fhsss))
61 (:report
62 (lambda (condition stream)
63 (format stream "~@<File ~S has a fasl file type, but no fasl header:~%~
64 Expected ~S, but got ~S.~:@>"
65 (invalid-fasl-stream condition)
66 (invalid-fasl-expected condition)
67 (invalid-fasl-fhsss condition)))))
70 ;;; The following comment preceded the pre 1.0.12.36 definition of
71 ;;; LOAD; it may no longer be accurate:
73 ;; FIXME: Daniel Barlow's ilsb.tar ILISP-for-SBCL patches contain an
74 ;; implementation of "DEFUN SOURCE-FILE" which claims, in a comment,
75 ;; that CMU CL does not correctly record source file information when
76 ;; LOADing a non-compiled file. Check whether this bug exists in SBCL
77 ;; and fix it if so.
79 (defun load (pathspec &key (verbose *load-verbose*) (print *load-print*)
80 (if-does-not-exist t) (external-format :default))
81 #!+sb-doc
82 "Load the file given by FILESPEC into the Lisp environment, returning
83 T on success."
84 (flet ((load-stream (stream faslp)
85 (let* (;; Bindings required by ANSI.
86 (*readtable* *readtable*)
87 (*package* (sane-package))
88 ;; FIXME: we should probably document the circumstances
89 ;; where *LOAD-PATHNAME* and *LOAD-TRUENAME* aren't
90 ;; pathnames during LOAD. ANSI makes no exceptions here.
91 (*load-pathname* (handler-case (pathname stream)
92 ;; FIXME: it should probably be a type
93 ;; error to try to get a pathname for a
94 ;; stream that doesn't have one, but I
95 ;; don't know if we guarantee that.
96 (error () nil)))
97 (*load-truename* (when *load-pathname*
98 (handler-case (truename stream)
99 (file-error () nil))))
100 ;; Bindings used internally.
101 (*load-depth* (1+ *load-depth*))
102 ;; KLUDGE: I can't find in the ANSI spec where it says
103 ;; that DECLAIM/PROCLAIM of optimization policy should
104 ;; have file scope. CMU CL did this, and it seems
105 ;; reasonable, but it might not be right; after all,
106 ;; things like (PROCLAIM '(TYPE ..)) don't have file
107 ;; scope, and I can't find anything under PROCLAIM or
108 ;; COMPILE-FILE or LOAD or OPTIMIZE which justifies this
109 ;; behavior. Hmm. -- WHN 2001-04-06
110 (sb!c::*policy* sb!c::*policy*))
111 (return-from load
112 (if faslp
113 (load-as-fasl stream verbose print)
114 (load-as-source stream verbose print))))))
115 ;; Case 1: stream.
116 (when (streamp pathspec)
117 (return-from load (load-stream pathspec (fasl-header-p pathspec))))
118 (let ((pathname (pathname pathspec)))
119 ;; Case 2: Open as binary, try to process as a fasl.
120 (with-open-stream
121 (stream (or (open pathspec :element-type '(unsigned-byte 8)
122 :if-does-not-exist nil)
123 (when (null (pathname-type pathspec))
124 (let ((defaulted-pathname
125 (probe-load-defaults pathspec)))
126 (if defaulted-pathname
127 (progn (setq pathname defaulted-pathname)
128 (open pathname
129 :if-does-not-exist
130 (if if-does-not-exist :error nil)
131 :element-type '(unsigned-byte 8))))))
132 (if if-does-not-exist
133 (error 'simple-file-error
134 :pathname pathspec
135 :format-control
136 "~@<Couldn't load ~S: file does not exist.~@:>"
137 :format-arguments (list pathspec)))))
138 (unless stream
139 (return-from load nil))
140 (let* ((real (probe-file stream))
141 (should-be-fasl-p
142 (and real (string-equal (pathname-type real) *fasl-file-type*))))
143 ;; Don't allow empty .fasls, and assume other empty files
144 ;; are source files.
145 (when (and (or should-be-fasl-p (not (eql 0 (file-length stream))))
146 (fasl-header-p stream :errorp should-be-fasl-p))
147 (return-from load (load-stream stream t)))))
148 ;; Case 3: Open using the gived external format, process as source.
149 (with-open-file (stream pathname :external-format external-format)
150 (load-stream stream nil)))))
152 ;; This implements the defaulting SBCL seems to have inherited from
153 ;; CMU. This routine does not try to perform any loading; all it does
154 ;; is return the pathname (not the truename) of a file to be loaded,
155 ;; or NIL if no such file can be found. This routine is supposed to
156 ;; signal an error if a fasl's timestamp is older than its source
157 ;; file, but we protect against errors in PROBE-FILE, because any of
158 ;; the ways that we might fail to find a defaulted file are reasons
159 ;; not to load it, but not worth exposing to the user who didn't
160 ;; expicitly ask us to load a file with a made-up name (e.g., the
161 ;; defaulted filename might exceed filename length limits).
162 (defun probe-load-defaults (pathname)
163 (destructuring-bind (defaulted-source-pathname
164 defaulted-source-truename
165 defaulted-fasl-pathname
166 defaulted-fasl-truename)
167 (loop for type in (list *load-source-default-type*
168 *fasl-file-type*)
169 as probe-pathname = (make-pathname :type type
170 :defaults pathname)
171 collect probe-pathname
172 collect (handler-case (probe-file probe-pathname)
173 (file-error () nil)))
174 (cond ((and defaulted-fasl-truename
175 defaulted-source-truename
176 (> (file-write-date defaulted-source-truename)
177 (file-write-date defaulted-fasl-truename)))
178 (restart-case
179 (error "The object file ~A is~@
180 older than the presumed source:~% ~A."
181 defaulted-fasl-truename
182 defaulted-source-truename)
183 (source () :report "load source file"
184 defaulted-source-pathname)
185 (object () :report "load object file"
186 defaulted-fasl-pathname)))
187 (defaulted-fasl-truename defaulted-fasl-pathname)
188 (defaulted-source-truename defaulted-source-pathname))))
190 ;;; Load a code object. BOX-NUM objects are popped off the stack for
191 ;;; the boxed storage section, then SIZE bytes of code are read in.
192 #!-x86
193 (defun load-code (box-num code-length)
194 (declare (fixnum box-num code-length))
195 (with-fop-stack t
196 (let ((code (sb!c:allocate-code-object box-num code-length))
197 (index (+ sb!vm:code-trace-table-offset-slot box-num)))
198 (declare (type index index))
199 (setf (%code-debug-info code) (pop-stack))
200 (dotimes (i box-num)
201 (declare (fixnum i))
202 (setf (code-header-ref code (decf index)) (pop-stack)))
203 (sb!sys:without-gcing
204 (read-n-bytes *fasl-input-stream*
205 (code-instructions code)
207 code-length))
208 code)))
210 ;;; Moving native code during a GC or purify is not so trivial on the
211 ;;; x86 port.
213 ;;; Our strategy for allowing the loading of x86 native code into the
214 ;;; dynamic heap requires that the addresses of fixups be saved for
215 ;;; all these code objects. After a purify these fixups can be
216 ;;; dropped. In CMU CL, this policy was enabled with
217 ;;; *ENABLE-DYNAMIC-SPACE-CODE*; in SBCL it's always used.
218 #!+x86
219 (defun load-code (box-num code-length)
220 (declare (fixnum box-num code-length))
221 (with-fop-stack t
222 (let ((stuff (list (pop-stack))))
223 (dotimes (i box-num)
224 (declare (fixnum i))
225 (push (pop-stack) stuff))
226 (let* ((dbi (car (last stuff))) ; debug-info
227 (tto (first stuff))) ; trace-table-offset
229 (setq stuff (nreverse stuff))
231 ;; FIXME: *LOAD-CODE-VERBOSE* should probably be #!+SB-SHOW.
232 (when *load-code-verbose*
233 (format t "stuff: ~S~%" stuff)
234 (format t
235 " : ~S ~S ~S ~S~%"
236 (sb!c::compiled-debug-info-p dbi)
237 (sb!c::debug-info-p dbi)
238 (sb!c::compiled-debug-info-name dbi)
239 tto)
240 (format t " loading to the dynamic space~%"))
242 (let ((code (sb!c:allocate-code-object box-num code-length))
243 (index (+ sb!vm:code-trace-table-offset-slot box-num)))
244 (declare (type index index))
245 (when *load-code-verbose*
246 (format t
247 " obj addr=~X~%"
248 (sb!kernel::get-lisp-obj-address code)))
249 (setf (%code-debug-info code) (pop stuff))
250 (dotimes (i box-num)
251 (declare (fixnum i))
252 (setf (code-header-ref code (decf index)) (pop stuff)))
253 (sb!sys:without-gcing
254 (read-n-bytes *fasl-input-stream*
255 (code-instructions code)
257 code-length))
258 code)))))
260 ;;;; linkage fixups
262 ;;; how we learn about assembler routines at startup
263 (defvar *!initial-assembler-routines*)
265 (defun !loader-cold-init ()
266 (/show0 "/!loader-cold-init")
267 (dolist (routine *!initial-assembler-routines*)
268 (setf (gethash (car routine) *assembler-routines*) (cdr routine))))