X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffop.lisp;h=bf65fdda1f0755752d46a94ac7373c27a0816ddf;hb=3c65762b927af861c9c8bc416e4cbac9a14ec0c3;hp=fce38feddd2906c6893fe7f186244af7c094c5d4;hpb=aa2dc9529460ea0d9c99998dc87283fc1a43e808;p=sbcl.git

diff --git a/src/code/fop.lisp b/src/code/fop.lisp
index fce38fe..bf65fdd 100644
--- a/src/code/fop.lisp
+++ b/src/code/fop.lisp
@@ -24,7 +24,6 @@
 	  `(with-fop-stack ,pushp ,@forms)))
      (%define-fop ',name ,fop-code)))
 
-;;; FIXME: This can be byte coded.
 (defun %define-fop (name code)
   (let ((oname (svref *fop-names* code)))
     (when (and oname (not (eq oname name)))
@@ -126,7 +125,7 @@
   #+sb-xc-host ; since xc host doesn't know how to compile %PRIMITIVE
   (error "FOP-MISC-TRAP can't be defined without %PRIMITIVE.")
   #-sb-xc-host
-  (%primitive sb!c:make-other-immediate-type 0 sb!vm:unbound-marker-type))
+  (%primitive sb!c:make-other-immediate-type 0 sb!vm:unbound-marker-widetag))
 
 (define-fop (fop-character 68)
   (code-char (read-arg 3)))
@@ -410,7 +409,7 @@
   (let* ((rank (read-arg 4))
 	 (vec (pop-stack))
 	 (length (length vec))
-	 (res (make-array-header sb!vm:simple-array-type rank)))
+	 (res (make-array-header sb!vm:simple-array-widetag rank)))
     (declare (simple-array vec)
 	     (type (unsigned-byte 24) rank))
     (set-array-header res vec length length 0
@@ -605,14 +604,28 @@
     (sb!vm:sanctify-for-execution component)
     component))
 
-;;; This a no-op except in cold load. (In ordinary warm load,
-;;; everything involved with function definition can be handled nicely
-;;; by ordinary toplevel code.)
 (define-fop (fop-fset 74 nil)
-  (pop-stack)
-  (pop-stack))
+  ;; Ordinary, not-for-cold-load code shouldn't need to mess with this
+  ;; at all, since it's only used as part of the conspiracy between
+  ;; the cross-compiler and GENESIS to statically link FDEFINITIONs
+  ;; for cold init.
+  (warn "~@<FOP-FSET seen in ordinary load (not cold load) -- quite strange! ~
+If you didn't do something strange to cause this, please report it as a ~
+bug.~:@>")
+  ;; Unlike CMU CL, we don't treat this as a no-op in ordinary code.
+  ;; If the user (or, more likely, developer) is trying to reload
+  ;; compiled-for-cold-load code into a warm SBCL, we'll do a warm
+  ;; assignment. (This is partly for abstract tidiness, since the warm
+  ;; assignment is the closest analogy to what happens at cold load,
+  ;; and partly because otherwise our compiled-for-cold-load code will
+  ;; fail, since in SBCL things like compiled-for-cold-load %DEFUN
+  ;; depend more strongly than in CMU CL on FOP-FSET actually doing
+  ;; something.)
+  (let ((fn (pop-stack))
+	(name (pop-stack)))
+    (setf (fdefinition name) fn)))
 
-;;; Modify a slot in a Constants object.
+;;; Modify a slot in a CONSTANTS object.
 (define-cloned-fops (fop-alter-code 140 nil) (fop-byte-alter-code 141)
   (let ((value (pop-stack))
 	(code (pop-stack)))
@@ -633,33 +646,17 @@
       (error "internal error: unaligned function object, offset = #X~X"
 	     offset))
     (let ((fun (%primitive sb!c:compute-function code-object offset)))
-      (setf (%function-self fun) fun)
-      (setf (%function-next fun) (%code-entry-points code-object))
+      (setf (%simple-fun-self fun) fun)
+      (setf (%simple-fun-next fun) (%code-entry-points code-object))
       (setf (%code-entry-points code-object) fun)
-      (setf (%function-name fun) name)
-      (setf (%function-arglist fun) arglist)
-      (setf (%function-type fun) type)
+      (setf (%simple-fun-name fun) name)
+      (setf (%simple-fun-arglist fun) arglist)
+      (setf (%simple-fun-type fun) type)
       ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL.
       #+nil (when *load-print*
 	      (load-fresh-line)
 	      (format t "~S defined~%" fun))
       fun)))
-
-(define-fop (fop-make-byte-compiled-function 143)
-  (let* ((size (read-arg 1))
-	 (layout (pop-stack))
-	 (res (%make-funcallable-instance size layout)))
-    (declare (type index size))
-    (do ((n (1- size) (1- n)))
-	((minusp n))
-      (declare (type (integer -1 #.most-positive-fixnum) n))
-      (setf (%funcallable-instance-info res n) (pop-stack)))
-    (initialize-byte-compiled-function res)
-    ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL.
-    #+nil (when *load-print*
-	    (load-fresh-line)
-	    (format t "~S defined~%" res))
-    res))
 
 ;;;; Some Dylan FOPs used to live here. By 1 November 1998 the code
 ;;;; was sufficiently stale that the functions it called were no