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 (load "assertoid.lisp")
  13 (use-package "ASSERTOID")
  14
  15 ;;; Check for correct defaulting of unsupplied parameters to *
  16 (deftype opt (&optional arg)
  17   `(integer 0 ,arg))
  18 (deftype opt-singleton (&optional (arg))
  19   `(integer 0 ,arg))
  20 (deftype key (&key arg)
  21   `(integer 0 ,arg))
  22 (deftype key-singleton (&key (arg))
  23   `(integer 0 ,arg))
  24
  25 (assert (typep 1 'opt))
  26 (assert (typep 1 'opt-singleton))
  27 (assert (typep 1 'key))
  28 (assert (typep 1 'key-singleton))
  29
  30 ;;; empty body
  31 (deftype deftype-with-empty-body ())
  32 (assert (subtypep 'deftype-with-empty-body nil))
  33 (assert (subtypep nil 'deftype-with-empty-body))
  34
  35 ;;; atom body
  36 (deftype deftype.atom-body () t)
  37 (with-test (:name (deftype atom :body))
  38   (assert (subtypep 'deftype.atom-body t))
  39   (assert (subtypep t 'deftype.atom-body)))
  40
  41 ;; Ensure that DEFTYPE can successfully replace a DEFSTRUCT type
  42 ;; definition.
  43 (defstruct foo)
  44 (assert (progn (deftype foo () 'integer)
  45                (null (find-class 'foo nil))
  46                t))
  47
  48 ;; Ensure that DEFCLASS after DEFTYPE nukes the lambda-list.
  49 (defun get-deftype-lambda-list (symbol)
  50   (let ((expander (sb-int:info :type :expander symbol)))
  51     (and (functionp expander)
  52          (sb-kernel:%fun-lambda-list expander))))
  53 (deftype bar (x) `(integer ,x))
  54 (assert (equal '(x) (get-deftype-lambda-list 'bar)))
  55 (defclass bar () ())
  56 (assert (not (get-deftype-lambda-list 'bar)))
  57
  58 ;; Need to work with plain symbols as the body.
  59 (defconstant whatever 't)
  60 (deftype anything () whatever)
  61 (assert (typep 42 'anything))
  62
  63 (with-test (:name :deftype-not-list-lambda-list)
  64   (assert-error (eval `(deftype ,(gensym) non-list-argument))))