tests/mop-35.impure.lisp

   1 ;;;; Constructing and instantiating subclasses of system classes
   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 (defmacro assert-subtype (class type)
  15   `(progn
  16      (assert-tri-eq t t (subtypep ',class ',type))
  17      (assert-instance-type ,class ,type)))
  18
  19 (defmacro assert-instance-type (class type)
  20   `(flet ((compiled (x) (typep x ',type))
  21           (evaled (x y) (typep x (opaque-identity y))))
  22      (assert (typep (make-instance ',class) ',type))
  23      (assert (compiled (make-instance ',class)))
  24      (assert (evaled (make-instance ',class) ',type))))
  25
  26 (defmacro assert-callable (class)
  27   `(let ((i (make-instance ',class)))
  28      (sb-mop:set-funcallable-instance-function i (lambda (x) (1+ x)))
  29      (assert (= (funcall i 51) 52))))
  30
  31 (macrolet ((test (stype)
  32              (let ((sname (intern (concatenate 'string "%" (symbol-name stype))))
  33                    (fsname (intern (concatenate 'string "%F" (symbol-name stype)))))
  34                `(progn
  35                   (defclass ,sname (,stype standard-object)
  36                     ())
  37                   (with-test (:name (,stype standard-object))
  38                     (assert-subtype ,sname ,stype)
  39                     (assert-instance-type ,sname (not function))
  40                     (assert-instance-type ,sname (not sequence)))
  41
  42                   (defclass ,fsname (,stype sb-mop:funcallable-standard-object)
  43                     ()
  44                     (:metaclass sb-mop:funcallable-standard-class))
  45                   (with-test (:name (,stype function type))
  46                     (assert-subtype ,fsname ,stype)
  47                     (assert-subtype ,fsname function)
  48                     (assert-instance-type ,fsname (not sequence)))
  49                   (with-test (:name (,stype function funcall))
  50                     (assert-callable ,fsname))))))
  51   (test stream)
  52   (test file-stream)
  53   (test string-stream))
  54
  55 (defclass %sequence (sequence standard-object)
  56   ())
  57 (with-test (:name (sequence standard-object))
  58   (assert-subtype %sequence sequence)
  59   (assert-instance-type %sequence (not function))
  60   (assert-instance-type %sequence (not stream)))
  61
  62 (defclass %fsequence (sequence sb-mop:funcallable-standard-object)
  63   ()
  64   (:metaclass sb-mop:funcallable-standard-class))
  65 (with-test (:name (sequence function type))
  66   (assert-subtype %fsequence sequence)
  67   (assert-subtype %fsequence function)
  68   (assert-instance-type %fsequence (not stream)))
  69 (with-test (:name (sequence function funcall))
  70   (assert-callable %fsequence))
  71
  72 (macrolet ((test (stype)
  73              (let ((sname (intern (concatenate 'string "%SEQ" (symbol-name stype))))
  74                    (fsname (intern (concatenate 'string "%FSEQ" (symbol-name stype)))))
  75                `(progn
  76                   (defclass ,sname (,stype sequence standard-object)
  77                     ())
  78                   (with-test (:name (,stype sequence standard-object))
  79                     (assert-subtype ,sname ,stype)
  80                     (assert-instance-type ,sname (not function))
  81                     (assert-subtype ,sname sequence))
  82
  83                   (defclass ,fsname (,stype sequence sb-mop:funcallable-standard-object)
  84                     ()
  85                     (:metaclass sb-mop:funcallable-standard-class))
  86                   (with-test (:name (,stype sequence function))
  87                     (assert-subtype ,fsname ,stype)
  88                     (assert-subtype ,fsname function)
  89                     (assert-subtype ,fsname sequence))
  90                   (with-test (:name (,stype sequence function funcall))
  91                     (assert-callable ,fsname))))))
  92   (test stream)
  93   (test file-stream)
  94   (test string-stream))
  95