(new-type-info
(make-type-info :name ',type
:class class-info
- :number new-type-number)))
+ :number new-type-number
+ :type ',type-spec)))
(setf (aref *info-types* new-type-number) new-type-info)
(push new-type-info (class-info-types class-info)))))
- ;; Arrange for TYPE-INFO-DEFAULT and TYPE-INFO-TYPE to be set
- ;; at cold load time. (They can't very well be set at
- ;; cross-compile time, since they differ between the
- ;; cross-compiler and the target. The DEFAULT slot values
- ;; differ because they're compiled closures, and the TYPE slot
- ;; values differ in the use of SB!XC symbols instead of CL
- ;; symbols.)
+ ;; Arrange for TYPE-INFO-DEFAULT and
+ ;; TYPE-INFO-VALIDATE-FUNCTION to be set at cold load
+ ;; time. (They can't very well be set at cross-compile time,
+ ;; since they differ between host and target and are
+ ;; host-compiled closures.)
(push `(let ((type-info (type-info-or-lose ,',class ,',type)))
(setf (type-info-validate-function type-info)
,',validate-function)
;; NIL) instead of full-blown (LAMBDA (X) NIL).
(lambda (name)
(declare (ignorable name))
- ,',default))
- (setf (type-info-type type-info) ',',type-spec))
+ ,',default)))
*!reversed-type-info-init-forms*))
',type))
;; Constant CLASS and TYPE is an overwhelmingly common special case,
;; and we can implement it much more efficiently than the general case.
(if (and (keywordp class) (keywordp type))
- (let ((info (type-info-or-lose class type)))
+ (let (#+sb-xc-host (sb!xc:*gensym-counter* sb!xc:*gensym-counter*)
+ (info (type-info-or-lose class type)))
(with-unique-names (value foundp)
`(multiple-value-bind (,value ,foundp)
(get-info-value ,name
(values ,value ,foundp))))
whole))
-(defun (setf info) (new-value
- class
- type
- name
- &optional (env-list nil env-list-p))
+(defun (setf info)
+ (new-value class type name &optional (env-list nil env-list-p))
(let* ((info (type-info-or-lose class type))
(tin (type-info-number info)))
(when (type-info-validate-function info)
;; 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))
+ (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.
;;; where this information came from:
;;; :ASSUMED = from uses of the object
;;; :DEFINED = from examination of the definition
+;;; :DEFINED-METHOD = implicit, incremental declaration by CLOS.
;;; :DECLARED = from a declaration
-;;; :DEFINED trumps :ASSUMED, and :DECLARED trumps :DEFINED.
+;;; :DEFINED trumps :ASSUMED, :DEFINED-METHOD trumps :DEFINED,
+;;; and :DECLARED trumps :DEFINED-METHOD.
;;; :DEFINED and :ASSUMED are useful for issuing compile-time warnings,
-;;; and :DECLARED is useful for ANSIly specializing code which
-;;; implements the function, or which uses the function's return values.
+;;; :DEFINED-METHOD and :DECLARED are useful for ANSIly specializing
+;;; code which implements the function, or which uses the function's
+;;; return values.
(define-info-type
:class :function
:type :where-from
- :type-spec (member :declared :assumed :defined)
+ :type-spec (member :declared :defined-method :assumed :defined)
:default
;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's
;; not clear how to generalize the FBOUNDP expression to the
(define-info-type
:class :variable
:type :kind
- :type-spec (member :special :constant :macro :global :alien)
- :default (if (symbol-self-evaluating-p name)
+ :type-spec (member :special :constant :macro :global :alien :unknown)
+ :default (if (typep name '(or boolean keyword))
:constant
- :global))
+ :unknown))
+
+(define-info-type
+ :class :variable
+ :type :always-bound
+ :type-spec boolean
+ :default nil)
;;; the declared type for this variable
(define-info-type
:type-spec (member :declared :assumed :defined)
:default :assumed)
-;;; the Lisp object which is the value of this constant, if known
+;;; We only need a mechanism different from the
+;;; usual SYMBOL-VALUE for the cross compiler.
+#+sb-xc-host
(define-info-type
:class :variable
- :type :constant-value
+ :type :xc-constant-value
:type-spec t
- ;; CMU CL used to return two values for (INFO :VARIABLE :CONSTANT-VALUE ..).
- ;; Now we don't: it was the last remaining multiple-value return from
- ;; the INFO system, and bringing it down to one value lets us simplify
- ;; things, especially simplifying the declaration of return types.
- ;; Software which used to check the second value (for "is it defined
- ;; as a constant?") should check (EQL (INFO :VARIABLE :KIND ..) :CONSTANT)
- ;; instead.
- :default (if (symbol-self-evaluating-p name)
- name
- (bug "constant lookup of nonconstant ~S" name)))
+ :default nil)
;;; the macro-expansion for symbol-macros
(define-info-type
:type-spec (or ctype null)
:default nil)
-;;; If this is a class name, then the value is a cons (NAME . CLASS),
-;;; where CLASS may be null if the class hasn't been defined yet. Note
-;;; that for built-in classes, the kind may be :PRIMITIVE and not
-;;; :INSTANCE. The name is in the cons so that we can signal a
-;;; meaningful error if we only have the cons.
-(define-info-type
- :class :type
- :type :classoid
- :type-spec (or sb!kernel::classoid-cell null)
- :default nil)
-
;;; layout for this type being used by the compiler
(define-info-type
:class :type
:default (let ((class (find-classoid name nil)))
(when class (classoid-layout class))))
+;;; DEFTYPE lambda-list
+(define-info-type
+ :class :type
+ :type :lambda-list
+ :type-spec list
+ :default nil)
+
+(define-info-type
+ :class :type
+ :type :source-location
+ :type-spec t
+ :default nil)
+
(define-info-class :typed-structure)
(define-info-type
:class :typed-structure
(!cold-init-forms
(/show0 "beginning *INFO-CLASSES* init, calling MAKE-HASH-TABLE")
(setf *info-classes*
- (make-hash-table :test 'eq :size #.(hash-table-size *info-classes*)))
+ (make-hash-table :test 'eq :size #.(* 2 (hash-table-count *info-classes*))))
(/show0 "done with MAKE-HASH-TABLE in *INFO-CLASSES* init")
(dolist (class-info-name '#.(let ((result nil))
(maphash (lambda (key value)
(declare (ignore value))
(push key result))
*info-classes*)
- result))
+ (sort result #'string<)))
(let ((class-info (make-class-info class-info-name)))
(setf (gethash class-info-name *info-classes*)
class-info)))
(list (type-info-name info-type)
(class-info-name (type-info-class info-type))
(type-info-number info-type)
- (type-info-type info-type))))
+ ;; KLUDGE: for repeatable xc fasls, to
+ ;; avoid different cross-compiler
+ ;; treatment of equal constants here we
+ ;; COPY-TREE, which is not in general a
+ ;; valid identity transformation
+ ;; [e.g. on (EQL (FOO))] but is OK for
+ ;; all the types we use here.
+ (copy-tree (type-info-type info-type)))))
*info-types*)))
(/show0 "done with *INFO-TYPES* initialization"))