Only COERCE-TO-FUN if the result-type is exactly FUNCTION

It's definitely wrong to attempt to coerce symbols and lambda forms to
subclasses of FUNCALLABLE-STANDARD-OBJECT.  (This move to "exactly
FUNCTION" might be too strong, though I think it's probably a bit
weird to expect COERCE to do anything sensible with contorted subtypes
of FUNCTION, e.g. (COERCE '+ '(AND FUNCTION (SATISFIES HALTS-P))).

NEWS

@@ -4,6 +4,8 @@ changes relative to sbcl-2.4.1:
   * bug fix: restore the ability to inherit from both SEQUENCE and
     SB-MOP:FUNCALLABLE-STANDARD-OBJECT.  (lp#2050088, reported by Christophe
     Junke)
+  * bug fix: COERCE will not convert lambda forms to functions if given a type
+    naming a (strict) subclass of FUNCTION.
 
 changes in sbcl-2.4.1 relative to sbcl-2.4.0:
   * enhancement: compact instance headers are partially supported with the

src/code/coerce.lisp

@@ -244,7 +244,7 @@
            (if class
                (coerce-to-extended-sequence object class)
                (coerce-error))))
-        ((csubtypep type (specifier-type 'function))
+        ((type= type (specifier-type 'function))
          (coerce-to-fun object))
         (t
          (coerce-error))))))

src/compiler/typetran.lisp

@@ -1646,7 +1646,7 @@
          (if (null class)
              (give-up-ir1-transform)
              `(coerce-to-extended-sequence x (load-time-value (find-class ',tval) t)))))
-      ((csubtypep tspec (specifier-type 'function))
+      ((type= tspec (specifier-type 'function))
        (if (csubtypep (lvar-type x) (specifier-type 'symbol))
            `(coerce-symbol-to-fun x)
            ;; if X can later be derived as FUNCTION then we don't want

tests/mop-36.impure.lisp

@@ -0,0 +1,51 @@
+;;;; Interaction of SB-MOP:FUNCALLABLE-STANDARD-OBJECT with COERCE
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(defun unoptimized/symbol ()
+  (lambda (x)
+    (coerce x (opaque-identity 'sb-mop:funcallable-standard-object))))
+(defun unoptimized/class ()
+  (lambda (x)
+    (coerce x (opaque-identity (find-class 'sb-mop:funcallable-standard-object)))))
+(defun optimized/symbol ()
+  (compile nil `(lambda (x) (coerce x 'sb-mop:funcallable-standard-object))))
+(defun optimized/class ()
+  (compile nil `(lambda (x) (coerce x ',(find-class 'sb-mop:funcallable-standard-object)))))
+
+(with-test (:name (coerce standard-object))
+  (let ((o (make-instance 'standard-object)))
+    (assert-error (funcall (unoptimized/symbol) o) type-error)
+    (assert-error (funcall (unoptimized/class) o) type-error)
+    (assert-error (funcall (optimized/symbol) o) type-error)
+    (assert-error (funcall (optimized/class) o) type-error)))
+
+(with-test (:name (coerce :funcallable-standard-object))
+  (let ((o (make-instance 'sb-mop:funcallable-standard-object)))
+    (assert (eql (funcall (unoptimized/symbol) o) o))
+    (assert (eql (funcall (unoptimized/class) o) o))
+    (assert (eql (funcall (optimized/symbol) o) o))
+    (assert (eql(funcall (optimized/class) o) o))))
+
+(with-test (:name (coerce symbol))
+  (let ((o 'identity))
+    (assert-error (funcall (unoptimized/symbol) o) type-error)
+    (assert-error (funcall (unoptimized/class) o) type-error)
+    (assert-error (funcall (optimized/symbol) o) type-error)
+    (assert-error (funcall (optimized/class) o) type-error)))
+
+(with-test (:name (coerce lambda))
+  (let ((o '(lambda (x) (1+ x))))
+    (assert-error (funcall (unoptimized/symbol) o) type-error)
+    (assert-error (funcall (unoptimized/class) o) type-error)
+    (assert-error (funcall (optimized/symbol) o) type-error)
+    (assert-error (funcall (optimized/class) o) type-error)))