0.8.3.54:

[sbcl.git] / src / compiler / srctran.lisp

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index f675b2e..e2cb897 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2346,53 +2346,32 @@
              (specifier-type 'unsigned-byte)))
        *universal-type*)))
 
-(defoptimizer (%dpb derive-type) ((newbyte size posn int))
+(defun %deposit-field-derive-type-aux (size posn int)
   (let ((size (continuation-type size))
        (posn (continuation-type posn))
        (int (continuation-type int)))
-    (if (and (numeric-type-p size)
-            (csubtypep size (specifier-type 'integer))
-            (numeric-type-p posn)
-            (csubtypep posn (specifier-type 'integer))
-            (numeric-type-p int)
-            (csubtypep int (specifier-type 'integer)))
-       (let ((size-high (numeric-type-high size))
-             (posn-high (numeric-type-high posn))
-             (high (numeric-type-high int))
-             (low (numeric-type-low int)))
-         (if (and size-high posn-high high low
-                  (<= (+ size-high posn-high) sb!vm:n-word-bits))
-             (specifier-type
-              (list (if (minusp low) 'signed-byte 'unsigned-byte)
-                    (max (integer-length high)
-                         (integer-length low)
-                         (+ size-high posn-high))))
-             *universal-type*))
-       *universal-type*)))
+    (when (and (numeric-type-p size)
+               (numeric-type-p posn)
+               (numeric-type-p int))
+      (let ((size-high (numeric-type-high size))
+            (posn-high (numeric-type-high posn))
+            (high (numeric-type-high int))
+            (low (numeric-type-low int)))
+        (when (and size-high posn-high high low
+                   (<= (+ size-high posn-high) sb!vm:n-word-bits))
+          (let ((raw-bit-count (max (integer-length high)
+                                    (integer-length low)
+                                    (+ size-high posn-high))))
+            (specifier-type
+             (if (minusp low)
+                 `(signed-byte ,(1+ raw-bit-count))
+                 `(unsigned-byte ,raw-bit-count)))))))))
+
+(defoptimizer (%dpb derive-type) ((newbyte size posn int))
+  (%deposit-field-derive-type-aux size posn int))
 
 (defoptimizer (%deposit-field derive-type) ((newbyte size posn int))
-  (let ((size (continuation-type size))
-       (posn (continuation-type posn))
-       (int (continuation-type int)))
-    (if (and (numeric-type-p size)
-            (csubtypep size (specifier-type 'integer))
-            (numeric-type-p posn)
-            (csubtypep posn (specifier-type 'integer))
-            (numeric-type-p int)
-            (csubtypep int (specifier-type 'integer)))
-       (let ((size-high (numeric-type-high size))
-             (posn-high (numeric-type-high posn))
-             (high (numeric-type-high int))
-             (low (numeric-type-low int)))
-         (if (and size-high posn-high high low
-                  (<= (+ size-high posn-high) sb!vm:n-word-bits))
-             (specifier-type
-              (list (if (minusp low) 'signed-byte 'unsigned-byte)
-                    (max (integer-length high)
-                         (integer-length low)
-                         (+ size-high posn-high))))
-             *universal-type*))
-       *universal-type*)))
+  (%deposit-field-derive-type-aux size posn int))
 
 (deftransform %ldb ((size posn int)
                    (fixnum fixnum integer)