Utility predicates for packing: UNBOUNDED-SC-P and UNBOUNDED-TN-P

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

diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp
index 2aca4c3..e652fc4 100644 (file)
--- a/src/code/typedefs.lisp
+++ b/src/code/typedefs.lisp
@@ -42,23 +42,27 @@
   (multiple-value-bind (whole wholeless-arglist)
       (if (eq '&whole (car arglist))
           (values (cadr arglist) (cddr arglist))
-          (values (gensym) arglist))
+          (values (sb!xc:gensym) arglist))
     (multiple-value-bind (forms decls)
         (parse-body body :doc-string-allowed nil)
       `(progn
          (!cold-init-forms
-          (setf (info :type :translator ',name)
-                (lambda (,whole)
-                  (block ,name
-                    (destructuring-bind ,wholeless-arglist
-                        (rest ,whole) ; discarding NAME
-                      ,@decls
-                      ,@forms)))))
+          (let ((fun (lambda (,whole)
+                       (block ,name
+                         (destructuring-bind ,wholeless-arglist
+                             (rest ,whole)  ; discarding NAME
+                           ,@decls
+                       ,@forms)))))
+            #-sb-xc-host
+            (setf (%simple-fun-arglist (the simple-fun fun)) ',wholeless-arglist)
+            (setf (info :type :translator ',name) fun)))
          ',name))))
 
 ;;; DEFVARs for these come later, after we have enough stuff defined.
 (declaim (special *wild-type* *universal-type* *empty-type*))
 \f
+(defvar *type-random-state*)
+
 ;;; the base class for the internal representation of types
 (def!struct (ctype (:conc-name type-)
                    (:constructor nil)
@@ -77,7 +81,11 @@
   (enumerable nil :read-only t)
   ;; an arbitrary hash code used in EQ-style hashing of identity
   ;; (since EQ hashing can't be done portably)
-  (hash-value (random #.(ash 1 15))
+  (hash-value (random #.(ash 1 15)
+                      (if (boundp '*type-random-state*)
+                          *type-random-state*
+                          (setf *type-random-state*
+                                (make-random-state))))
               :type (and fixnum unsigned-byte)
               :read-only t)
   ;; Can this object contain other types? A global property of our
@@ -132,12 +140,12 @@
 #!-sb-fluid (declaim (inline type-list-cache-hash))
 (declaim (ftype (function (list) (unsigned-byte 8)) type-list-cache-hash))
 (defun type-list-cache-hash (types)
-  (logand (loop with res = 0
-             for type in types
-             for hash = (type-hash-value type)
-             do (setq res (logxor res hash))
-             finally (return res))
-          #xFF))
+  (logand #xFF
+          (loop with res fixnum = 0
+                for type in types
+                for hash = (type-hash-value type)
+                do (setq res (logxor res hash))
+                finally (return res))))
 \f
 ;;;; cold loading initializations