tests/mop-36.impure.lisp

   1 ;;;; Interaction of SB-MOP:FUNCALLABLE-STANDARD-OBJECT with COERCE
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (defun unoptimized/symbol ()
  15   (lambda (x)
  16     (coerce x (opaque-identity 'sb-mop:funcallable-standard-object))))
  17 (defun unoptimized/class ()
  18   (lambda (x)
  19     (coerce x (opaque-identity (find-class 'sb-mop:funcallable-standard-object)))))
  20 (defun optimized/symbol ()
  21   (compile nil `(lambda (x) (coerce x 'sb-mop:funcallable-standard-object))))
  22 (defun optimized/class ()
  23   (compile nil `(lambda (x) (coerce x ',(find-class 'sb-mop:funcallable-standard-object)))))
  24
  25 (with-test (:name (coerce standard-object))
  26   (let ((o (make-instance 'standard-object)))
  27     (assert-error (funcall (unoptimized/symbol) o) type-error)
  28     (assert-error (funcall (unoptimized/class) o) type-error)
  29     (assert-error (funcall (optimized/symbol) o) type-error)
  30     (assert-error (funcall (optimized/class) o) type-error)))
  31
  32 (with-test (:name (coerce :funcallable-standard-object))
  33   (let ((o (make-instance 'sb-mop:funcallable-standard-object)))
  34     (assert (eql (funcall (unoptimized/symbol) o) o))
  35     (assert (eql (funcall (unoptimized/class) o) o))
  36     (assert (eql (funcall (optimized/symbol) o) o))
  37     (assert (eql(funcall (optimized/class) o) o))))
  38
  39 (with-test (:name (coerce symbol))
  40   (let ((o 'identity))
  41     (assert-error (funcall (unoptimized/symbol) o) type-error)
  42     (assert-error (funcall (unoptimized/class) o) type-error)
  43     (assert-error (funcall (optimized/symbol) o) type-error)
  44     (assert-error (funcall (optimized/class) o) type-error)))
  45
  46 (with-test (:name (coerce lambda))
  47   (let ((o '(lambda (x) (1+ x))))
  48     (assert-error (funcall (unoptimized/symbol) o) type-error)
  49     (assert-error (funcall (unoptimized/class) o) type-error)
  50     (assert-error (funcall (optimized/symbol) o) type-error)
  51     (assert-error (funcall (optimized/class) o) type-error)))