tests/deftype.impure.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; While most of SBCL is derived from the CMU CL system, the test
   5 ;;;; files (like this one) were written from scratch after the fork
   6 ;;;; from CMU CL.
   7 ;;;;
   8 ;;;; This software is in the public domain and is provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  10 ;;;; more information.
  11
  12 ;;; Check for correct defaulting of unsupplied parameters to *
  13 (deftype opt (&optional arg)
  14   `(integer 0 ,arg))
  15 (deftype opt-singleton (&optional (arg))
  16   `(integer 0 ,arg))
  17 (deftype key (&key arg)
  18   `(integer 0 ,arg))
  19 (deftype key-singleton (&key (arg))
  20   `(integer 0 ,arg))
  21
  22 (assert (typep 1 'opt))
  23 (assert (typep 1 'opt-singleton))
  24 (assert (typep 1 'key))
  25 (assert (typep 1 'key-singleton))
  26
  27 ;;; empty body
  28 (deftype deftype-with-empty-body ())
  29 (assert (subtypep 'deftype-with-empty-body nil))
  30 (assert (subtypep nil 'deftype-with-empty-body))
  31
  32 ;;; atom body
  33 (deftype deftype.atom-body () t)
  34 (with-test (:name (deftype atom :body))
  35   (assert (subtypep 'deftype.atom-body t))
  36   (assert (subtypep t 'deftype.atom-body)))
  37
  38 ;; Ensure that DEFTYPE can successfully replace a DEFSTRUCT type
  39 ;; definition.
  40 (defstruct foo)
  41 (assert (progn (deftype foo () 'integer)
  42                (null (find-class 'foo nil))
  43                t))
  44
  45 ;; Ensure that DEFCLASS after DEFTYPE nukes the lambda-list.
  46 (defun get-deftype-lambda-list (symbol)
  47   (let ((expander (sb-int:info :type :expander symbol)))
  48     (and (functionp expander)
  49          (sb-kernel:%fun-lambda-list expander))))
  50 (deftype bar (x) `(integer ,x))
  51 (assert (equal '(x) (get-deftype-lambda-list 'bar)))
  52 (defclass bar () ())
  53 (assert (not (get-deftype-lambda-list 'bar)))
  54
  55 ;; Need to work with plain symbols as the body.
  56 (defconstant whatever 't)
  57 (deftype anything () whatever)
  58 (assert (typep 42 'anything))
  59
  60 (with-test (:name :deftype-not-list-lambda-list)
  61   (assert-error (eval `(deftype ,(gensym) non-list-argument))))