-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy patheqv-hash-test.lisp
executable file
·176 lines (156 loc) · 4.86 KB
/
eqv-hash-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
;;; -*- mode: lisp -*-
;;;
;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic@yahoo.com)
;;;
(in-package :eqv-hash-user)
(defclass foo ()
((slot1 :initform 0 :initarg :slot1 :type fixnum :accessor slot1)
(slot2 :initform 0 :initarg :slot2 :type fixnum :accessor slot2)))
(defclass foo-intention (equalp-key-situation) ())
(defparameter +foo-intention+ (make-instance 'foo-intention))
(defmethod eqv ((foo1 foo) (foo2 foo) (s (eql +foo-intention+)))
(eql (slot1 foo1) (slot1 foo2)))
(defmethod hash ((foo1 foo) (s (eql +foo-intention+)))
(floor (slot1 foo1) 2))
(deftest htref.test-1 ; (eqv i1 i2), (= (hash i1) (hash i2))
(let ((ght (make-generalized-hash-table +foo-intention+))
(i1 (make-instance 'foo :slot1 1 :slot2 2))
(i2 (make-instance 'foo :slot1 1 :slot2 3)))
(setf (htref ght i1) i1)
(setf (htref ght i2) i2)
(and (= (cnt ght) 1)
(eq (htref ght i1) i2)
(eq (htref ght i2) i2)))
t)
(deftest htref.test-2 ; (not (eqv i1 i2)), (= (hash i1) (hash i2))
(let ((ght (make-generalized-hash-table +foo-intention+))
(i1 (make-instance 'foo :slot1 2))
(i2 (make-instance 'foo :slot1 3)))
(setf (htref ght i1) i1)
(setf (htref ght i2) i2)
(and (= (cnt ght) 2)
(eq (htref ght i1) i1)
(eq (htref ght i2) i2)))
t)
(deftest htref.test-3 ; (not (eqv i1 i2)), (/= (hash i1) (hash i2))
(let ((ght (make-generalized-hash-table +foo-intention+))
(i1 (make-instance 'foo :slot1 2))
(i2 (make-instance 'foo :slot1 4)))
(setf (htref ght i1) i1)
(setf (htref ght i2) i2)
(and (= (cnt ght) 2)
(eq (htref ght i1) i1)
(eq (htref ght i2) i2)))
t)
(deftest htref.test-4
(let ((ght (make-generalized-hash-table +foo-intention+))
(i1 (make-instance 'foo :slot1 1 :slot2 2))
(i2 (make-instance 'foo :slot1 1 :slot2 3)))
(setf (htref ght i1) i1)
(and (= (cnt ght) 1) (eq (htref ght i2) i1)))
t)
(deftest htref.test-5
(let ((ght (make-generalized-hash-table +foo-intention+))
(i1 (make-instance 'foo :slot1 1 :slot2 2))
(i2 (make-instance 'foo :slot1 1 :slot2 3)))
(setf (htref ght i1) i1)
(multiple-value-bind (v vp)
(htref ght i2)
(declare (ignore v))
(values (cnt ght) vp)))
1 t)
(deftest htref.test-6
(let ((ght (make-generalized-hash-table +foo-intention+))
(i1 (make-instance 'foo :slot1 2))
(i2 (make-instance 'foo :slot1 3)))
(setf (htref ght i1) i1)
(htref ght i2))
nil nil)
(deftest htref.test-7
(let ((ght (make-generalized-hash-table +foo-intention+))
(i1 (make-instance 'foo :slot1 2))
(i2 (make-instance 'foo :slot1 3)))
(and (eq (setf (htref ght i1) i2) i2) (= (cnt ght) 1)))
t)
(deftest htadd.test-1
(let ((ght (make-generalized-hash-table +foo-intention+))
(i1 (make-instance 'foo :slot1 2)))
(htadd ght i1)
(htref ght i1))
t t)
(deftest htadd.test-2
(let ((ght (make-generalized-hash-table +foo-intention+))
(i1 (make-instance 'foo :slot1 2)))
(htref ght i1))
nil nil)
(deftest htadd.test-3
(let ((ght (make-generalized-hash-table +foo-intention+))
(i1 (make-instance 'foo :slot1 2))
(i2 (make-instance 'foo :slot1 3)))
(htadd ght i1)
(htref ght i2))
nil nil)
(deftest htpresent.test-1
(let ((ght (make-generalized-hash-table +foo-intention+))
(i1 (make-instance 'foo :slot1 2)))
(htadd ght i1)
(and (= (cnt ght) 1) (htpresent ght i1)))
t)
(deftest htpresent.test-2
(let ((ght (make-generalized-hash-table +foo-intention+))
(i1 (make-instance 'foo :slot1 2)))
(and (= (cnt ght) 0) (htpresent ght i1)))
nil)
(deftest htremove.test-1
(let ((ght (make-generalized-hash-table +foo-intention+))
(i1 (make-instance 'foo :slot1 2)))
(values
(htremove ght i1)
(= (cnt ght) 0)
(htref ght i1)))
nil t nil)
(deftest htremove.test-2
(let ((ght (make-generalized-hash-table +foo-intention+))
(i1 (make-instance 'foo :slot1 2)))
(htadd ght i1)
(values
(htremove ght i1)
(= (cnt ght) 0)
(htref ght i1)))
t t nil)
(deftest with-ht.test-1
(let ((ght (make-generalized-hash-table +foo-intention+))
(i1 (make-instance 'foo :slot1 2))
(i2 (make-instance 'foo :slot1 3))
l)
(htadd ght i1)
(htadd ght i2)
(with-ht (k v) ght
(push (cons k v) l))
(and (= (length l) 2)
(equal (assoc i1 l) (cons i1 t))
(equal (assoc i2 l) (cons i2 t))))
t)
(deftest with-ht.test-2
(let ((ght (make-generalized-hash-table +foo-intention+))
l)
(with-ht (k v) ght
(push (cons k v) l))
l)
nil)
(deftest with-ht-collect.test-1
(let ((ght (make-generalized-hash-table +foo-intention+))
(i1 (make-instance 'foo :slot1 2))
(i2 (make-instance 'foo :slot1 3))
l)
(htadd ght i1)
(htadd ght i2)
(let ((l (with-ht-collect (k v) ght (cons k v))))
(and (= (length l) 2)
(equal (assoc i1 l) (cons i1 t))
(equal (assoc i2 l) (cons i2 t)))))
t)
(deftest with-ht-collect.test-2
(let ((ght (make-generalized-hash-table +foo-intention+)))
(with-ht-collect (k v) ght (cons k v)))
nil)