- ;; FIXME: Since currently *TYPE-SYSTEM-INITIALIZED* is not set
- ;; until many toplevel forms have run, this condition on
- ;; PROCLAIM (FTYPE ..) (and on PROCLAIM (TYPE ..), above) means
- ;; that valid PROCLAIMs in cold code could get lost. Probably
- ;; the cleanest way to deal with this would be to initialize
- ;; the type system completely in special cold init forms,
- ;; before any ordinary toplevel forms run. Failing that, we
- ;; could queue up PROCLAIMs to be done after the type system is
- ;; initialized. Failing that, we could at least issue a warning
- ;; when we have to ignore a PROCLAIM because the type system is
- ;; uninitialized.
- (when *type-system-initialized*
- (let ((type (specifier-type (first args))))
- (unless (csubtypep type (specifier-type 'function))
- (error "not a function type: ~S" (first args)))
- (dolist (name (rest args))
-
- ;; KLUDGE: Something like the commented-out TYPE/=
- ;; check here would be nice, but it has been
- ;; commented out because TYPE/= doesn't support
- ;; function types. It could probably be made to do
- ;; so, but it might take some time, since function
- ;; types involve values types, which aren't
- ;; supported, and since the SUBTYPEP operator for
- ;; FUNCTION types is rather broken, e.g.
- ;; (SUBTYPEP '(FUNCTION (T BOOLEAN) NIL)
- ;; '(FUNCTION (FIXNUM FIXNUM) NIL)) => T, T
- ;; -- WHN 20000229
- #|
- (when (eq (info :function :where-from name) :declared)
- (let ((old-type (info :function :type name)))
- (when (type/= type old-type)
- (style-warn
- "new FTYPE proclamation~@
- ~S~@
- for ~S does not match old FTYPE proclamation~@
- ~S"
- (list type name old-type)))))
- |#
+ (if *type-system-initialized*
+ (let ((ctype (specifier-type (first args))))
+ (unless (csubtypep ctype (specifier-type 'function))
+ (error "not a function type: ~S" (first args)))
+ (dolist (name (rest args))
+ (when (eq (info :function :where-from name) :declared)
+ (let ((old-type (info :function :type name)))
+ (when (type/= ctype old-type)
+ (style-warn
+ "new FTYPE proclamation~@
+ ~S~@
+ for ~S does not match old FTYPE proclamation~@
+ ~S"
+ ctype name old-type))))