X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffop.lisp;h=22df57fde772a7ac8b6af28f4b3e6fa48062532a;hb=860543cc7ba0266e41e1d41ac9b6a208f3795f1a;hp=5d67fee33d91c4141aedcbb1f621a8b5d07ca9dc;hpb=d40a76606c86722b0aef8179155f9f2840739b72;p=sbcl.git

diff --git a/src/code/fop.lisp b/src/code/fop.lisp
index 5d67fee..22df57f 100644
--- a/src/code/fop.lisp
+++ b/src/code/fop.lisp
@@ -4,24 +4,19 @@
 
 ;;; Define NAME as a fasl operation, with op-code FOP-CODE. PUSHP
 ;;; describes what the body does to the fop stack:
-;;;   :NOPE
-;;;     The body neither pushes or pops the fop stack.
 ;;;   T
 ;;;     The body might pop the fop stack. The result of the body is 
 ;;;     pushed on the fop stack.
 ;;;   NIL
 ;;;     The body might pop the fop stack. The result of the body is
 ;;;     discarded.
-;;;
-;;; FIXME: Make PUSHP into a &KEY argument accepting a booleana value.
-;;; Handle the :PUSHP :NOPE case with a separate :STACKP NIL argument,
-;;; meaning "the body doesn't interact with the FOP stack."
-(defmacro define-fop ((name fop-code &optional (pushp t)) &rest forms)
+;;; STACKP describes whether or not the body interacts with the fop stack.
+(defmacro define-fop ((name fop-code &key (pushp t) (stackp t)) &rest forms)
   `(progn
      (defun ,name ()
-       ,(if (eq pushp :nope)
-	  `(progn ,@forms)
-	  `(with-fop-stack ,pushp ,@forms)))
+       ,(if stackp
+            `(with-fop-stack ,pushp ,@forms)
+            `(progn ,@forms)))
      (%define-fop ',name ,fop-code)))
 
 (defun %define-fop (name code)
@@ -62,14 +57,15 @@
 ;;; Some of this logic is already in DUMP-FOP*, but that still requires the
 ;;; caller to know that it's a 1-byte-arg/4-byte-arg cloned fop pair, and to
 ;;; know both the 1-byte-arg and the 4-byte-arg fop names. -- WHN 19990902
-(defmacro define-cloned-fops ((name code &optional (pushp t))
+(defmacro define-cloned-fops ((name code &key (pushp t) (stackp t))
 			      (small-name small-code) &rest forms)
-  (aver (member pushp '(nil t :nope)))
+  (aver (member pushp '(nil t)))
+  (aver (member stackp '(nil t)))
   `(progn
      (macrolet ((clone-arg () '(read-arg 4)))
-       (define-fop (,name ,code ,pushp) ,@forms))
+       (define-fop (,name ,code :pushp ,pushp :stackp ,stackp) ,@forms))
      (macrolet ((clone-arg () '(read-arg 1)))
-       (define-fop (,small-name ,small-code ,pushp) ,@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),
@@ -105,15 +101,15 @@
 ;;; into fasl files for debugging purposes. There's no shortage of
 ;;; unused fop codes, so we add this second NOP, which reads 4
 ;;; arbitrary bytes and discards them.
-(define-fop (fop-nop4 137 :nope)
+(define-fop (fop-nop4 137 :stackp nil)
   (let ((arg (read-arg 4)))
     (declare (ignorable arg))
     #!+sb-show
     (when *show-fop-nop4-p*
       (format *debug-io* "~&/FOP-NOP4 ARG=~W=#X~X~%" arg arg))))
 
-(define-fop (fop-nop 0 :nope))
-(define-fop (fop-pop 1 nil) (push-fop-table (pop-stack)))
+(define-fop (fop-nop 0 :stackp nil))
+(define-fop (fop-pop 1 :pushp nil) (push-fop-table (pop-stack)))
 (define-fop (fop-push 2) (svref *current-fop-table* (read-arg 4)))
 (define-fop (fop-byte-push 3) (svref *current-fop-table* (read-arg 1)))
 
@@ -141,7 +137,7 @@
     (declare (type index size))
     (do ((n (1- size) (1- n)))
 	((minusp n))
-      (declare (type (integer -1 #.most-positive-fixnum) n))
+      (declare (type index-or-minus-1 n))
       (setf (%instance-ref res n) (pop-stack)))
     res))
 
@@ -152,23 +148,23 @@
 	(name (pop-stack)))
     (find-and-init-or-check-layout name length inherits depthoid)))
 
-(define-fop (fop-end-group 64 :nope)
+(define-fop (fop-end-group 64 :stackp nil)
   (/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 :nope))
-(define-fop (fop-maybe-cold-load 82 :nope))
+(define-fop (fop-normal-load 81 :stackp nil))
+(define-fop (fop-maybe-cold-load 82 :stackp nil))
 
-(define-fop (fop-verify-table-size 62 :nope)
+(define-fop (fop-verify-table-size 62 :stackp nil)
   (let ((expected-index (read-arg 4)))
     (unless (= *current-fop-table-index* expected-index)
-      (error "internal error: fasl table of improper size"))))
-(define-fop (fop-verify-empty-stack 63 :nope)
+      (bug "fasl table of improper size"))))
+(define-fop (fop-verify-empty-stack 63 :stackp nil)
   (unless (= *fop-stack-pointer* *fop-stack-pointer-on-entry*)
-    (error "internal error: fasl stack not empty when it should be")))
+    (bug "fasl stack not empty when it should be")))
 
 ;;;; fops for loading symbols
 
@@ -294,64 +290,41 @@
   (let ((im (pop-stack)))
     (%make-complex (pop-stack) im)))
 
-(define-fop (fop-complex-single-float 72)
-  (prepare-for-fast-read-byte *fasl-input-stream*
-    (prog1
-	(complex (make-single-float (fast-read-s-integer 4))
-		 (make-single-float (fast-read-s-integer 4)))
-      (done-with-fast-read-byte))))
+(macrolet ((fast-read-single-float ()
+             '(make-single-float (fast-read-s-integer 4)))
+           (fast-read-double-float ()
+             '(let ((lo (fast-read-u-integer 4)))
+               (make-double-float (fast-read-s-integer 4) lo)))
+           #!+long-float
+           (fast-read-long-float ()
+             '(let ((lo (fast-read-u-integer 4))
+                    #!+sparc (mid (fast-read-u-integer 4))
+                    (hi (fast-read-u-integer 4)) ; XXX
+                    (exp (fast-read-s-integer #!+x86 2 #!+sparc 4)))
+               (make-long-float exp hi #!+sparc mid lo))))
+  (macrolet ((define-complex-fop (name fop-code type)
+               (let ((reader (symbolicate "FAST-READ-" type)))
+                 `(define-fop (,name ,fop-code)
+                      (prepare-for-fast-read-byte *fasl-input-stream*
+                        (prog1
+                            (complex (,reader) (,reader))
+                          (done-with-fast-read-byte))))))
+             (define-float-fop (name fop-code type)
+               (let ((reader (symbolicate "FAST-READ-" type)))
+                 `(define-fop (,name ,fop-code)
+                      (prepare-for-fast-read-byte *fasl-input-stream*
+                        (prog1
+                            (,reader)
+                          (done-with-fast-read-byte)))))))
+    (define-complex-fop fop-complex-single-float 72 single-float)
+    (define-complex-fop fop-complex-double-float 73 double-float)
+    #!+long-float
+    (define-complex-fop fop-complex-long-float 67 long-float)
+    (define-float-fop fop-single-float 46 single-float)
+    (define-float-fop fop-double-float 47 double-float)
+    #!+long-float
+    (define-float-fop fop-long-float 52 long-float)))
 
-(define-fop (fop-complex-double-float 73)
-  (prepare-for-fast-read-byte *fasl-input-stream*
-    (prog1
-	(let* ((re-lo (fast-read-u-integer 4))
-	       (re-hi (fast-read-u-integer 4))
-	       (re (make-double-float re-hi re-lo))
-	       (im-lo (fast-read-u-integer 4))
-	       (im-hi (fast-read-u-integer 4))
-	       (im (make-double-float im-hi im-lo)))
-	  (complex re im))
-      (done-with-fast-read-byte))))
-
-#!+long-float
-(define-fop (fop-complex-long-float 67)
-  (prepare-for-fast-read-byte *fasl-input-stream*
-    (prog1
-	(let* ((re-lo (fast-read-u-integer 4))
-	       #!+sparc (re-mid (fast-read-u-integer 4))
-	       (re-hi (fast-read-u-integer 4))
-	       (re-exp (fast-read-s-integer #!+x86 2 #!+sparc 4))
-	       (re (make-long-float re-exp re-hi #!+sparc re-mid re-lo))
-	       (im-lo (fast-read-u-integer 4))
-	       #!+sparc (im-mid (fast-read-u-integer 4))
-	       (im-hi (fast-read-u-integer 4))
-	       (im-exp (fast-read-s-integer #!+x86 2 #!+sparc 4))
-	       (im (make-long-float im-exp im-hi #!+sparc im-mid im-lo)))
-	  (complex re im))
-      (done-with-fast-read-byte))))
-
-(define-fop (fop-single-float 46)
-  (prepare-for-fast-read-byte *fasl-input-stream*
-    (prog1 (make-single-float (fast-read-s-integer 4))
-      (done-with-fast-read-byte))))
-
-(define-fop (fop-double-float 47)
-  (prepare-for-fast-read-byte *fasl-input-stream*
-    (prog1
-	(let ((lo (fast-read-u-integer 4)))
-	  (make-double-float (fast-read-s-integer 4) lo))
-      (done-with-fast-read-byte))))
-
-#!+long-float
-(define-fop (fop-long-float 52)
-  (prepare-for-fast-read-byte *fasl-input-stream*
-    (prog1
-	(let ((lo (fast-read-u-integer 4))
-	      #!+sparc (mid (fast-read-u-integer 4))
-	      (hi (fast-read-u-integer 4))
-	      (exp (fast-read-s-integer #!+x86 2 #!+sparc 4)))
-	  (make-long-float exp hi #!+sparc mid lo))
-      (done-with-fast-read-byte))))
 
 ;;;; loading lists
 
@@ -482,8 +455,7 @@
 		  (8 (make-array len :element-type '(unsigned-byte 8)))
 		  (16 (make-array len :element-type '(unsigned-byte 16)))
 		  (32 (make-array len :element-type '(unsigned-byte 32)))
-		  (t (error "internal error: losing i-vector element size: ~S"
-			    size)))))
+		  (t (bug "losing i-vector element size: ~S" size)))))
       (declare (type index len))
       (done-with-fast-read-byte)
       (read-n-bytes *fasl-input-stream*
@@ -504,8 +476,7 @@
  		  (16 (make-array len :element-type '(signed-byte 16)))
  		  (30 (make-array len :element-type '(signed-byte 30)))
  		  (32 (make-array len :element-type '(signed-byte 32)))
- 		  (t (error "internal error: losing si-vector element size: ~S"
-			    size)))))
+ 		  (t (bug "losing si-vector element size: ~S" size)))))
       (declare (type index len))
       (done-with-fast-read-byte)
       (read-n-bytes *fasl-input-stream*
@@ -528,7 +499,7 @@
     ;; fasl loading.
     result))
 
-(define-fop (fop-eval-for-effect 54 nil)
+(define-fop (fop-eval-for-effect 54 :pushp nil)
   (let ((result (eval (pop-stack))))
     ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL.
     (declare (ignore result))
@@ -546,7 +517,7 @@
 	    ((zerop n) (apply (pop-stack) args))
 	  (declare (type index n))))))
 
-(define-fop (fop-funcall-for-effect 56 nil)
+(define-fop (fop-funcall-for-effect 56 :pushp nil)
   (let ((arg (read-arg 1)))
     (if (zerop arg)
 	(funcall (pop-stack))
@@ -557,19 +528,19 @@
 
 ;;;; fops for fixing up circularities
 
-(define-fop (fop-rplaca 200 nil)
+(define-fop (fop-rplaca 200 :pushp nil)
   (let ((obj (svref *current-fop-table* (read-arg 4)))
 	(idx (read-arg 4))
 	(val (pop-stack)))
     (setf (car (nthcdr idx obj)) val)))
 
-(define-fop (fop-rplacd 201 nil)
+(define-fop (fop-rplacd 201 :pushp nil)
   (let ((obj (svref *current-fop-table* (read-arg 4)))
 	(idx (read-arg 4))
 	(val (pop-stack)))
     (setf (cdr (nthcdr idx obj)) val)))
 
-(define-fop (fop-svset 202 nil)
+(define-fop (fop-svset 202 :pushp nil)
   (let* ((obi (read-arg 4))
 	 (obj (svref *current-fop-table* obi))
 	 (idx (read-arg 4))
@@ -578,12 +549,14 @@
 	(setf (%instance-ref obj idx) val)
 	(setf (svref obj idx) val))))
 
-(define-fop (fop-structset 204 nil)
+(define-fop (fop-structset 204 :pushp nil)
   (setf (%instance-ref (svref *current-fop-table* (read-arg 4))
 		       (read-arg 4))
 	(pop-stack)))
 
-(define-fop (fop-nthcdr 203 t)
+;;; In the original CMUCL code, this actually explicitly declared PUSHP
+;;; to be T, even though that's what it defaults to in DEFINE-FOP.
+(define-fop (fop-nthcdr 203)
   (nthcdr (read-arg 4) (pop-stack)))
 
 ;;;; fops for loading functions
@@ -595,10 +568,10 @@
 ;;; putting the implementation and version in required fields in the
 ;;; fasl file header.)
 
-(define-fop (fop-code 58 :nope)
+(define-fop (fop-code 58 :stackp nil)
   (load-code (read-arg 4) (read-arg 4)))
 
-(define-fop (fop-small-code 59 :nope)
+(define-fop (fop-small-code 59 :stackp nil)
   (load-code (read-arg 1) (read-arg 2)))
 
 (define-fop (fop-fdefinition 60)
@@ -609,7 +582,7 @@
     (sb!vm:sanctify-for-execution component)
     component))
 
-(define-fop (fop-fset 74 nil)
+(define-fop (fop-fset 74 :pushp nil)
   ;; 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
@@ -631,7 +604,7 @@ bug.~:@>")
     (setf (fdefinition name) fn)))
 
 ;;; Modify a slot in a CONSTANTS object.
-(define-cloned-fops (fop-alter-code 140 nil) (fop-byte-alter-code 141)
+(define-cloned-fops (fop-alter-code 140 :pushp nil) (fop-byte-alter-code 141)
   (let ((value (pop-stack))
 	(code (pop-stack)))
     (setf (code-header-ref code (clone-arg)) value)
@@ -648,9 +621,8 @@ bug.~:@>")
 	(offset (read-arg 4)))
     (declare (type index offset))
     (unless (zerop (logand offset sb!vm:lowtag-mask))
-      (error "internal error: unaligned function object, offset = #X~X"
-	     offset))
-    (let ((fun (%primitive sb!c:compute-function code-object offset)))
+      (bug "unaligned function object, offset = #X~X" offset))
+    (let ((fun (%primitive sb!c:compute-fun code-object offset)))
       (setf (%simple-fun-self fun) fun)
       (setf (%simple-fun-next fun) (%code-entry-points code-object))
       (setf (%code-entry-points code-object) fun)