From e87b067a323c3ab15ad543115eed416b960db6ae Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Mon, 11 Apr 2011 11:32:50 +0000
Subject: [PATCH] 1.0.47.24: more conservative FTYPE proclamations

  Full warnings for changing FTYPE proclamations in the
  cross-compiler, and always a CERROR when the function is a known one
  and the new type is not a subtype of the old one.

  This necessitates the following changes:

  * Rewriting DEF-MATH-RTN not to use DEFINE-ALIEN-ROUTINE which
    proclaims its FTYPE.

  * Fix the DEFKNOWN for CLASSOID-NAME to match the DEFSTRUCT.

  * Fix STRING-OUTPUT-STREAM-ELEMENT-TYPE slot type, and DEFKNOWN
    result type.
---
 src/code/irrat.lisp        |   17 ++++++++++-------
 src/code/stream.lisp       |    2 +-
 src/compiler/fndb.lisp     |    4 ++--
 src/compiler/proclaim.lisp |   17 ++++++++++++-----
 version.lisp-expr          |    2 +-
 5 files changed, 26 insertions(+), 16 deletions(-)

diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp
index 71619ee..1b28a3a 100644
--- a/src/code/irrat.lisp
+++ b/src/code/irrat.lisp
@@ -23,15 +23,18 @@
 (eval-when (:compile-toplevel :execute)
 
 (sb!xc:defmacro def-math-rtn (name num-args)
-  (let ((function (symbolicate "%" (string-upcase name))))
+  (let ((function (symbolicate "%" (string-upcase name)))
+        (args (let ((sb!impl::*gentemp-counter* 0))
+                (loop repeat num-args collect (gentemp "ARG")))))
     `(progn
        (declaim (inline ,function))
-       (sb!alien:define-alien-routine (,name ,function) double-float
-         ,@(let ((results nil))
-             (dotimes (i num-args (nreverse results))
-               (push (list (intern (format nil "ARG-~D" i))
-                           'double-float)
-                     results)))))))
+       (defun ,function ,args
+         (alien-funcall
+          (extern-alien ,name
+                        (function double-float
+                                  ,@(loop repeat num-args
+                                          collect 'double-float)))
+          ,@args)))))
 
 (defun handle-reals (function var)
   `((((foreach fixnum single-float bignum ratio))
diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index 3065d16..71adb3a 100644
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -1301,7 +1301,7 @@
   ;; end of the stream.
   (index-cache 0 :type index)
   ;; Requested element type
-  (element-type 'character))
+  (element-type 'character :type type-specifier))
 
 #!+sb-doc
 (setf (fdocumentation 'make-string-output-stream 'function)
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 77be6fa..f86bff6 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -80,7 +80,7 @@
 ;;;; classes
 
 (sb!xc:deftype name-for-class () t)
-(defknown classoid-name (classoid) name-for-class (flushable))
+(defknown classoid-name (classoid) symbol (flushable))
 (defknown find-classoid (name-for-class &optional t)
   (or classoid null) ())
 (defknown classoid-of (t) classoid (flushable))
@@ -966,7 +966,7 @@
   (flushable unsafe))
 (defknown make-string-output-stream
     (&key (:element-type type-specifier))
-    stream
+    string-output-stream
   (flushable))
 (defknown get-output-stream-string (stream) simple-string ())
 (defknown streamp (t) boolean (movable foldable flushable))
diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp
index d0231ce..755467a 100644
--- a/src/compiler/proclaim.lisp
+++ b/src/compiler/proclaim.lisp
@@ -231,11 +231,18 @@
                      (when (type/= ctype old-type)
                        ;; FIXME: changing to FTYPE-PROCLAMATION-MISMATCH
                        ;; broke late-proclaim.lisp.
-                       (style-warn
-                        "~@<new FTYPE proclamation for ~S~@:_  ~S~@:_~
-                       does not match the old FTYPE proclamation:~@:_  ~S~@:>"
-                        name (type-specifier ctype) (type-specifier old-type)))))
-
+                       (if (info :function :info name)
+                           ;; Allow for tightening of known function types
+                           (unless (csubtypep ctype old-type)
+                             (cerror "Continue"
+                                     "~@<new FTYPE proclamation for known function ~S~@:_  ~S~@:_~
+                                      does not match its old FTYPE:~@:_  ~S~@:>"
+                                     name (type-specifier ctype) (type-specifier old-type)))
+                           (#+sb-xc-host warn
+                            #-sb-xc-host style-warn
+                            "~@<new FTYPE proclamation for ~S~@:_  ~S~@:_~
+                             does not match the old FTYPE proclamation:~@:_  ~S~@:>"
+                            name (type-specifier ctype) (type-specifier old-type))))))
                  ;; Now references to this function shouldn't be warned
                  ;; about as undefined, since even if we haven't seen a
                  ;; definition yet, we know one is planned.
diff --git a/version.lisp-expr b/version.lisp-expr
index 6e2883f..d4d0951 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -20,4 +20,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.47.23"
+"1.0.47.24"
-- 
1.7.10.4