fix test for Blocked condition in canonical normalization

[sbcl.git] / src / code / fop.lisp

diff --git a/src/code/fop.lisp b/src/code/fop.lisp
index 9f6d58b..b3863eb 100644 (file)
--- a/src/code/fop.lisp
+++ b/src/code/fop.lisp
@@ -134,8 +134,8 @@
 
 (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-push 2) (ref-fop-table (read-word-arg)))
+(define-fop (fop-byte-push 3) (ref-fop-table (read-byte-arg)))
 
 (define-fop (fop-empty-list 4) ())
 (define-fop (fop-truth 5) t)
@@ -145,7 +145,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-widetag))
+  (%primitive sb!c:make-unbound-marker))
 
 (define-cloned-fops (fop-character 68) (fop-short-character 69)
   (code-char (clone-arg)))
@@ -184,37 +184,37 @@
 
 (define-fop (fop-verify-table-size 62 :stackp nil)
   (let ((expected-index (read-word-arg)))
-    (unless (= *current-fop-table-index* expected-index)
+    (unless (= (get-fop-table-index) expected-index)
       (bug "fasl table of improper size"))))
 (define-fop (fop-verify-empty-stack 63 :stackp nil)
-  (unless (zerop (length *fop-stack*))
+  (unless (fop-stack-empty-p)
     (bug "fasl stack not empty when it should be")))
 \f
 ;;;; fops for loading symbols
 
-(defun fop-intern (smallp package)
-  (let ((size (if smallp
-                  (read-byte-arg)
-                  (read-word-arg))))
-    (when (> size (length *fasl-symbol-buffer*))
-      (setq *fasl-symbol-buffer* (make-string (* size 2))))
-    (let ((buffer *fasl-symbol-buffer*))
-      #+sb-xc-host
-      (read-string-as-bytes *fasl-input-stream* buffer size)
-      #-sb-xc-host
-      (progn
-        #!+sb-unicode
-        (read-string-as-unsigned-byte-32 *fasl-input-stream* buffer size)
-        #!-sb-unicode
-        (read-string-as-bytes *fasl-input-stream* buffer size))
-      (push-fop-table (without-package-locks
-                        (intern* buffer
-                                 size
-                                 package))))))
+(defun aux-fop-intern (smallp package)
+  (declare (optimize speed))
+  (let* ((size (if smallp
+                   (read-byte-arg)
+                   (read-word-arg)))
+         (buffer (make-string size)))
+    #+sb-xc-host
+    (read-string-as-bytes *fasl-input-stream* buffer size)
+    #-sb-xc-host
+    (progn
+      #!+sb-unicode
+      (read-string-as-unsigned-byte-32 *fasl-input-stream* buffer size)
+      #!-sb-unicode
+      (read-string-as-bytes *fasl-input-stream* buffer size))
+    (push-fop-table (without-package-locks
+                      (intern* buffer
+                               size
+                               package
+                               :no-copy t)))))
 
 (macrolet ((def (name code smallp package-form)
              `(define-fop (,name ,code)
-                (fop-intern ,smallp ,package-form))))
+                (aux-fop-intern ,smallp ,package-form))))
 
   (def fop-lisp-symbol-save          75 nil *cl-package*)
   (def fop-lisp-small-symbol-save    76 t   *cl-package*)
@@ -227,13 +227,13 @@
   ;; FOP-SYMBOL-IN-LAST-PACKAGE-SAVE/FOP-SMALL-SYMBOL-IN-LAST-PACKAGE-SAVE
   ;; cloned fop pair could undo some of this bloat.
   (def fop-symbol-in-package-save             8 nil
-    (svref *current-fop-table* (read-word-arg)))
+    (ref-fop-table (read-word-arg)))
   (def fop-small-symbol-in-package-save       9 t
-    (svref *current-fop-table* (read-word-arg)))
+    (ref-fop-table (read-word-arg)))
   (def fop-symbol-in-byte-package-save       10 nil
-    (svref *current-fop-table* (read-byte-arg)))
+    (ref-fop-table (read-byte-arg)))
   (def fop-small-symbol-in-byte-package-save 11 t
-    (svref *current-fop-table* (read-byte-arg))))
+    (ref-fop-table (read-byte-arg))))
 
 (define-cloned-fops (fop-uninterned-symbol-save 12)
                     (fop-uninterned-small-symbol-save 13)
@@ -546,20 +546,20 @@
 ;;;; fops for fixing up circularities
 
 (define-fop (fop-rplaca 200 :pushp nil)
-  (let ((obj (svref *current-fop-table* (read-word-arg)))
+  (let ((obj (ref-fop-table (read-word-arg)))
         (idx (read-word-arg))
         (val (pop-stack)))
     (setf (car (nthcdr idx obj)) val)))
 
 (define-fop (fop-rplacd 201 :pushp nil)
-  (let ((obj (svref *current-fop-table* (read-word-arg)))
+  (let ((obj (ref-fop-table (read-word-arg)))
         (idx (read-word-arg))
         (val (pop-stack)))
     (setf (cdr (nthcdr idx obj)) val)))
 
 (define-fop (fop-svset 202 :pushp nil)
   (let* ((obi (read-word-arg))
-         (obj (svref *current-fop-table* obi))
+         (obj (ref-fop-table obi))
          (idx (read-word-arg))
          (val (pop-stack)))
     (if (%instancep obj)
@@ -567,7 +567,7 @@
         (setf (svref obj idx) val))))
 
 (define-fop (fop-structset 204 :pushp nil)
-  (setf (%instance-ref (svref *current-fop-table* (read-word-arg))
+  (setf (%instance-ref (ref-fop-table (read-word-arg))
                        (read-word-arg))
         (pop-stack)))