-
Notifications
You must be signed in to change notification settings - Fork 3
/
Copy pathfunctional-test.lisp
177 lines (147 loc) · 6 KB
/
functional-test.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
;;; Copyright 2020 Google LLC
;;;
;;; Use of this source code is governed by an MIT-style
;;; license that can be found in the LICENSE file or at
;;; https://opensource.org/licenses/MIT.
;;; Test package for ace.core.functional.
;;;
(defpackage #:ace.core.functional-test
(:use #:common-lisp
#:ace.core.functional
#:ace.core
#:ace.test)
(:import-from #:ace.core.functional
ace.core.functional::ftype-declaration
ace.core.functional::function-lambda-list
ace.core.functional::simple-lambda-list))
(in-package :ace.core.functional-test)
(defun foo (list)
(funcall (compose #'oddp #'car) list))
(defun not-foo (list)
(funcall (compose #'not #'oddp #'car) list))
(deftest compose-test ()
(expect (foo '(1 2)))
(expect (not (foo '(2 1))))
(expect (not-foo '(2 1)))
(expect (not (not-foo '(1 2)))))
(defun compose-list (just-arg)
(compose #'list just-arg))
(declaim (ftype (function (fixnum fixnum) fixnum) div) (inline div))
(defun div (x y)
(declare (fixnum x y) (optimize (speed 1) (safety 3)))
(/ x y))
;; This one uses the lambda list of the global function resolved.
(defun div3 (x y z)
(declare (fixnum x y z) (optimize (speed 1) (safety 3)))
(/ x y z))
(defun* div* (x &optional (y 2))
(declare (self inline (fixnum &optional fixnum) fixnum))
(/ x y))
(deftest compose-test2 ()
(expect (equal '(4) (funcall (compose-list #'1+) 3)))
(locally (declare (notinline compose) (optimize (safety 3)))
(expect-error (funcall (compose #'list #'div) 1 1 1))))
(deftest compose-test3 ()
(flet ((div (&rest args) (apply #'+ args)))
(expect (equal '(3) (funcall (compose #'list #'div) 1 1 1)))
(expect (equal '(3) (funcall (compose #'list 'div) 9 3)))
(expect (equal '(1) (funcall (compose #'list 'div3) 6 3 2)))
(locally (declare (notinline compose) (optimize (speed 1) (safety 3)))
;; DIV taken from the global environment.
(expect-error (funcall (compose #'list 'div) 1 1 1)))))
(deftest compose-test4 ()
(declare (optimize (speed 1) (safety 3)))
(flet ((div (x) (1+ x)))
(declare (ftype (function (fixnum) (values fixnum &optional)) div))
(expect (equal '(2) (funcall (compose #'list #'div) 1)))
(locally (declare (notinline compose))
;; DIV taken from the local environment.
(expect-error (funcall (compose #'list #'div) 1 1 1)))
;; DIV taken from the global environment.
(expect (equal '(3) (funcall (compose #'list 'div) 9 3)))))
(deftest compose-test5 ()
(declare (optimize (speed 1) (safety 3)))
(flet ((div (x) (1+ x)))
(expect (equal '(2) (funcall (compose #'list #'div) 1)))
(locally (declare (notinline compose))
;; DIV taken from the local environment.
(expect-error (funcall (compose #'list #'div) 1 1 1)))
;; DIV taken from the global environment.
(expect (equal '(3) (funcall (compose #'list 'div) 9 3)))))
(declaim (ftype (function (fixnum &optional fixnum) fixnum) divopt)
(inline divopt))
(defun divopt (x &optional (y 2))
(declare (fixnum x y) (optimize (speed 1) (safety 3)))
(/ x y))
(defun* divopt* (x &optional (y 2 yp))
(declare (self (fixnum &optional fixnum) (or null fixnum)))
(and yp (/ x y)))
(declaim (ftype (function (fixnum &optional fixnum fixnum) fixnum) divopt3))
(defun divopt3 (x &optional (y 1) (z 2))
(declare (fixnum x y z) (optimize (speed 1) (safety 3)))
(/ x y z))
;; This function has FTYPE to derive the lambda-list.
(declaim (ftype (function (fixnum fixnum &optional fixnum) fixnum) divopt3+))
(defun divopt3+ (x y &optional (z 2))
(declare (fixnum x y z) (optimize (speed 1) (safety 3)))
(/ x y z))
;; This function has no FTYPE to derive the lambda-list.
(defun divopt3* (x y &optional (z 2))
(declare (fixnum x y z) (optimize (speed 1) (safety 3)))
(/ x y z))
(deftest bind-test ()
;; fixed
(expect (= 5 (funcall (bind 'div 10) 2)))
(expect (= 5 (funcall (bind #'div 10) 2)))
(expect (= 5 (funcall (bind #'div3 100 10) 2)))
(expect (= 10 (funcall (funcall (bind #'constantly 10)))))
(expect (= 10 (funcall (funcall (bind #'constantly) 10))))
;; optional
(expect (= 5 (funcall (bind #'divopt 10) 2)))
(expect (= 5 (funcall (bind #'divopt 10))))
(expect (= 1 (funcall (bind #'divopt 10 10))))
(expect (= 5 (funcall (bind #'divopt) 10)))
(expect (= 5 (funcall (bind #'divopt) 10 2)))
(expect (= 5 (funcall (bind #'divopt* 10) 2)))
(expect (null (funcall (bind #'divopt* 10))))
(expect (= 5 (funcall (bind #'divopt3 10))))
(expect (= 5 (funcall (bind #'divopt3 20) 2)))
;; Test that with and without FTYPE this works correctly.
(expect (= 5 (funcall (bind #'divopt3+ 10) 1)))
(expect (= 5 (funcall (bind #'divopt3* 10) 1)))
;; rest
(expect (= 5 (funcall (bind #'/ 10) 2)))
(expect (= 3 (funcall (bind #'div 9) 3)))
;; error
(expect-error (funcall (bind #'divopt3+ 10))))
(deftest ftype-test ()
(expect (equal '(FUNCTION (FIXNUM FIXNUM) (VALUES FIXNUM &REST T))
(ftype-declaration 'div)))
(let ((lexenv
(handler-bind ((warning #'muffle-warning))
(sb-cltl2:augment-environment
nil :function '(foo)
:declare `((ftype (function (fixnum string) t) foo))))))
(expect (equal '(function (fixnum string) *)
(ftype-declaration 'foo lexenv)))))
(deftest function-lambda-list-test ()
(expect (equal '(X &OPTIONAL (Y 2)) (function-lambda-list 'div*))))
(deftest simple-lambda-list-test ()
(multiple-value-bind (ll args types)
(simple-lambda-list '#'div)
(expect (= 2 (length ll)))
(expect (= 2 (length args)))
(expect (= 2 (length types))))
(multiple-value-bind (ll args types)
(simple-lambda-list '#'div*)
(expect (= 3 (length ll)))
(expect (eq '&optional (second ll)))
(expect (= 2 (length (third ll))))
(expect (= 2 (length args)))
(expect (= 2 (length types))))
(multiple-value-bind (ll args types)
(simple-lambda-list '#'divopt*)
(expect (= 2 (length ll)))
(expect (eq '&rest (first ll)))
(expect (atom args))
(expect (null types))))