function.lsp 4.99 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

(in-package :cl-test)

;;;
;;; 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))