-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathmodf-test.lisp
250 lines (223 loc) · 10.5 KB
/
modf-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
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
(in-package :modf-test)
(in-root-suite)
(deftest run-tests ()
(modf-eval-test)
(fsetf-tests)
(recursive-definitions)
(late-invert-class)
(late-invert-struct)
(test-lists)
(test-arrays)
(test-structs)
(test-classes))
#+closer-mop
(defun class-equal (obj1 obj2)
(let* ((class (class-of obj1))
(slots (closer-mop:class-slots class)))
(is (eql class (class-of obj2)))
(iter (for slot in slots)
(cond ((slot-boundp obj1 (closer-mop:slot-definition-name slot))
(is (equal
(slot-value obj1 (closer-mop:slot-definition-name slot))
(slot-value obj2 (closer-mop:slot-definition-name slot)))))
(t (is (not (slot-boundp
obj2 (closer-mop:slot-definition-name slot)))))))))
;; We need to test to make sure certain recursive definitions are possible.
;; Because we make certain assumptions about the arguments in the case of a
;; missing inversion method, we need to have a argument order like NTH or
;; GETHASH.
(define-modf-function nth** 2 (new-val nth list)
(if (= nth 0)
(cons new-val (cdr list))
(cons (car list)
(modf (nth** (- nth 1) (modf-eval (cdr list)))
new-val))))
(deftest recursive-definitions ()
(remhash (intern (modf::modf-name 'nth*)) modf::*modf-nth-arg*)
(unintern (intern (modf::modf-name 'nth*)))
(define-modf-function nth* 2 (new-val nth list)
(if (= nth 0)
(cons new-val (cdr list))
(cons (car list)
(modf (nth* (- nth 1) (modf-eval (cdr list)))
new-val))))
(let ((list '(1 2 3 4)))
(is (equal (modf (nth* 2 list) t) '(1 2 t 4)))
(is (equal (modf (nth** 2 list) t) '(1 2 t 4)))))
(deftest modf-eval-test ()
(is (equal '(1 t 3 4) (modf (second (modf-eval '(1 2 3 4))) t))))
(deftest fsetf-tests ()
(let ((ima '((1 2 3) (4 5 6) (7 8 9))))
(fsetf (second ima) 'second)
(fsetf (second (first ima)) 'first-second
(third ima) 'third)
(is (equal '((1 first-second 3) second third)
ima))))
(defclass late-parent ()
((parent-slot :accessor parent-slot-of
:initarg :parent-slot)))
(defclass late-child (late-parent)
((child-slot :accessor child-slot-of
:initarg :child-slot)))
(deftest late-invert-class ()
(let ((obj (make-instance 'late-child)))
(class-equal (modf (child-slot-of obj) 'value)
(make-instance 'late-child
:child-slot 'value))
(class-equal (modf (parent-slot-of obj) 'value)
(make-instance 'late-child
:parent-slot 'value)))
(let ((obj (make-instance 'late-child
:parent-slot 'a
:child-slot 'b)))
(class-equal (modf (child-slot-of obj) 'value)
(make-instance 'late-child
:parent-slot (parent-slot-of obj)
:child-slot 'value))
(class-equal (modf (parent-slot-of obj) 'value)
(make-instance 'late-child
:parent-slot 'value
:child-slot (child-slot-of obj))))
(let ((obj (make-instance 'late-parent)))
(class-equal (modf (parent-slot-of obj) 'value)
(make-instance 'late-parent
:parent-slot 'value))))
(defstruct late-struct a b c)
(defun ls-equal (obj1 obj2)
(and (is (equal (late-struct-a obj1) (late-struct-a obj2)))
(is (equal (late-struct-b obj1) (late-struct-b obj2)))
(is (equal (late-struct-c obj1) (late-struct-c obj2)))))
(defstruct late-included included)
(defstruct (late-including (:include late-included)) a b c)
(defun li-equal (obj1 obj2)
(and (is (equal (late-including-a obj1) (late-including-a obj2)))
(is (equal (late-including-b obj1) (late-including-b obj2)))
(is (equal (late-including-c obj1) (late-including-c obj2)))
(is (equal (late-including-included obj1)
(late-including-included obj2)))))
(deftest late-invert-struct ()
(let ((modf::*accessor-heuristics* t))
(let ((str1 (make-late-struct :a 1 :b 2 :c 3))
(str2 (make-late-struct)))
(ls-equal (modf (late-struct-a str1) t)
(make-late-struct :a t :b 2 :c 3))
(ls-equal (modf (late-struct-a str2) t)
(make-late-struct :a t))
(ls-equal (modf (late-struct-c str1) t)
(make-late-struct :a 1 :b 2 :c t))
(ls-equal (modf (late-struct-c str2) t)
(make-late-struct :c t)))
(with-expected-failures
(let ((str1 (make-late-including :a 1 :b 2 :c 3 :included 4))
(str2 (make-late-including)))
(li-equal (modf (late-including-a str1) t)
(make-late-including :a t :b 2 :c 3))
(li-equal (modf (late-including-a str2) t)
(make-late-including :a t))
(li-equal (modf (late-including-included str1) t)
(make-late-including :a 1 :b 2 :c 3 :included t))
(li-equal (modf (late-including-included str2) t)
(make-late-including :included t))
;; Test using the accessors of an included object
(li-equal (modf (late-included-included str1) t)
(make-late-including :a 1 :b 2 :c 3 :included t))
(li-equal (modf (late-included-included str2) t)
(make-late-including :included t))))))
(defsuite* lisp-types)
(deftest test-lists ()
(let ((list '(1 2 (3 4) (5 (6 (7))) 8)))
(is (equal '(t 2 (3 4) (5 (6 (7))) 8) (modf (car list) t)))
(is (equal '(1 t (3 4) (5 (6 (7))) 8) (modf (cadr list) t)))
(is (equal '(1 2 (3 t) (5 (6 (7))) 8) (modf (cadr (caddr list)) t)))
(is (equal '(1 2 (3 4) (5 (a b c)) 8) (modf (second (fourth list)) '(a b c))))
(is (equal '(1 2 (3 4) (5 (6 (7))) . end) (modf (last list) 'end)))
;; Chaining
(is (equal '(1 2 t nil "hello") (modf (third list) t
& (fourth &) nil
& (fifth &) "hello")))
;; Apply and funcall. These don't really make sense here, but whatever
(is (equal '(one 2 (3 4) (5 (6 (7))) 8) (modf (funcall #'car list) 'one)))
(is (equal '(1 two (3 4) (5 (6 (7))) 8) (modf (funcall #'car
(funcall #'cdr list))
'two)))
;; (with-expected-failures
;; ;; These should all fail. This is because, like with setf, you can only
;; ;; apply on certain functions (AREF and friends and user defined
;; ;; functions). I am thinking about removing this limitation.
;; (is (equal '(one 2 (3 4) (5 (6 (7))) 8) (modf (apply #'car (modf-eval (list list)))
;; 'one)))
;; (is (equal '(1 two (3 4) (5 (6 (7))) 8) (modf (apply #'car
;; (apply #'cdr (modf-eval (list list))) nil)
;; 'two))))
))
(deftest test-plists ()
(let* ((string-key "string-key")
(plist `(:a 1 :b 2 :b 5 ,string-key 10)))
(is (equal (modf (getf plist :a) 0)
`(:a 0 :b 2 :b 5 ,string-key 10)))
(is (equal (modf (getf plist :b) 0)
`(:a 1 :b 0 :b 5 ,string-key 10)))
(is (equal (modf (getf plist :not-present) 0)
`(:not-present 0 :a 1 :b 2 :b 5 ,string-key 10)))
(is (equal (modf (getf plist string-key) 100)
`(:a 1 :b 2 :b 5 ,string-key 100)))
(let ((equal-but-not-eq (string-downcase (string-upcase string-key))))
(is (equal (modf (getf plist equal-but-not-eq) 100)
`(,string-key 100 :a 1 :b 2 :b 5 ,string-key 10))))))
(deftest test-arrays ()
;; One dimensional
(let ((arr #(1 2 3 4 5 6))
(arr-of-lists #((1 2 3) (4 5 6))))
(is (equalp #(t 2 3 4 5 6) (modf (aref arr 0) t)))
;; Funcall
(is (equalp #(1 2 t 4 5 6) (modf (funcall #'aref arr 2) t)))
(is (equalp #((1 2 t) (4 5 6)) (modf (funcall #'third
(funcall #'aref arr-of-lists 0))
t)))
;; Apply
(is (equalp #(1 t 3 4 5 6) (modf (apply #'aref arr '(1)) t)))
(is (equalp #((1 2 3) (4 t 6)) (modf (funcall #'second
(apply #'aref arr-of-lists '(1)))
t)))
;; Chaining
(is (iter (for el1 in-sequence #(6 5 4 3 2 6))
(for el2 in-sequence (modf (aref arr 0) 6
& (aref & 1) 5
& (aref & 2) 4
& (aref & 3) 3
& (aref & 4) 2))
(always (eql el1 el2)))))
;; Two dimensional just to make sure (should be the same)
(let ((arr #2A((1 2 3) (4 5 6))))
(is (equalp #2A((t 2 3) (4 5 6)) (modf (aref arr 0 0) t)))
;; Funcall
(is (equalp #2A((1 2 t) (4 5 6)) (modf (funcall #'aref arr 0 2) t)))
;; Apply
(is (equalp #2A((1 t 3) (4 5 6)) (modf (apply #'aref arr '(0 1)) t)))))
(modf-def:define-modf-for-class-slots (defclass test-class2 (test-parent)
((c :accessor c-of :initarg :c))))
(deftest test-classes ()
(let ((class1 (make-instance 'test-class1 :b 4 :a 7))
(class2 (make-instance 'test-class2 :c t :a nil)))
#+closer-mop
(progn (is (eql 0 (b-of (modf (slot-value class1 'b) 0))))
(is (eql 3 (a-of (modf (slot-value class1 'a) 3)))))
#-closer-mop
(with-expected-failures
(is (eql 0 (let ((class1 (make-instance 'test-class1 :b 4 :a 7)))
(b-of (modf (slot-value class1 'b) 0)))))
(is (eql 3 (let ((class1 (make-instance 'test-class1 :b 4 :a 7)))
(a-of (modf (slot-value class1 'a) 3))))))
(is (eql 4 (let ((class1 (make-instance 'test-class1 :b 4 :a 7)))
(a-of (modf (a-of class1) 4))))
"Failed to invert accessor function using heuristics.")
(is (eql 2 (b-of (modf (b-of class1) 2))))
(is (eql 'hello (c-of (modf (c-of class2) 'hello))))))
(modf-def:defstruct test-struct1 b)
(defstruct test-struct2 c)
(modf-def:define-modf-for-struct-slots (defstruct test-struct2 c))
(deftest test-structs ()
(let ((s1 (make-test-struct1 :b 'b-slot))
(s2 (make-test-struct2 :c 'c-slot)))
(is (eql 2 (test-struct1-b (modf (test-struct1-b s1) 2))))
(is (eql -1 (test-struct2-c (modf (test-struct2-c s2) -1))))))