the.lsp 3.56 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Tue May  6 06:48:48 2003
;;;; Contains: Tests of THE

(in-package :cl-test)

(deftest the.1
  (the (values) (values)))

(deftest the.2
  (the (values) 'a)
  a)

(deftest the.3
16
  (check-predicate #'(lambda (e)
sds's avatar
sds committed
17 18
                       (let ((x (multiple-value-list (eval `(the (values) (quote ,e))))))
                         (and x (not (cdr x)) (eql (car x) e)))))
19 20 21
  nil)

(deftest the.4
22
  (check-predicate #'(lambda (e)
sds's avatar
sds committed
23 24
                       (let ((x (multiple-value-list (eval `(the ,(type-of e) (quote ,e))))))
                         (and x (not (cdr x)) (eql (car x) e)))))
25
  nil)
26 27

(deftest the.5
28
  (check-predicate #'(lambda (e)
sds's avatar
sds committed
29 30
                       (let ((x (multiple-value-list (eval `(the (values ,(type-of e)) (quote ,e))))))
                         (and x (not (cdr x)) (eql (car x) e)))))
31 32 33
  nil)

(deftest the.6
34
  (check-predicate #'(lambda (e)
sds's avatar
sds committed
35 36
                       (let ((x (multiple-value-list (eval `(the (values ,(type-of e) t) (quote ,e))))))
                         (and x (not (cdr x)) (eql (car x) e)))))
37 38 39
  nil)

(deftest the.7
40 41 42
  (check-predicate
   #'(lambda (e)
       (let ((x (multiple-value-list (eval `(the (values ,(type-of e))
sds's avatar
sds committed
43 44 45 46
                                              (values (quote ,e) :ignored))))))
         (and (eql (length x) 2)
              (eql (car x) e)
              (eql (cadr x) :ignored)))))
47
  nil)
pfdietz's avatar
pfdietz committed
48 49

(deftest the.8
50
  (check-predicate #'(lambda (e) (or (not (constantp e))
sds's avatar
sds committed
51
                                     (eql (eval `(the ,(type-of e) ,e)) e))))
pfdietz's avatar
pfdietz committed
52 53 54
  nil)

(deftest the.9
55
  (check-predicate #'(lambda (e) (or (not (constantp e))
sds's avatar
sds committed
56
                                     (eql (eval `(the ,(class-of e) ,e)) e))))
pfdietz's avatar
pfdietz committed
57 58 59
  nil)

(deftest the.10
60
  (check-predicate #'(lambda (e) (eql (eval `(the ,(class-of e) ',e)) e)))
pfdietz's avatar
pfdietz committed
61 62
  nil)

63
(deftest the.11
64 65 66
  (check-predicate
   #'(lambda (e)
       (let* ((type (type-of e))
sds's avatar
sds committed
67 68
              (x (multiple-value-list (eval `(the ,type (the ,type (quote ,e)))))))
         (and x (not (cdr x)) (eql (car x) e)))))
69 70 71 72
  nil)

(deftest the.12
  (let ((lexpr
sds's avatar
sds committed
73 74 75 76 77
         `(lambda ()
            (and
             ,@(loop for e in *mini-universe*
                     for type = (type-of e)
                     collect `(eqlt (quote ,e) (the ,type (quote ,e))))))))
78 79 80 81 82 83 84 85 86 87 88
    (funcall (compile nil lexpr)))
  t)

(deftest the.13
  (let ((x 0))
    (values
     (the (or symbol integer) (incf x))
     x))
  1 1)

(deftest the.14
89
  (the (values &rest t) (values 'a 'b))
90 91 92
  a b)

(deftest the.15
93
  (the (values &rest symbol) (values 'a 'b))
94 95 96 97
  a b)

(deftest the.16
  (the (values &rest null) (values)))
98 99 100 101 102 103 104 105

(deftest the.17
  (the (values symbol integer &rest null) (values 'a 1))
  a 1)

(deftest the.18
  (the (values symbol integer &rest t) (values 'a 1 'foo '(x y)))
  a 1 foo (x y))
106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128

(deftest the.19
  (let () (list (the (values) (eval '(values)))))
  (nil))

;;; This is from SBCL bug 261
(deftest the.20
  (let () (list (the (values &optional fixnum) (eval '(values)))))
  (nil))

(deftest the.21
  (let () (list (the (values &rest t) (eval '(values)))))
  (nil))

(deftest the.22
  (the (values symbol integer &rest t) (eval '(values 'a 1 'foo '(x y))))
  a 1 foo (x y))

(deftest the.23
  (multiple-value-list
   (the (values symbol integer &optional fixnum) (eval '(values 'a 1))))
  (a 1))

129 130 131 132 133 134 135 136 137 138 139 140 141 142
;;; Test that explicit calls to macroexpand in subforms
;;; are done in the correct environment

(deftest the.24
  (macrolet
   ((%m (z) z))
   (the (integer 0 10) (expand-in-current-env (%m 4))))
  4)

(deftest the.25
  (macrolet
   ((%m (z) z))
   (the (values t t) (expand-in-current-env (%m (values 1 2)))))
  1 2)
143