X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffop.lisp;h=146bec97f22c2f428024ca58d57e064eb9782beb;hb=cb83aa22932bf4b9bc74ac6f0fcd91db1702ad33;hp=aabae173f0ba535948d299ddaeb421f072f86ab4;hpb=416152f084604094445a758ff399871132dff2bd;p=sbcl.git

diff --git a/src/code/fop.lisp b/src/code/fop.lisp
index aabae17..146bec9 100644
--- a/src/code/fop.lisp
+++ b/src/code/fop.lisp
@@ -2,29 +2,29 @@
 
 (in-package "SB!FASL")
 
+;;; Sometimes we want to skip over any FOPs with side-effects (like
+;;; function calls) while executing other FOPs. *SKIP-UNTIL* will
+;;; either contain the position where the skipping will stop, or
+;;; NIL if we're executing normally.
+(defvar *skip-until* nil)
+
 ;;; 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 
+;;;     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)))
 
-;;; FIXME: This can be byte coded.
 (defun %define-fop (name code)
   (let ((oname (svref *fop-names* code)))
     (when (and oname (not (eq oname name)))
@@ -37,56 +37,69 @@
     (when (and ocode (/= ocode code))
       (error "multiple codes for fop name ~S: ~D and ~D" name code ocode)))
   (setf (svref *fop-names* code) name
-	(get name 'fop-code) code
-	(svref *fop-functions* code) (symbol-function name))
+        (get name 'fop-code) code
+        (svref *fop-funs* code) (symbol-function name))
   (values))
 
 ;;; Define a pair of fops which are identical except that one reads
 ;;; a four-byte argument while the other reads a one-byte argument. The
-;;; argument can be accessed by using the Clone-Arg macro.
+;;; argument can be accessed by using the CLONE-ARG macro.
 ;;;
 ;;; KLUDGE: It would be nice if the definition here encapsulated which
 ;;; value ranges went with which fop variant, and chose the correct
 ;;; fop code to use. Currently, since such logic isn't encapsulated,
 ;;; we see callers doing stuff like
-;;;	(cond ((and (< num-consts #x100) (< total-length #x10000))
-;;;	       (dump-fop 'sb!impl::fop-small-code file)
-;;;	       (dump-byte num-consts file)
-;;;	       (dump-integer-as-n-bytes total-length 2 file))
-;;;	      (t
-;;;	       (dump-fop 'sb!impl::fop-code file)
-;;;	       (dump-unsigned-32 num-consts file)
-;;;	       (dump-unsigned-32 total-length file))))
+;;;     (cond ((and (< num-consts #x100) (< total-length #x10000))
+;;;            (dump-fop 'sb!impl::fop-small-code file)
+;;;            (dump-byte num-consts file)
+;;;            (dump-integer-as-n-bytes total-length 2 file))
+;;;           (t
+;;;            (dump-fop 'sb!impl::fop-code file)
+;;;            (dump-word num-consts file)
+;;;            (dump-word total-length file))))
 ;;; in several places. It would be cleaner if this could be replaced with
 ;;; something like
 ;;;     (dump-fop file fop-code num-consts total-length)
 ;;; 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))
-			      (small-name small-code) &rest forms)
-  (aver (member pushp '(nil t :nope)))
+(defmacro define-cloned-fops ((name code &key (pushp t) (stackp t))
+                              (small-name small-code) &rest forms)
+  (aver (member pushp '(nil t)))
+  (aver (member stackp '(nil t)))
   `(progn
-     (macrolet ((clone-arg () '(read-arg 4)))
-       (define-fop (,name ,code ,pushp) ,@forms))
-     (macrolet ((clone-arg () '(read-arg 1)))
-       (define-fop (,small-name ,small-code ,pushp) ,@forms))))
+     (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))))
 
 ;;; 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))
+(declaim (ftype (function (stream simple-string &optional index) (values))
+                read-string-as-bytes #!+sb-unicode read-string-as-words))
 (defun read-string-as-bytes (stream string &optional (length (length string)))
   (dotimes (i length)
     (setf (aref string i)
-	  (code-char (read-byte stream))))
+          (sb!xc:code-char (read-byte stream))))
   ;; FIXME: The classic CMU CL code to do this was
   ;;   (READ-N-BYTES FILE STRING START END).
   ;; It was changed for SBCL because we needed a portable version for
   ;; bootstrapping. Benchmark the non-portable version and see whether it's
   ;; significantly better than the portable version here. If it is, then use
-  ;; add as an alternate definition, protected with #-SB-XC-HOST.
+  ;; 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")
+  (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))
+              (setf code (logior code (ash (read-byte stream)
+                                           (* k sb!vm:n-byte-bits))))))))
   (values))
 
 ;;;; miscellaneous fops
@@ -106,17 +119,17 @@
 ;;; 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=~D=#X~X~%" arg arg))))
+      (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-push 2) (svref *current-fop-table* (read-arg 4)))
-(define-fop (fop-byte-push 3) (svref *current-fop-table* (read-arg 1)))
+(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-word-arg)))
+(define-fop (fop-byte-push 3) (svref *current-fop-table* (read-byte-arg)))
 
 (define-fop (fop-empty-list 4) ())
 (define-fop (fop-truth 5) t)
@@ -126,87 +139,86 @@
   #+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)))
-;;; CMU CL had FOP-CHARACTER as fop 68, but it's not needed in current
-;;; SBCL as we have no extended characters, only 1-byte characters.
-;;; (Ditto for CMU CL, actually: FOP-CHARACTER was speculative generality.)
-(define-fop (fop-short-character 69)
-  (code-char (read-arg 1)))
+(define-cloned-fops (fop-character 68) (fop-short-character 69)
+  (code-char (clone-arg)))
 
 (define-cloned-fops (fop-struct 48) (fop-small-struct 49)
   (let* ((size (clone-arg))
-	 (res (%make-instance size)))
+         (res (%make-instance size)))
     (declare (type index size))
-    (do ((n (1- size) (1- n)))
-	((minusp n))
-      (declare (type (integer -1 #.most-positive-fixnum) n))
-      (setf (%instance-ref res n) (pop-stack)))
+    (let* ((layout (pop-stack))
+           (nuntagged (layout-n-untagged-slots layout))
+           (ntagged (- size nuntagged)))
+      (setf (%instance-ref res 0) layout)
+      (dotimes (n (1- ntagged))
+        (declare (type index n))
+        (setf (%instance-ref res (1+ n)) (pop-stack)))
+      (dotimes (n nuntagged)
+        (declare (type index n))
+        (setf (%raw-instance-ref/word res (- nuntagged n 1)) (pop-stack))))
     res))
 
 (define-fop (fop-layout 45)
-  (let ((length (pop-stack))
-	(depthoid (pop-stack))
-	(inherits (pop-stack))
-	(name (pop-stack)))
-    (find-and-init-or-check-layout name length inherits depthoid)))
-
-(define-fop (fop-end-group 64 :nope)
+  (let ((nuntagged (pop-stack))
+        (length (pop-stack))
+        (depthoid (pop-stack))
+        (inherits (pop-stack))
+        (name (pop-stack)))
+    (find-and-init-or-check-layout name length inherits depthoid nuntagged)))
+
+(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)
-  (let ((expected-index (read-arg 4)))
+(define-fop (fop-verify-table-size 62 :stackp nil)
+  (let ((expected-index (read-word-arg)))
     (unless (= *current-fop-table-index* expected-index)
-      (error "internal error: fasl table of improper size"))))
-(define-fop (fop-verify-empty-stack 63 :nope)
-  (unless (= *fop-stack-pointer* *fop-stack-pointer-on-entry*)
-    (error "internal error: fasl stack not empty when it should be")))
+      (bug "fasl table of improper size"))))
+(define-fop (fop-verify-empty-stack 63 :stackp nil)
+  (unless (zerop (length *fop-stack*))
+    (bug "fasl stack not empty when it should be")))
 
 ;;;; fops for loading symbols
 
-(defvar *load-symbol-buffer* (make-string 100))
-(declaim (simple-string *load-symbol-buffer*))
-(defvar *load-symbol-buffer-size* 100)
-(declaim (type index *load-symbol-buffer-size*))
-;;; FIXME:
-;;;   (1) *LOAD-SYMBOL-BUFFER-SIZE* is redundant, should just be
-;;;       (LENGTH *LOAD-SYMBOL-BUFFER*).
-;;;   (2) *LOAD-SYMBOL-BUFFER* should not have a global value, but should
-;;;       be bound on entry to FASL loading, and it should be renamed to
-;;;       *FASL-SYMBOL-BUFFER*.
-
 (macrolet (;; FIXME: Should all this code really be duplicated inside
-	   ;; each fop? Perhaps it would be better for this shared
-	   ;; code to live in FLET FROB1 and FLET FROB4 (for the
-	   ;; two different sizes of counts).
-	   (frob (name code name-size package)
-	     (let ((n-package (gensym))
-		   (n-size (gensym))
-		   (n-buffer (gensym)))
-	       `(define-fop (,name ,code)
-		  (prepare-for-fast-read-byte *fasl-input-stream*
-		    (let ((,n-package ,package)
-			  (,n-size (fast-read-u-integer ,name-size)))
-		      (when (> ,n-size *load-symbol-buffer-size*)
-			(setq *load-symbol-buffer*
-			      (make-string (setq *load-symbol-buffer-size*
-						 (* ,n-size 2)))))
-		      (done-with-fast-read-byte)
-		      (let ((,n-buffer *load-symbol-buffer*))
-			(read-string-as-bytes *fasl-input-stream*
-					      ,n-buffer
-					      ,n-size)
-			(push-fop-table (intern* ,n-buffer
-						 ,n-size
-						 ,n-package)))))))))
+           ;; each fop? Perhaps it would be better for this shared
+           ;; code to live in FLET FROB1 and FLET FROB4 (for the
+           ;; two different sizes of counts).
+           (frob (name code name-size package)
+             (let ((n-package (gensym))
+                   (n-size (gensym))
+                   (n-buffer (gensym)))
+               `(define-fop (,name ,code)
+                  (prepare-for-fast-read-byte *fasl-input-stream*
+                    (let ((,n-package ,package)
+                          (,n-size (fast-read-u-integer ,name-size)))
+                      (when (> ,n-size (length *fasl-symbol-buffer*))
+                        (setq *fasl-symbol-buffer*
+                              (make-string (* ,n-size 2))))
+                      (done-with-fast-read-byte)
+                      (let ((,n-buffer *fasl-symbol-buffer*))
+                        #+sb-xc-host
+                        (read-string-as-bytes *fasl-input-stream*
+                                              ,n-buffer
+                                              ,n-size)
+                        #-sb-xc-host
+                        (#!+sb-unicode read-string-as-words
+                         #!-sb-unicode read-string-as-bytes
+                         *fasl-input-stream*
+                         ,n-buffer
+                         ,n-size)
+                        (push-fop-table (without-package-locks
+                                         (intern* ,n-buffer
+                                                  ,n-size
+                                                  ,n-package))))))))))
 
   ;; Note: CMU CL had FOP-SYMBOL-SAVE and FOP-SMALL-SYMBOL-SAVE, but
   ;; since they made the behavior of the fasloader depend on the
@@ -223,12 +235,12 @@
   ;;       (SETF *PACKAGE* (FIND-PACKAGE :CL)))
   ;; which in CMU CL 2.4.9 defines a variable CL-USER::*FOO* instead of
   ;; defining CL::*FOO*. Therefore, we don't use those fops in SBCL.
-  ;;(frob fop-symbol-save		6 4 *package*)
-  ;;(frob fop-small-symbol-save	  7 1 *package*)
+  ;;(frob fop-symbol-save               6 4 *package*)
+  ;;(frob fop-small-symbol-save   7 1 *package*)
 
-  (frob fop-lisp-symbol-save	      75 4 *cl-package*)
+  (frob fop-lisp-symbol-save          75 #.sb!vm:n-word-bytes *cl-package*)
   (frob fop-lisp-small-symbol-save    76 1 *cl-package*)
-  (frob fop-keyword-symbol-save       77 4 *keyword-package*)
+  (frob fop-keyword-symbol-save       77 #.sb!vm:n-word-bytes *keyword-package*)
   (frob fop-keyword-small-symbol-save 78 1 *keyword-package*)
 
   ;; FIXME: Because we don't have FOP-SYMBOL-SAVE any more, an enormous number
@@ -236,20 +248,23 @@
   ;; fasl files. A new
   ;; FOP-SYMBOL-IN-LAST-PACKAGE-SAVE/FOP-SMALL-SYMBOL-IN-LAST-PACKAGE-SAVE
   ;; cloned fop pair could undo some of this bloat.
-  (frob fop-symbol-in-package-save 8 4
-    (svref *current-fop-table* (fast-read-u-integer 4)))
+  (frob fop-symbol-in-package-save 8 #.sb!vm:n-word-bytes
+    (svref *current-fop-table* (fast-read-u-integer #.sb!vm:n-word-bytes)))
   (frob fop-small-symbol-in-package-save 9 1
-    (svref *current-fop-table* (fast-read-u-integer 4)))
-  (frob fop-symbol-in-byte-package-save 10 4
+    (svref *current-fop-table* (fast-read-u-integer #.sb!vm:n-word-bytes)))
+  (frob fop-symbol-in-byte-package-save 10 #.sb!vm:n-word-bytes
     (svref *current-fop-table* (fast-read-u-integer 1)))
   (frob fop-small-symbol-in-byte-package-save 11 1
     (svref *current-fop-table* (fast-read-u-integer 1))))
 
 (define-cloned-fops (fop-uninterned-symbol-save 12)
-		    (fop-uninterned-small-symbol-save 13)
+                    (fop-uninterned-small-symbol-save 13)
   (let* ((arg (clone-arg))
-	 (res (make-string arg)))
+         (res (make-string arg)))
+    #!-sb-unicode
     (read-string-as-bytes *fasl-input-stream* res)
+    #!+sb-unicode
+    (read-string-as-words *fasl-input-stream* res)
     (push-fop-table (make-symbol res))))
 
 (define-fop (fop-package 14)
@@ -262,13 +277,13 @@
   (declare (fixnum length))
   ;; #+cmu (declare (optimize (inhibit-warnings 2)))
   (do* ((index length (1- index))
-	(byte 0 (read-byte *fasl-input-stream*))
-	(result 0 (+ result (ash byte bits)))
-	(bits 0 (+ bits 8)))
+        (byte 0 (read-byte *fasl-input-stream*))
+        (result 0 (+ result (ash byte bits)))
+        (bits 0 (+ bits 8)))
        ((= index 0)
-	(if (logbitp 7 byte)	; look at sign bit
-	    (- result (ash 1 bits))
-	    result))
+        (if (logbitp 7 byte)    ; look at sign bit
+            (- result (ash 1 bits))
+            result))
     (declare (fixnum index byte bits))))
 
 (define-cloned-fops (fop-integer 33) (fop-small-integer 34)
@@ -277,7 +292,7 @@
 (define-fop (fop-word-integer 35)
   (prepare-for-fast-read-byte *fasl-input-stream*
     (prog1
-     (fast-read-s-integer 4)
+     (fast-read-s-integer #.sb!vm:n-word-bytes)
      (done-with-fast-read-byte))))
 
 (define-fop (fop-byte-integer 36)
@@ -294,82 +309,52 @@
   (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))))
-
-(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))))
+(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))))
+  (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)))
 
-#!+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
 
 (define-fop (fop-list 15)
   (do ((res () (cons (pop-stack) res))
-       (n (read-arg 1) (1- n)))
+       (n (read-byte-arg) (1- n)))
       ((zerop n) res)
     (declare (type index n))))
 
 (define-fop (fop-list* 16)
   (do ((res (pop-stack) (cons (pop-stack) res))
-       (n (read-arg 1) (1- n)))
+       (n (read-byte-arg) (1- n)))
       ((zerop n) res)
     (declare (type index n))))
 
 (macrolet ((frob (name op fun n)
-	     `(define-fop (,name ,op)
-		(call-with-popped-things ,fun ,n))))
+             `(define-fop (,name ,op)
+                (call-with-popped-args ,fun ,n))))
 
   (frob fop-list-1 17 list 1)
   (frob fop-list-2 18 list 2)
@@ -391,196 +376,223 @@
 
 ;;;; fops for loading arrays
 
-(define-cloned-fops (fop-string 37) (fop-small-string 38)
+(define-cloned-fops (fop-base-string 37) (fop-small-base-string 38)
   (let* ((arg (clone-arg))
-	 (res (make-string arg)))
+         (res (make-string arg :element-type 'base-char)))
     (read-string-as-bytes *fasl-input-stream* res)
     res))
 
+#!+sb-unicode
+(progn
+  #+sb-xc-host
+  (define-cloned-fops (fop-character-string 161) (fop-small-character-string 162)
+    (bug "CHARACTER-STRING FOP encountered"))
+
+  #-sb-xc-host
+  (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)
+      res)))
+
 (define-cloned-fops (fop-vector 39) (fop-small-vector 40)
   (let* ((size (clone-arg))
-	 (res (make-array size)))
+         (res (make-array size)))
     (declare (fixnum size))
     (do ((n (1- size) (1- n)))
-	((minusp n))
+        ((minusp n))
       (setf (svref res n) (pop-stack)))
     res))
 
 (define-fop (fop-array 83)
-  (let* ((rank (read-arg 4))
-	 (vec (pop-stack))
-	 (length (length vec))
-	 (res (make-array-header sb!vm:simple-array-type rank)))
+  (let* ((rank (read-word-arg))
+         (vec (pop-stack))
+         (length (length vec))
+         (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
-		      (do ((i rank (1- i))
-			   (dimensions () (cons (pop-stack) dimensions)))
-			  ((zerop i) dimensions)
-			(declare (type index i)))
-		      nil)
+             (type (unsigned-byte #.(- sb!vm:n-word-bits sb!vm:n-widetag-bits)) rank))
+    (set-array-header res vec length nil 0
+                      (do ((i rank (1- i))
+                           (dimensions () (cons (pop-stack) dimensions)))
+                          ((zerop i) dimensions)
+                        (declare (type index i)))
+                      nil)
     res))
 
 (define-fop (fop-single-float-vector 84)
-  (let* ((length (read-arg 4))
-	 (result (make-array length :element-type 'single-float)))
-    (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:word-bytes))
+  (let* ((length (read-word-arg))
+         (result (make-array length :element-type 'single-float)))
+    (read-n-bytes *fasl-input-stream* result 0 (* length 4))
     result))
 
 (define-fop (fop-double-float-vector 85)
-  (let* ((length (read-arg 4))
-	 (result (make-array length :element-type 'double-float)))
-    (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:word-bytes 2))
-    result))
-
-#!+long-float
-(define-fop (fop-long-float-vector 88)
-  (let* ((length (read-arg 4))
-	 (result (make-array length :element-type 'long-float)))
-    (read-n-bytes *fasl-input-stream*
-		  result
-		  0
-		  (* length sb!vm:word-bytes #!+x86 3 #!+sparc 4))
+  (let* ((length (read-word-arg))
+         (result (make-array length :element-type 'double-float)))
+    (read-n-bytes *fasl-input-stream* result 0 (* length 8))
     result))
 
 (define-fop (fop-complex-single-float-vector 86)
-  (let* ((length (read-arg 4))
-	 (result (make-array length :element-type '(complex single-float))))
-    (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:word-bytes 2))
+  (let* ((length (read-word-arg))
+         (result (make-array length :element-type '(complex single-float))))
+    (read-n-bytes *fasl-input-stream* result 0 (* length 8))
     result))
 
 (define-fop (fop-complex-double-float-vector 87)
-  (let* ((length (read-arg 4))
-	 (result (make-array length :element-type '(complex double-float))))
-    (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:word-bytes 2 2))
+  (let* ((length (read-word-arg))
+         (result (make-array length :element-type '(complex double-float))))
+    (read-n-bytes *fasl-input-stream* result 0 (* length 16))
     result))
 
-#!+long-float
-(define-fop (fop-complex-long-float-vector 89)
-  (let* ((length (read-arg 4))
-	 (result (make-array length :element-type '(complex long-float))))
-    (read-n-bytes *fasl-input-stream* result 0
-		  (* length sb!vm:word-bytes #!+x86 3 #!+sparc 4 2))
-    result))
-
-;;; *** NOT *** the FOP-INT-VECTOR as currently documented in rtguts. Size
-;;; must be a directly supported I-vector element size, with no extra bits.
-;;; This must be packed according to the local byte-ordering, allowing us to
-;;; directly read the bits.
+;;; CMU CL comment:
+;;;   *** NOT *** the FOP-INT-VECTOR as currently documented in rtguts.
+;;;   Size must be a directly supported I-vector element size, with no
+;;;   extra bits. This must be packed according to the local
+;;;   byte-ordering, allowing us to directly read the bits.
 (define-fop (fop-int-vector 43)
   (prepare-for-fast-read-byte *fasl-input-stream*
-    (let* ((len (fast-read-u-integer 4))
-	   (size (fast-read-byte))
-	   (res (case size
-		  (1 (make-array len :element-type 'bit))
-		  (2 (make-array len :element-type '(unsigned-byte 2)))
-		  (4 (make-array len :element-type '(unsigned-byte 4)))
-		  (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)))))
+    (let* ((len (fast-read-u-integer #.sb!vm:n-word-bytes))
+           (size (fast-read-byte))
+           (res (case size
+                  (0 (make-array len :element-type 'nil))
+                  (1 (make-array len :element-type 'bit))
+                  (2 (make-array len :element-type '(unsigned-byte 2)))
+                  (4 (make-array len :element-type '(unsigned-byte 4)))
+                  (7 (prog1 (make-array len :element-type '(unsigned-byte 7))
+                       (setf size 8)))
+                  (8 (make-array len :element-type '(unsigned-byte 8)))
+                  (15 (prog1 (make-array len :element-type '(unsigned-byte 15))
+                        (setf size 16)))
+                  (16 (make-array len :element-type '(unsigned-byte 16)))
+                  (31 (prog1 (make-array len :element-type '(unsigned-byte 31))
+                        (setf size 32)))
+                  (32 (make-array len :element-type '(unsigned-byte 32)))
+                  #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+                  (63 (prog1 (make-array len :element-type '(unsigned-byte 63))
+                        (setf size 64)))
+                  (64 (make-array len :element-type '(unsigned-byte 64)))
+                  (t (bug "losing i-vector element size: ~S" size)))))
       (declare (type index len))
       (done-with-fast-read-byte)
       (read-n-bytes *fasl-input-stream*
-		    res
-		    0
-		    (ceiling (the index (* size len))
-			     sb!vm:byte-bits))
+                    res
+                    0
+                    (ceiling (the index (* size len)) sb!vm:n-byte-bits))
       res)))
 
 ;;; This is the same as FOP-INT-VECTOR, except this is for signed
 ;;; SIMPLE-ARRAYs.
 (define-fop (fop-signed-int-vector 50)
   (prepare-for-fast-read-byte *fasl-input-stream*
-    (let* ((len (fast-read-u-integer 4))
-	   (size (fast-read-byte))
-	   (res (case size
- 		  (8 (make-array len :element-type '(signed-byte 8)))
- 		  (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)))))
+    (let* ((len (fast-read-u-integer #.sb!vm:n-word-bytes))
+           (size (fast-read-byte))
+           (res (case size
+                  (8 (make-array len :element-type '(signed-byte 8)))
+                  (16 (make-array len :element-type '(signed-byte 16)))
+                  #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
+                  (29 (prog1 (make-array len :element-type '(unsigned-byte 29))
+                        (setf size 32)))
+                  #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
+                  (30 (prog1 (make-array len :element-type '(signed-byte 30))
+                        (setf size 32)))
+                  (32 (make-array len :element-type '(signed-byte 32)))
+                  #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+                  (60 (prog1 (make-array len :element-type '(unsigned-byte 60))
+                        (setf size 64)))
+                  #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+                  (61 (prog1 (make-array len :element-type '(signed-byte 61))
+                        (setf size 64)))
+                  #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+                  (64 (make-array len :element-type '(signed-byte 64)))
+                  (t (bug "losing si-vector element size: ~S" size)))))
       (declare (type index len))
       (done-with-fast-read-byte)
       (read-n-bytes *fasl-input-stream*
-		    res
-		    0
- 		    (ceiling (the index (* (if (= size 30)
-					       32 ; Adjust for (signed-byte 30)
-					       size) len)) sb!vm:byte-bits))
+                    res
+                    0
+                    (ceiling (the index (* size len)) sb!vm:n-byte-bits))
       res)))
 
 (define-fop (fop-eval 53)
-  (let ((result (eval (pop-stack))))
-    ;; FIXME: CMU CL had this code here:
-    ;;   (when *load-print*
-    ;;     (load-fresh-line)
-    ;;     (prin1 result)
-    ;;     (terpri))
-    ;; Unfortunately, this dependence on the *LOAD-PRINT* global
-    ;; variable is non-ANSI, so for now we've just punted printing in
-    ;; fasl loading.
-    result))
-
-(define-fop (fop-eval-for-effect 54 nil)
-  (let ((result (eval (pop-stack))))
-    ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL.
-    (declare (ignore result))
-    #+nil (when *load-print*
-	    (load-fresh-line)
-	    (prin1 result)
-	    (terpri))))
+  (if *skip-until*
+      (pop-stack)
+      (let ((result (eval (pop-stack))))
+        ;; FIXME: CMU CL had this code here:
+        ;;   (when *load-print*
+        ;;     (load-fresh-line)
+        ;;     (prin1 result)
+        ;;     (terpri))
+        ;; Unfortunately, this dependence on the *LOAD-PRINT* global
+        ;; variable is non-ANSI, so for now we've just punted printing in
+        ;; fasl loading.
+        result)))
+
+(define-fop (fop-eval-for-effect 54 :pushp nil)
+  (if *skip-until*
+      (pop-stack)
+      (let ((result (eval (pop-stack))))
+        ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL.
+        (declare (ignore result))
+        #+nil (when *load-print*
+                (load-fresh-line)
+                (prin1 result)
+                (terpri)))))
 
 (define-fop (fop-funcall 55)
-  (let ((arg (read-arg 1)))
-    (if (zerop arg)
-	(funcall (pop-stack))
-	(do ((args () (cons (pop-stack) args))
-	     (n arg (1- n)))
-	    ((zerop n) (apply (pop-stack) args))
-	  (declare (type index n))))))
-
-(define-fop (fop-funcall-for-effect 56 nil)
-  (let ((arg (read-arg 1)))
-    (if (zerop arg)
-	(funcall (pop-stack))
-	(do ((args () (cons (pop-stack) args))
-	     (n arg (1- n)))
-	    ((zerop n) (apply (pop-stack) args))
-	  (declare (type index n))))))
+  (let ((arg (read-byte-arg)))
+    (if *skip-until*
+        (dotimes (i (1+ arg))
+          (pop-stack))
+        (if (zerop arg)
+            (funcall (pop-stack))
+            (do ((args () (cons (pop-stack) args))
+                 (n arg (1- n)))
+                ((zerop n) (apply (pop-stack) args))
+              (declare (type index n)))))))
+
+(define-fop (fop-funcall-for-effect 56 :pushp nil)
+  (let ((arg (read-byte-arg)))
+    (if *skip-until*
+        (dotimes (i (1+ arg))
+          (pop-stack))
+        (if (zerop arg)
+            (funcall (pop-stack))
+            (do ((args () (cons (pop-stack) args))
+                 (n arg (1- n)))
+                ((zerop n) (apply (pop-stack) args))
+              (declare (type index n)))))))
 
 ;;;; fops for fixing up circularities
 
-(define-fop (fop-rplaca 200 nil)
-  (let ((obj (svref *current-fop-table* (read-arg 4)))
-	(idx (read-arg 4))
-	(val (pop-stack)))
+(define-fop (fop-rplaca 200 :pushp nil)
+  (let ((obj (svref *current-fop-table* (read-word-arg)))
+        (idx (read-word-arg))
+        (val (pop-stack)))
     (setf (car (nthcdr idx obj)) val)))
 
-(define-fop (fop-rplacd 201 nil)
-  (let ((obj (svref *current-fop-table* (read-arg 4)))
-	(idx (read-arg 4))
-	(val (pop-stack)))
+(define-fop (fop-rplacd 201 :pushp nil)
+  (let ((obj (svref *current-fop-table* (read-word-arg)))
+        (idx (read-word-arg))
+        (val (pop-stack)))
     (setf (cdr (nthcdr idx obj)) val)))
 
-(define-fop (fop-svset 202 nil)
-  (let* ((obi (read-arg 4))
-	 (obj (svref *current-fop-table* obi))
-	 (idx (read-arg 4))
-	 (val (pop-stack)))
-    (if (typep obj 'instance)
-	(setf (%instance-ref obj idx) val)
-	(setf (svref obj idx) val))))
-
-(define-fop (fop-structset 204 nil)
-  (setf (%instance-ref (svref *current-fop-table* (read-arg 4))
-		       (read-arg 4))
-	(pop-stack)))
-
-(define-fop (fop-nthcdr 203 t)
-  (nthcdr (read-arg 4) (pop-stack)))
+(define-fop (fop-svset 202 :pushp nil)
+  (let* ((obi (read-word-arg))
+         (obj (svref *current-fop-table* obi))
+         (idx (read-word-arg))
+         (val (pop-stack)))
+    (if (%instancep obj)
+        (setf (%instance-ref obj idx) val)
+        (setf (svref obj idx) val))))
+
+(define-fop (fop-structset 204 :pushp nil)
+  (setf (%instance-ref (svref *current-fop-table* (read-word-arg))
+                       (read-word-arg))
+        (pop-stack)))
+
+;;; 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-word-arg) (pop-stack)))
 
 ;;;; fops for loading functions
 
@@ -591,11 +603,11 @@
 ;;; putting the implementation and version in required fields in the
 ;;; fasl file header.)
 
-(define-fop (fop-code 58 :nope)
-  (load-code (read-arg 4) (read-arg 4)))
+(define-fop (fop-code 58 :stackp nil)
+  (load-code (read-word-arg) (read-word-arg)))
 
-(define-fop (fop-small-code 59 :nope)
-  (load-code (read-arg 1) (read-arg 2)))
+(define-fop (fop-small-code 59 :stackp nil)
+  (load-code (read-byte-arg) (read-halfword-arg)))
 
 (define-fop (fop-fdefinition 60)
   (fdefinition-object (pop-stack) t))
@@ -605,7 +617,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
@@ -623,60 +635,42 @@ bug.~:@>")
   ;; depend more strongly than in CMU CL on FOP-FSET actually doing
   ;; something.)
   (let ((fn (pop-stack))
-	(name (pop-stack)))
+        (name (pop-stack)))
     (setf (fdefinition name) fn)))
 
-;;; Modify a slot in a Constants object.
-(define-cloned-fops (fop-alter-code 140 nil) (fop-byte-alter-code 141)
+;;; 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))
-	(code (pop-stack)))
+        (code (pop-stack)))
     (setf (code-header-ref code (clone-arg)) value)
     (values)))
 
-(define-fop (fop-function-entry 142)
+(define-fop (fop-fun-entry 142)
   #+sb-xc-host ; since xc host doesn't know how to compile %PRIMITIVE
-  (error "FOP-FUNCTION-ENTRY can't be defined without %PRIMITIVE.")
+  (error "FOP-FUN-ENTRY can't be defined without %PRIMITIVE.")
   #-sb-xc-host
-  (let ((type (pop-stack))
-	(arglist (pop-stack))
-	(name (pop-stack))
-	(code-object (pop-stack))
-	(offset (read-arg 4)))
+  (let ((xrefs (pop-stack))
+        (type (pop-stack))
+        (arglist (pop-stack))
+        (name (pop-stack))
+        (code-object (pop-stack))
+        (offset (read-word-arg)))
     (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)))
-      (setf (%function-self fun) fun)
-      (setf (%function-next fun) (%code-entry-points code-object))
+      (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)
-      (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)
+      (setf (%simple-fun-xrefs fun) xrefs)
       ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL.
       #+nil (when *load-print*
-	      (load-fresh-line)
-	      (format t "~S defined~%" fun))
+              (load-fresh-line)
+              (format t "~S defined~%" fun))
       fun)))
-
-;;; FIXME: byte compiler to be completely deleted
-#|
-(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
@@ -692,40 +686,96 @@ bug.~:@>")
 
 ;;;; assemblerish fops
 
-(define-fop (fop-foreign-fixup 147)
-  (let* ((kind (pop-stack))
-	 (code-object (pop-stack))
-	 (len (read-arg 1))
-	 (sym (make-string len)))
-    (read-n-bytes *fasl-input-stream* sym 0 len)
-    (sb!vm:fixup-code-object code-object
-			     (read-arg 4)
-			     (foreign-symbol-address-as-integer sym)
-			     kind)
-    code-object))
-
 (define-fop (fop-assembler-code 144)
   (error "cannot load assembler code except at cold load"))
 
 (define-fop (fop-assembler-routine 145)
   (error "cannot load assembler code except at cold load"))
 
+(define-fop (fop-foreign-fixup 147)
+  (let* ((kind (pop-stack))
+         (code-object (pop-stack))
+         (len (read-byte-arg))
+         (sym (make-string len :element-type 'base-char)))
+    (read-n-bytes *fasl-input-stream* sym 0 len)
+    (sb!vm:fixup-code-object code-object
+                             (read-word-arg)
+                             (foreign-symbol-address sym)
+                             kind)
+    code-object))
+
 (define-fop (fop-assembler-fixup 148)
   (let ((routine (pop-stack))
-	(kind (pop-stack))
-	(code-object (pop-stack)))
+        (kind (pop-stack))
+        (code-object (pop-stack)))
     (multiple-value-bind (value found) (gethash routine *assembler-routines*)
       (unless found
-	(error "undefined assembler routine: ~S" routine))
-      (sb!vm:fixup-code-object code-object (read-arg 4) value kind))
+        (error "undefined assembler routine: ~S" routine))
+      (sb!vm:fixup-code-object code-object (read-word-arg) value kind))
     code-object))
 
 (define-fop (fop-code-object-fixup 149)
   (let ((kind (pop-stack))
-	(code-object (pop-stack)))
+        (code-object (pop-stack)))
     ;; Note: We don't have to worry about GC moving the code-object after
     ;; the GET-LISP-OBJ-ADDRESS and before that value is deposited, because
     ;; we can only use code-object fixups when code-objects don't move.
-    (sb!vm:fixup-code-object code-object (read-arg 4)
-			     (get-lisp-obj-address code-object) kind)
+    (sb!vm:fixup-code-object code-object (read-word-arg)
+                             (get-lisp-obj-address code-object) kind)
     code-object))
+
+#!+linkage-table
+(define-fop (fop-foreign-dataref-fixup 150)
+  (let* ((kind (pop-stack))
+         (code-object (pop-stack))
+         (len (read-byte-arg))
+         (sym (make-string len :element-type 'base-char)))
+    (read-n-bytes *fasl-input-stream* sym 0 len)
+    (sb!vm:fixup-code-object code-object
+                             (read-word-arg)
+                             (foreign-symbol-address sym t)
+                             kind)
+    code-object))
+
+;;; FOPs needed for implementing an IF operator in a FASL
+
+;;; Skip until a FOP-MAYBE-STOP-SKIPPING with the same POSITION is
+;;; executed. While skipping, we execute most FOPs normally, except
+;;; for ones that a) funcall/eval b) start skipping. This needs to
+;;; be done to ensure that the fop table gets populated correctly
+;;; regardless of the execution path.
+(define-fop (fop-skip 151 :pushp nil)
+  (let ((position (pop-stack)))
+    (unless *skip-until*
+      (setf *skip-until* position)))
+  (values))
+
+;;; As before, but only start skipping if the top of the FOP stack is NIL.
+(define-fop (fop-skip-if-false 152 :pushp nil)
+  (let ((condition (pop-stack))
+        (position (pop-stack)))
+    (unless (or condition
+                *skip-until*)
+      (setf *skip-until* position)))
+  (values))
+
+;;; If skipping, pop the top of the stack and discard it. Needed for
+;;; ensuring that the stack stays balanced when skipping.
+(define-fop (fop-drop-if-skipping 153 :pushp nil)
+  (when *skip-until*
+    (pop-stack))
+  (values))
+
+;;; If skipping, push a dummy value on the stack. Needed for
+;;; ensuring that the stack stays balanced when skipping.
+(define-fop (fop-push-nil-if-skipping 154 :pushp nil)
+  (when *skip-until*
+    (push-stack nil))
+  (values))
+
+;;; Stop skipping if the top of the stack matches *SKIP-UNTIL*
+(define-fop (fop-maybe-stop-skipping 155 :pushp nil)
+  (let ((label (pop-stack)))
+    (when (eql *skip-until* label)
+      (setf *skip-until* nil)))
+  (values))