#-no-ansi-print-object
(:print-object (lambda (x s)
(print-unreadable-object (x s :type t)
- (prin1 (class-info-name x)))))
+ (prin1 (class-info-name x) s))))
(:copier nil))
;; name of this class
(name nil :type keyword :read-only t)
(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))
\f
;;;; generic interfaces
-;;; FIXME: used only in this file, needn't be in runtime
(defmacro do-info ((env &key (name (gensym)) (class (gensym)) (type (gensym))
(type-number (gensym)) (value (gensym)) known-volatile)
&body body)
;; 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.
(define-info-type
:class :function
- :type :documentation
- :type-spec (or string null)
- :default nil)
-
-(define-info-type
- :class :function
:type :definition
:type-spec (or fdefn null)
:default nil)
(define-info-type
:class :variable
:type :kind
- :type-spec (member :special :constant :macro :global :alien)
+ :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
(when (info :type :kind name)
(error 'declaration-type-conflict-error
:format-arguments (list name)))))
+(define-info-type
+ :class :declaration
+ :type :handler
+ :type-spec (or function null))
(define-info-class :alien-type)
(define-info-type
(!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"))
projects / sbcl.git / blobdiff