X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffop.lisp;h=9891b4690dfd1f599c2d5077a244aaedfe503743;hb=55c7345f18c442abbbe46c66b51bcab612cae65f;hp=617983304c8893266d54efb9e8224b8497660ff0;hpb=3ca73f72116001579bde0f59e5aa1359cc41631e;p=sbcl.git diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 6179833..9891b46 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -71,14 +71,15 @@ (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) @@ -91,13 +92,13 @@ ;; 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)) @@ -172,11 +173,9 @@ (/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))) @@ -210,7 +209,7 @@ ,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 @@ -264,11 +263,23 @@ #!-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)))) ;;;; fops for loading numbers @@ -392,7 +403,7 @@ (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) @@ -416,7 +427,8 @@ (dimensions () (cons (pop-stack) dimensions))) ((zerop i) dimensions) (declare (type index i))) - nil) + nil + t) res)) (define-fop (fop-single-float-vector 84) @@ -638,6 +650,17 @@ bug.~:@>") (name (pop-stack))) (setf (fdefinition name) fn))) +(define-fop (fop-note-debug-source 174 :pushp nil) + (warn "~@") + ;; 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)) @@ -649,7 +672,8 @@ bug.~:@>") #+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)) @@ -664,6 +688,7 @@ bug.~:@>") (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)