function.lsp 4.97 KB
Newer Older
1 2 3
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Mon Oct  7 07:34:29 2002
4
;;;; Contains: Tests for type FUNCTION and the special form FUNCTION
5

6

7 8 9 10 11 12 13 14 15 16

;;;
;;; Note! There are significant incompatibilities between CLTL1 and ANSI CL
;;; in the meaning of FUNCTION and FUNCTIONP.
;;;

(deftest function.1
  (typep nil 'function)
  nil)

17 18
;;; The next test demonstrates an incompatibility between CLtL1 and ANSI CL.
;;; In ANSI CL, symbols are no longer of type FUNCTION.
19 20 21 22 23
(deftest function.2
  (typep 'identity 'function)
  nil)

(deftest function.3
24
  (not-mv (typep #'identity 'function))
25 26 27 28
  nil)

(deftest function.4
  (loop for x in *cl-symbol-names*
sds's avatar
sds committed
29 30 31 32 33 34 35 36 37
        for s = (find-symbol x "CL")
        for f = (and (fboundp s)
                     (symbol-function s)
                     (not (special-operator-p s))
                     (not (macro-function s))
                     (symbol-function s))
        unless (or (null f)
                   (typep f 'function))
        collect x)
38
  nil)
39 40 41 42 43

(deftest function.5
  (typep '(setf car) 'function)
  nil)

44 45
;;; The next test demonstrates an incompatibility between CLtL1 and ANSI CL.
;;; In ANSI CL, lambda forms are no longer of type FUNCTION.
46 47 48 49
(deftest function.6
  (typep '(lambda (x) x) 'function)
  nil)

50 51
(report-and-ignore-errors
 (defun (setf function-7-accessor) (y x) (setf (car x) y) y))
pfdietz's avatar
pfdietz committed
52 53

(deftest function.7
54
  (not-mv (typep #'(setf function-7-accessor) 'function))
pfdietz's avatar
pfdietz committed
55
  nil)
56 57

(deftest function.8
58
  (not-mv (typep #'(lambda (x) x) 'function))
59 60 61
  nil)

(deftest function.9
62
  (not-mv (typep (compile nil '(lambda (x) x)) 'function))
63 64
  nil)

65 66
;;; The next test demonstrates an incompatibility between CLtL1 and ANSI CL.
;;; In ANSI CL, symbols and cons can no longer also be of type FUNCTION.
67
(deftest function.10
68
  (check-predicate (typef '(not (and (or number character symbol
sds's avatar
sds committed
69 70
                                         cons array)
                                     function))))
71
  nil)
72 73 74 75 76 77

(deftest function.11
  (flet ((%f () nil)) (typep '%f 'function))
  nil)

(deftest function.12
78
  (flet ((%f () nil)) (not-mv (typep #'%f 'function)))
79
  nil)
80 81

(deftest function.13
82
  (labels ((%f () nil)) (not-mv (typep #'%f 'function)))
83 84 85 86 87 88 89
  nil)

;;; "If name is a function name, the functional definition of that
;;; name is that established by the innermost lexically enclosing flet,
;;; labels, or macrolet form, if there is one." (page for FUNCTION, sec. 5.3)
;;;            ^^^^^^^^
;;;(deftest function.14
90
;;;  (macrolet ((%f () nil)) (not-mv (typep #'%f 'function)))
91
;;;  nil)
92 93 94 95 96 97 98 99 100 101

;;; Tests of FUNCTION type specifiers

(deftest function.14
  (flet ((%f () nil))
    (declare (optimize safety debug))
    (let ((f #'%f))
      (declare (type (function () null) f))
      (funcall f)))
  nil)
102 103 104 105 106 107 108 109 110 111 112 113 114

(deftest function.15
  (flet ((%f (x) (declare (ignore x)) nil))
    (declare (ftype (function (nil) nil) %f))
    :good)
  :good)

(deftest function.16
  (flet ((%f (x) (declare (ignore x)) nil))
    (declare (ftype (function (t) null) %f))
    (values
     (%f 'a)
     (locally (declare (ftype (function (integer) t) %f))
sds's avatar
sds committed
115
              (%f 10))
116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155
     (%f 'b)))
  nil nil nil)

(deftest function.17
  (flet ((%f (&optional x) x))
    (declare (ftype (function (&optional integer) t) %f))
    (values (%f) (%f 10) (%f) (%f (1+ most-positive-fixnum))))
  nil 10 nil #.(1+ most-positive-fixnum))

(deftest function.18
  (flet ((%f (&rest x) x))
    (declare (ftype (function (&rest symbol) t) %f))
    (values (%f) (%f 'a) (%f 'a 'b 'c)))
  () (a) (a b c))

(deftest function.19
  (flet ((%f (&key foo bar) (list foo bar)))
    (declare (ftype (function (&key (:foo t) (:bar t)) list) %f))
    (values
     (%f) (%f :foo 1)
     (%f :foo 1 :foo 2)
     (%f :bar 'a)
     (%f :bar 'a :bar 'b)
     (%f :foo 'x :bar 'y)
     (%f :bar 'x :foo 'y)
     (%f :bar 'x :foo 'y :bar 'z :foo 'w)
     ))
  (nil nil)
  (1 nil)
  (1 nil)
  (nil a)
  (nil a)
  (x y)
  (y x)
  (y x))

(deftest function.20
  (flet ((%f (&key foo) foo))
    (declare (ftype (function (&key (:foo t) (:allow-other-keys t)) t) %f))
    (values (%f) (%f :foo 'a) (%f :allow-other-keys nil)
sds's avatar
sds committed
156
            (%f :allow-other-keys t :foo 'z)))
157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184
  nil a nil z)

(deftest function.21
  (flet ((%f (&key foo &allow-other-keys) foo))
    (declare (ftype (function (&key (:foo integer)) t) %f))
    (values (%f) (%f :foo 123)))
  nil 123)

(deftest function.22
  (flet ((%f (&key foo &allow-other-keys) foo))
    (declare (ftype (function (&key (:foo integer) (:bar t)) t) %f))
    (values (%f) (%f :foo 123) (%f :bar 'x) (%f :foo 12 :bar 'y)))
  nil 123 nil 12)

(deftest function.23
  (flet ((%f (&key foo &allow-other-keys) foo))
    (declare (ftype (function (&key (:foo integer) &allow-other-keys) t) %f))
    (values (%f) (%f :foo 123) (%f :bar 'x) (%f :foo 12 :bar 'y)))
  nil 123 nil 12)

(deftest function.24
  (flet ((%f (&rest r &key foo bar) (list r foo bar)))
    (declare (ftype (function (&rest symbol &key (:foo t) (:bar t)) list) %f))
    (values (%f) (%f :foo 'a) (%f :bar 'b) (%f :bar 'd :foo 'c)))
  (nil nil nil)
  ((:foo a) a nil)
  ((:bar b) nil b)
  ((:bar d :foo c) c d))