(defun cold-intern (symbol &optional (package (symbol-package symbol)))
;; Anything on the cross-compilation host which refers to the target
- ;; machinery through the host SB-XC package can be translated to
+ ;; machinery through the host SB-XC package should be translated to
;; something on the target which refers to the same machinery
;; through the target COMMON-LISP package.
(let ((p (find-package "SB-XC")))
(when (eq (symbol-package symbol) p)
(setf symbol (intern (symbol-name symbol) *cl-package*))))
+ ;; Make sure that the symbol has an appropriate package. In
+ ;; particular, catch the so-easy-to-make error of typing something
+ ;; like SB-KERNEL:%BYTE-BLT in cold sources when what you really
+ ;; need is SB!KERNEL:%BYTE-BLT.
+ (let ((package-name (package-name package)))
+ (cond ((find package-name '("COMMON-LISP" "KEYWORD") :test #'string=)
+ ;; That's OK then.
+ (values))
+ ((string= package-name "SB!" :end1 3 :end2 3)
+ ;; That looks OK, too. (All the target-code packages
+ ;; have names like that.)
+ (values))
+ (t
+ ;; looks bad: maybe COMMON-LISP-USER? maybe an extension
+ ;; package in the xc host? something we can't think of
+ ;; a valid reason to dump, anyway...
+ (error "internal error: PACKAGE-NAME=~S looks too much like a typo."
+ package-name))))
+
(let (;; Information about each cold-interned symbol is stored
;; in COLD-INTERN-INFO.
;; (CAR COLD-INTERN-INFO) = descriptor of symbol
;; DEFINE-FOP) instead of creating a code, and
;;; (2) stores its definition in the *COLD-FOP-FUNS* vector,
;;; instead of storing in the *FOP-FUNS* vector.
-(defmacro define-cold-fop ((name &optional (pushp t)) &rest forms)
- (aver (member pushp '(nil t :nope)))
+(defmacro define-cold-fop ((name &key (pushp t) (stackp t)) &rest forms)
+ (aver (member pushp '(nil t)))
+ (aver (member stackp '(nil t)))
(let ((code (get name 'fop-code))
(fname (symbolicate "COLD-" name)))
(unless code
(error "~S is not a defined FOP." name))
`(progn
(defun ,fname ()
- ,@(if (eq pushp :nope)
- forms
- `((with-fop-stack ,pushp ,@forms))))
+ ,@(if stackp
+ `((with-fop-stack ,pushp ,@forms))
+ forms))
(setf (svref *cold-fop-funs* ,code) #',fname))))
-(defmacro clone-cold-fop ((name &optional (pushp t)) (small-name) &rest forms)
- (aver (member pushp '(nil t :nope)))
+(defmacro clone-cold-fop ((name &key (pushp t) (stackp t)) (small-name) &rest forms)
+ (aver (member pushp '(nil t)))
+ (aver (member stackp '(nil t)))
`(progn
(macrolet ((clone-arg () '(read-arg 4)))
- (define-cold-fop (,name ,pushp) ,@forms))
+ (define-cold-fop (,name :pushp ,pushp :stackp ,stackp) ,@forms))
(macrolet ((clone-arg () '(read-arg 1)))
- (define-cold-fop (,small-name ,pushp) ,@forms))))
+ (define-cold-fop (,small-name :pushp ,pushp :stackp ,stackp) ,@forms))))
;;; Cause a fop to be undefined in cold load.
(defmacro not-cold-fop (name)
(define-cold-fop (fop-empty-list) *nil-descriptor*)
(define-cold-fop (fop-truth) (cold-intern t))
-(define-cold-fop (fop-normal-load :nope)
+(define-cold-fop (fop-normal-load :stackp nil)
(setq *fop-funs* *normal-fop-funs*))
-(define-fop (fop-maybe-cold-load 82 :nope)
+(define-fop (fop-maybe-cold-load 82 :stackp nil)
(when *cold-load-filename*
(setq *fop-funs* *cold-fop-funs*)))
-(define-cold-fop (fop-maybe-cold-load :nope))
+(define-cold-fop (fop-maybe-cold-load :stackp nil))
(clone-cold-fop (fop-struct)
(fop-small-struct)
;;;; cold fops for loading numbers
(defmacro define-cold-number-fop (fop)
- `(define-cold-fop (,fop :nope)
+ `(define-cold-fop (,fop :stackp nil)
;; Invoke the ordinary warm version of this fop to push the
;; number.
(,fop)
*load-time-value-counter*
sb!vm:simple-vector-widetag)))
-(define-cold-fop (fop-funcall-for-effect nil)
+(define-cold-fop (fop-funcall-for-effect :pushp nil)
(if (= (read-arg 1) 0)
(cold-push (pop-stack)
*current-reversed-cold-toplevels*)
\f
;;;; cold fops for fixing up circularities
-(define-cold-fop (fop-rplaca nil)
+(define-cold-fop (fop-rplaca :pushp nil)
(let ((obj (svref *current-fop-table* (read-arg 4)))
(idx (read-arg 4)))
(write-memory (cold-nthcdr idx obj) (pop-stack))))
-(define-cold-fop (fop-rplacd nil)
+(define-cold-fop (fop-rplacd :pushp nil)
(let ((obj (svref *current-fop-table* (read-arg 4)))
(idx (read-arg 4)))
(write-wordindexed (cold-nthcdr idx obj) 1 (pop-stack))))
-(define-cold-fop (fop-svset nil)
+(define-cold-fop (fop-svset :pushp nil)
(let ((obj (svref *current-fop-table* (read-arg 4)))
(idx (read-arg 4)))
(write-wordindexed obj
(#.sb!vm:other-pointer-lowtag 2)))
(pop-stack))))
-(define-cold-fop (fop-structset nil)
+(define-cold-fop (fop-structset :pushp nil)
(let ((obj (svref *current-fop-table* (read-arg 4)))
(idx (read-arg 4)))
(write-wordindexed obj (1+ idx) (pop-stack))))
-(define-cold-fop (fop-nthcdr t)
+;;; In the original CMUCL code, this actually explicitly declared PUSHP
+;;; to be T, even though that's what it defaults to in DEFINE-COLD-FOP.
+(define-cold-fop (fop-nthcdr)
(cold-nthcdr (read-arg 4) (pop-stack)))
(defun cold-nthcdr (index obj)
;; (SETF CAR).
(make-hash-table :test 'equal))
-(define-cold-fop (fop-fset nil)
+(define-cold-fop (fop-fset :pushp nil)
(let* ((fn (pop-stack))
(cold-name (pop-stack))
(warm-name (warm-fun-name cold-name)))
(define-cold-code-fop fop-small-code (read-arg 1) (read-arg 2))
-(clone-cold-fop (fop-alter-code nil)
+(clone-cold-fop (fop-alter-code :pushp nil)
(fop-byte-alter-code)
(let ((slot (clone-arg))
(value (pop-stack))
(defparameter validate-entry-type-code 3845)
(defparameter directory-entry-type-code 3841)
(defparameter new-directory-entry-type-code 3861)
-(defparameter initial-function-entry-type-code 3863)
+(defparameter initial-fun-entry-type-code 3863)
(defparameter end-entry-type-code 3840)
(declaim (ftype (function (sb!vm:word) sb!vm:word) write-long))
(output-gspace *dynamic*)
;; Write the initial function.
- (write-long initial-function-entry-type-code)
+ (write-long initial-fun-entry-type-code)
(write-long 3)
(let* ((cold-name (cold-intern '!cold-init))
(cold-fdefn (cold-fdefinition-object cold-name))
- (initial-function (read-wordindexed cold-fdefn
- sb!vm:fdefn-fun-slot)))
+ (initial-fun (read-wordindexed cold-fdefn
+ sb!vm:fdefn-fun-slot)))
(format t
- "~&/(DESCRIPTOR-BITS INITIAL-FUNCTION)=#X~X~%"
- (descriptor-bits initial-function))
- (write-long (descriptor-bits initial-function)))
+ "~&/(DESCRIPTOR-BITS INITIAL-FUN)=#X~X~%"
+ (descriptor-bits initial-fun))
+ (write-long (descriptor-bits initial-fun)))
;; Write the End entry.
(write-long end-entry-type-code)
projects / sbcl.git / blobdiff