1.0.12.27: FILL on lists was broken by 1.0.12.16, oops!

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

diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp
index b9768ca..bc68512 100644 (file)
--- a/src/compiler/globaldb.lisp
+++ b/src/compiler/globaldb.lisp
@@ -758,7 +758,7 @@
   (&whole whole class type name &optional (env-list nil env-list-p))
   ;; Constant CLASS and TYPE is an overwhelmingly common special case,
   ;; and we can implement it much more efficiently than the general case.
-  (if (and (constantp class) (constantp type))
+  (if (and (keywordp class) (keywordp type))
       (let ((info (type-info-or-lose class type)))
         (with-unique-names (value foundp)
           `(multiple-value-bind (,value ,foundp)
@@ -768,6 +768,7 @@
              (declare (type ,(type-info-type info) ,value))
              (values ,value ,foundp))))
       whole))
+
 (defun (setf info) (new-value
                     class
                     type
@@ -786,25 +787,23 @@
                         tin
                         new-value)))
   new-value)
-;;; FIXME: We'd like to do this, but Python doesn't support
-;;; compiler macros and it's hard to change it so that it does.
-;;; It might make more sense to just convert INFO :FOO :BAR into
-;;; an ordinary function, so that instead of calling INFO :FOO :BAR
-;;; you call e.g. INFO%FOO%BAR. Then dynamic linking could be handled
-;;; by the ordinary Lisp mechanisms and we wouldn't have to maintain
-;;; all this cruft..
-#|
 #!-sb-fluid
 (progn
+  ;; Not all xc hosts are happy about SETF compiler macros: CMUCL 19
+  ;; does not accept them at all, and older SBCLs give a full warning.
+  ;; So the easy thing is to hide this optimization from all xc hosts.
+  #-sb-xc-host
   (define-compiler-macro (setf info) (&whole whole
-                                      new-value
-                                      class
-                                      type
-                                      name
-                                      &optional (env-list nil env-list-p))
-    ;; Constant CLASS and TYPE is an overwhelmingly common special case, and we
-    ;; can resolve it much more efficiently than the general case.
-    (if (and (constantp class) (constantp type))
+                                             new-value
+                                             class
+                                             type
+                                             name
+                                             &optional (env-list nil
+                                                                 env-list-p))
+    ;; Constant CLASS and TYPE is an overwhelmingly common special case,
+    ;; and we can resolve it much more efficiently than the general
+    ;; case.
+    (if (and (keywordp class) (keywordp type))
         (let* ((info (type-info-or-lose class type))
                (tin (type-info-number info)))
           (if env-list-p
@@ -814,9 +813,8 @@
                                (get-write-info-env ,env-list))
               `(set-info-value ,name
                                ,tin
-                               ,new-value)))
-        whole)))
-|#
+                               ,new-value))))
+    whole))
 
 ;;; the maximum density of the hashtable in a volatile env (in
 ;;; names/bucket)
@@ -938,7 +936,7 @@
   :default
   #+sb-xc-host (specifier-type 'function)
   #-sb-xc-host (if (fboundp name)
-                   (extract-fun-type (fdefinition name))
+                   (specifier-type (sb!impl::%fun-type (fdefinition name)))
                    (specifier-type 'function)))
 
 ;;; the ASSUMED-TYPE for this function, if we have to infer the type
@@ -1052,6 +1050,12 @@
   :type :definition
   :type-spec (or fdefn null)
   :default nil)
+
+(define-info-type
+  :class :function
+  :type :structure-accessor
+  :type-spec (or defstruct-description null)
+  :default nil)
 \f
 ;;;; definitions for other miscellaneous information