(macrolet ((clone-arg () '(read-word-arg)))
(define-fop (,name ,code :pushp ,pushp :stackp ,stackp) ,@forms))
(macrolet ((clone-arg () '(read-byte-arg)))
- (define-fop (,small-name ,small-code :pushp ,pushp :stackp stackp) ,@forms))))
+ (define-fop (,small-name ,small-code :pushp ,pushp :stackp ,stackp) ,@forms))))
;;; a helper function for reading string values from FASL files: sort
;;; of like READ-SEQUENCE specialized for files of (UNSIGNED-BYTE 8),
;;; with an automatic conversion from (UNSIGNED-BYTE 8) into CHARACTER
;;; for each element read
(declaim (ftype (function (stream simple-string &optional index) (values))
- read-string-as-bytes #!+sb-unicode read-string-as-words))
+ read-string-as-bytes
+ #!+sb-unicode read-string-as-unsigned-byte-32))
(defun read-string-as-bytes (stream string &optional (length (length string)))
(dotimes (i length)
(setf (aref string i)
;; it as an alternate definition, protected with #-SB-XC-HOST.
(values))
#!+sb-unicode
-(defun read-string-as-words (stream string &optional (length (length string)))
- #+sb-xc-host (bug "READ-STRING-AS-WORDS called")
+(defun read-string-as-unsigned-byte-32
+ (stream string &optional (length (length string)))
+ #+sb-xc-host (bug "READ-STRING-AS-UNSIGNED-BYTE-32 called")
(dotimes (i length)
(setf (aref string i)
(let ((code 0))
- ;; FIXME: is this the same as READ-WORD-ARG?
- (dotimes (k sb!vm:n-word-bytes (sb!xc:code-char code))
+ (dotimes (k 4 (sb!xc:code-char code))
(setf code (logior code (ash (read-byte stream)
(* k sb!vm:n-byte-bits))))))))
(values))
(/show0 "THROWing FASL-GROUP-END")
(throw 'fasl-group-end t))
-;;; In the normal loader, we just ignore these. GENESIS overwrites
-;;; FOP-MAYBE-COLD-LOAD with something that knows whether to revert to
-;;; cold-loading or not.
-(define-fop (fop-normal-load 81 :stackp nil))
-(define-fop (fop-maybe-cold-load 82 :stackp nil))
+;;; We used to have FOP-NORMAL-LOAD as 81 and FOP-MAYBE-COLD-LOAD as
+;;; 82 until GENESIS learned how to work with host symbols and
+;;; packages directly instead of piggybacking on the host code.
(define-fop (fop-verify-table-size 62 :stackp nil)
(let ((expected-index (read-word-arg)))
,n-buffer
,n-size)
#-sb-xc-host
- (#!+sb-unicode read-string-as-words
+ (#!+sb-unicode read-string-as-unsigned-byte-32
#!-sb-unicode read-string-as-bytes
*fasl-input-stream*
,n-buffer
#!-sb-unicode
(read-string-as-bytes *fasl-input-stream* res)
#!+sb-unicode
- (read-string-as-words *fasl-input-stream* res)
+ (read-string-as-unsigned-byte-32 *fasl-input-stream* res)
(push-fop-table (make-symbol res))))
(define-fop (fop-package 14)
(find-undeleted-package-or-lose (pop-stack)))
+
+(define-cloned-fops (fop-named-package-save 156 :stackp nil)
+ (fop-small-named-package-save 157)
+ (let* ((arg (clone-arg))
+ (package-name (make-string arg)))
+ #+sb-xc-host
+ (read-string-as-bytes *fasl-input-stream* package-name)
+ #-sb-xc-host
+ (#!-sb-unicode read-string-as-bytes
+ #!+sb-unicode read-string-as-unsigned-byte-32
+ *fasl-input-stream* package-name)
+ (push-fop-table (find-undeleted-package-or-lose package-name))))
\f
;;;; fops for loading numbers
(define-cloned-fops (fop-character-string 161) (fop-small-character-string 162)
(let* ((arg (clone-arg))
(res (make-string arg)))
- (read-string-as-words *fasl-input-stream* res)
+ (read-string-as-unsigned-byte-32 *fasl-input-stream* res)
res)))
(define-cloned-fops (fop-vector 39) (fop-small-vector 40)
(dimensions () (cons (pop-stack) dimensions)))
((zerop i) dimensions)
(declare (type index i)))
- nil)
+ nil
+ t)
res))
(define-fop (fop-single-float-vector 84)
(name (pop-stack)))
(setf (fdefinition name) fn)))
+(define-fop (fop-note-debug-source 174 :pushp nil)
+ (warn "~@<FOP-NOTE-DEBUG-SOURCE seen in ordinary load (not cold load) -- ~
+very strange! If you didn't do something to cause this, please report it as ~
+a bug.~@:>")
+ ;; as with COLD-FSET above, we are going to be lenient with coming
+ ;; across this fop in a warm SBCL.
+ (let ((debug-source (pop-stack)))
+ (setf (sb!c::debug-source-compiled debug-source) (get-universal-time)
+ (sb!c::debug-source-created debug-source)
+ (file-write-date (sb!c::debug-source-namestring debug-source)))))
+
;;; Modify a slot in a CONSTANTS object.
(define-cloned-fops (fop-alter-code 140 :pushp nil) (fop-byte-alter-code 141)
(let ((value (pop-stack))
#+sb-xc-host ; since xc host doesn't know how to compile %PRIMITIVE
(error "FOP-FUN-ENTRY can't be defined without %PRIMITIVE.")
#-sb-xc-host
- (let ((type (pop-stack))
+ (let ((info (pop-stack))
+ (type (pop-stack))
(arglist (pop-stack))
(name (pop-stack))
(code-object (pop-stack))
(setf (%simple-fun-name fun) name)
(setf (%simple-fun-arglist fun) arglist)
(setf (%simple-fun-type fun) type)
+ (setf (%simple-fun-info fun) info)
;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL.
#+nil (when *load-print*
(load-fresh-line)
projects / sbcl.git / blobdiff