[0f9724]: src / cllib / tests.lisp  Maximize  Restore  History

Download this file

537 lines (509 with data), 24.1 kB

  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
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
;;; Regression Testing
;;;
;;; Copyright (C) 1999-2008, 2010, 2013 by Sam Steingold
;;; This is Free Software, covered by the GNU GPL (v2+)
;;; See http://www.gnu.org/copyleft/gpl.html
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :cllib-base (translate-logical-pathname "clocc:src;cllib;base"))
;; `autoload-generate'
(require :cllib-autoload (translate-logical-pathname "cllib:autoload"))
;; `mesg'
(require :cllib-log (translate-logical-pathname "cllib:log"))
;; `with-collect'
(require :cllib-simple (translate-logical-pathname "cllib:simple"))
;; these files will be tested:
(require :cllib-list (translate-logical-pathname "cllib:list"))
(require :cllib-string (translate-logical-pathname "cllib:string"))
(require :cllib-matrix (translate-logical-pathname "cllib:matrix"))
(require :cllib-math (translate-logical-pathname "cllib:math"))
(require :cllib-date (translate-logical-pathname "cllib:date"))
(require :cllib-url (translate-logical-pathname "cllib:url"))
(require :cllib-rpm (translate-logical-pathname "cllib:rpm"))
(require :cllib-elisp (translate-logical-pathname "cllib:elisp"))
(require :cllib-xml (translate-logical-pathname "cllib:xml"))
(require :cllib-iter (translate-logical-pathname "cllib:iter"))
(require :cllib-munkres (translate-logical-pathname "cllib:munkres"))
(require :cllib-lift (translate-logical-pathname "cllib:lift"))
(require :cllib-bayes (translate-logical-pathname "cllib:bayes"))
(require :cllib-csv (translate-logical-pathname "cllib:csv"))
(require :cllib-cvs (translate-logical-pathname "cllib:cvs")))
(in-package :cllib)
(export '(test-all))
(defparameter *network-dependent-tests* '(test-cvs))
(defmacro deftest (name (&rest extra-keys) &body body)
`(defun ,name (&key (out *standard-output*) ,@extra-keys)
(mesg :test out " ** ~s...~%" ',name)
(let ((num-err 0))
,@body
(mesg :test out " ** ~s: ~:d error~:p~2%" ',name num-err)
num-err)))
(deftest test-string ()
(flet ((check (fun seq from to keys cmp res r1)
(mesg :test out " * ~s ~s ~s ~s~{ ~s~} -> ~s~%"
fun seq from to keys res)
(unless (funcall cmp res r1)
(incf num-err)
(warn " ### ~S FAILED: ~s ~s ~s~{ ~s~}~% ->~10t~s~% /=~10t~s~%"
fun seq from to keys r1 res))))
(flet ((ts (res seq from to &rest keys)
(check 'substitute-subseq seq from to keys #'string= res
(apply #'substitute-subseq seq from to keys))))
(ts "ab123efghcda" "abcdefghcda" "cd" "123" :start 1 :end 6)
(ts "ab123efgh123a" "abcdefghcda" "cd" "123" :start 1)
(ts "ab123efghcda" "abcdefghcda" "cd" "123" :end 6)
(ts "ab123efgh123a" "abcdefghcda" "cd" "123")
(ts "abcdefghcda" "abcdefghcda" "cd" "123" :start 5 :end 6))
(flet ((ts (res seq from to)
(check 'remove-subseq seq from to () #'equalp res
(remove-subseq seq from to))))
(ts '(1 2 3 7 8 9) '(1 2 3 4 5 6 7 8 9) 3 6)
(ts #(1 2 3 7 8 9) #(1 2 3 4 5 6 7 8 9) 3 6)
(ts (mk-arr '(unsigned-byte 8) '(1 2 3 7 8 9))
(mk-arr '(unsigned-byte 8) '(1 2 3 4 5 6 7 8 9)) 3 6))
(let ((s '(1 2 3 0 4 5 6 0 7 8 9)))
(flet ((ts (res &key (start 0) end)
(check 'split-seq s start end () #'equalp res
(split-seq s #'zerop :start start :end end))))
(ts '((1 2 3) (4 5 6) (7 8 9)))
(ts '((1 2 3) (4 5 6)) :end 7))
(dotimes (end (length s))
(dotimes (start end)
(check 'split-seq s start end () #'equalp
(split-seq s #'zerop :start start :end end)
(split-seq (subseq s start end) #'zerop)))))))
(deftest test-math ()
(labels ((perm= (li1 la1 li2 la2)
(when (set-difference li1 li2 :test #'equalp)
(incf num-err)
(warn "permutation lists differ:
** ~s **~%~s~% ** ~s **~%~s~% ** difference **~%~s~%"
la1 li1 la2 li2
(set-difference li1 li2 :test #'equalp))))
(perm-eq (li1 la1 li2 la2)
(perm= li1 la1 li2 la2)
(perm= li2 la2 li1 la1))
(ts-perm (nn)
(mesg :test out " * permutations of ~d element~:p~%" nn)
(let* ((ve (make-vector-indexed nn))
(le (permutations-list ve :method :lex))
(sh (permutations-list ve :method :shuffle))
(sw (permutations-list ve :method :swap)))
(perm-eq le :lex sh :shuffle)
(perm-eq le :lex sw :swap))))
(ts-perm 3)
(ts-perm 4)
(ts-perm 5))
(flet ((vec-find (vec x)
(binary-search 0 (1- (length vec))
(lambda (i) (<= (aref vec i) x))
:fmid #'mid-integer)))
(dolist (v '((#(1 2 3 4) 3 (2 3 T NIL))
(#(1 2 3 4 5) 30 (0 4 T T))))
(destructuring-bind (vec x vals) v
(mesg :test out " * search ~S in ~S~%" x vec)
(let ((v (multiple-value-list (vec-find vec x))))
(unless (equal vals v)
(incf num-err)
(warn "binary-search values differ:~% ** ~S~% ** ~S" vals v)))))))
(deftest test-date ()
(loop :repeat 10 :do
(let* ((n0 (random 100000)) (dd (days2date n0)) (n1 (date2days dd)))
(mesg :test out "~6:d --> ~a --> ~6:d~%" n0 dd n1)
(unless (= n0 n1)
(incf num-err)
(warn " ### FAILED: ~6:d --> ~a --> ~6:d~2%" n0 dd n1))))
(flet ((ts (nn st)
(mesg :test out "~30s --> ~d --> ~a~%"
st nn (dttm->string nn :format :short))
(unless (= nn (string->dttm st))
(incf num-err)
(warn " ### FAILED: ~s --> ~d, not ~d~2%"
st (string->dttm st) nn))))
(ts 3221942400 "2002-02-06")
(ts 3222004920 "2002-02-06T17:22")
(ts 3222004978 "2002-02-06T17:22:58")
(ts 3222004979 "2002-02-06T17:22:58.9")
(ts 3222004978 "2002-02-06T12:22:58.12Z-0500")
(ts 3222004978 "2002-02-06T22:22:58Z+0500")
(ts 3222004978 "06 Feb 2002 18:22:58 +0100")
(ts 3222004978 "06 Feb 2002 16:22:58 -0100")
(ts 3126878578 "1999/02/01 17:22:58")
(ts 3126896578 "Mon Feb 1 17:22:58 1999 EST")
(ts 3126878578 "Feb 1 Mon 17:22:58 1999 GMT")
(ts 3126878578 "Feb 1 Mon 17:22:58 1999")
(ts 3126878578 "1999 Feb 1 Mon 17:22:58")
(ts 3126896578 "1999-02-01 Mon 17:22:58 EST")
(ts 3126878578 "1999-02-01 17:22:58")
(ts 3126878578 "1999-02-01 17:22:58 GMT")
(ts 3126878578 "1999 Feb 1 17:22:58")
(ts 3126896578 "Feb 1 17:22:58 1999 EST")))
(deftest test-rpm ()
(flet ((av (v0 v1)
(mesg :test out " ~a < ~a~%" v0 v1)
(unless (version< v0 v1)
(incf num-err)
(warn " ### FAILED: ~a < ~a~2%" v0 v1))))
(av "3.3.2" "3.3.11")
(av "4.2b980516" "4.2")
(av "3.3.2pl2" "3.3.3")
(av "1.1b" "1.1.1")
(av "3.0" "3.0.3")))
(deftest test-url ()
(flet ((ts (st url pr)
(mesg :test out " * ~s~% - ~s~% - ~s~%" st url pr)
(let ((uu (url st)))
(unless (equalp uu url)
(incf num-err)
(warn " ### PARSING FAILED:~%~s~% ###~%~s~%" uu url))
(unless (string= (princ-to-string uu) pr)
(incf num-err)
(warn " ### PRINTING FAILED:~%~5t~s -->~%~5t~s~% not~5t~s~2%"
st uu st)))))
(ts "news://nntp.gnu.org/gnu.discuss"
(make-url :prot :news :user "" :pass "" :host "nntp.gnu.org" :port 0
:path "/gnu.discuss")
"news://nntp.gnu.org/gnu.discuss")
(ts "news:gnu.discuss"
(make-url :prot :news :user "" :pass "" :host "" :port 0
:path "gnu.discuss")
"news:gnu.discuss")
(ts "ftp://user#password@host.domain/path/to/file"
(make-url :prot :ftp :user "user" :pass "password" :host
"host.domain" :port 0 :path "/path/to/file")
"ftp://user#password@host.domain/path/to/file")
(ts "mailto:sds@gnu.org"
(make-url :prot :mailto :user "sds" :host "gnu.org")
"mailto:sds@gnu.org")
(ts "www.gnu.org/gpl.html"
(make-url :prot :http :user "" :pass "" :host "www.gnu.org" :port 0
:path "/gpl.html")
"http://www.gnu.org/gpl.html")))
(deftest test-elisp ()
(let ((*readtable* +elisp-readtable+)
(*package* (find-package "CLLIB")))
(flet ((ts (str obj)
(mesg :test out " * ~s --> ~s~%" str obj)
(handler-case
(let ((o1 (read-from-string str)))
(unless (equalp o1 obj)
(warn " ### READING FAILED: ~s != ~s~%" o1 obj)
(incf num-err)))
(error (err)
(warn " ### READ ERROR: ~a~%" err)
(incf num-err)))))
(ts "[a ?\\C-a ?c #\\z]" #(a (:control #\a) #\c #\z))
(ts "[?Z ?\\^M ?\\n]" #(#\Z (:control #\M) #\Newline)))))
(deftest test-xml ()
(flet ((ts (path num)
(mesg :test out " => <~a> ~:d object~:p expected~%" path num)
(handler-case
(let ((len (length (xml-read-from-file path :reset-ent nil))))
(if (= num len)
(mesg :test out " * correct length: ~:d~%" len)
(mesg :test out
" #~d# wrong length: ~:d (should be ~:d)~%"
(incf num-err) len num)))
(error (err)
(warn " ### ERROR: ~a~%" err)
(incf num-err)))))
(mesg :test out " ** ~s...~%" 'test-xml)
(ts *xml-ent-file* 284)
(ts (translate-logical-pathname "clocc:etc;cl-ent.xml") 1641)))
(deftest test-cvs ()
(flet ((ts (path)
(mesg :test out " * ~a~%" path)
(handler-case (when (cvs-stat-log path) 1)
(error (err)
(warn " ### ERROR: ~a~%" err)
(incf num-err)))))
(mesg :test out " ** ~s...~%" 'test-cvs)
(ts (namestring (translate-logical-pathname "clocc:")))))
(deftest test-matrix-inverse ((num-test 10) (dim 10) (max 10))
(loop :repeat num-test :with det :with i1 = (make-array (list dim dim))
:for err = 0
:for mx = (random-matrix dim dim max) :for m1 = (array-copy mx) :do
(handler-case (setq det (matrix-inverse m1))
(division-by-zero (c)
(mesg :test out " ** degenerate matrix~%~S~%"
(first (arithmetic-error-operands c)))))
(mesg :test out " ** log det = ~S~%" det)
(matrix-multiply mx m1 i1)
(dotimes (i dim)
(dotimes (j dim)
(let ((e (abs (- (if (= i j) 1 0) (aref i1 i j)))))
(when (< err e)
(setq err e)))))
(if (> err 0.001)
(warn " ###~:D### ERROR: ~F~%~S~%==>~%~S" (incf num-err) err mx m1)
(mesg :test out " err = ~S~%" err))))
(deftest test-matrix ()
(setq num-err (test-matrix-inverse :out out))
(flet ((ts (name actual expected)
(mesg :test out " ** ~A: ~S~%" name expected)
(unless (equalp actual expected)
(warn "###~:D### ERROR: ~S is not ~S" (incf num-err)
actual expected))))
(ts "slice" (array-slice #2A((1 2) (3 4)) '(NIL 1)) #(2 4))
(ts "slice" (array-slice #2A((1 2) (3 4)) '(0 0)) #0A1)
(ts "slice" (array-slice #2A((1 2) (3 4)) '(0 1)) #0A2)
(ts "marginal" (array-marginal #2A((1 2) (3 4)) '(0)) #(3 7))
(ts "marginal" (array-marginal #2A((1 2) (3 4)) '(1)) #(4 6))
(let ((arr (make-array '(3 4 5 6)))
(mx #2A((1980 1995 2010 2025 2040 2055)
(2430 2445 2460 2475 2490 2505)
(2880 2895 2910 2925 2940 2955)
(3330 3345 3360 3375 3390 3405))))
(dotimes (i (array-total-size arr)) (setf (row-major-aref arr i) i))
(ts "slice" (array-slice arr '(nil 1 nil 5))
#2A((35 41 47 53 59) (155 161 167 173 179) (275 281 287 293 299)))
(ts "slice" (aref (array-slice arr '(1 2 3 4))) (aref arr 1 2 3 4))
(ts "marginal" (array-marginal arr '(1 3)) mx)
(ts "marginal" (array-marginal arr '(3 1)) (matrix-transpose mx))
(ts "marginal" (aref (array-marginal arr nil))
(let ((sz (array-total-size arr))) (/ (* sz (1- sz)) 2))))))
(deftest test-munkres ()
(let ((assignment-list
'((#2A((69 64 23 53 94 85 16 7 77)
(12 6 22 43 73 17 15 39 91)
(74 38 43 86 40 89 22 69 81)
(33 83 10 34 30 20 94 100 58)
(15 14 60 3 97 70 8 8 0)
(53 23 23 32 26 32 37 3 13)
(73 54 60 93 98 53 75 76 94)
(44 51 26 73 14 66 71 73 79)
(77 88 69 86 94 49 50 93 68)
(19 43 7 5 22 42 29 55 62))
141 #(7 1 6 2 0 8 NIL 4 5 3) #(4 1 3 9 7 8 2 0 5))
(#2A((150 69 64 23 53 94 85 16 7 77)
(150 12 6 22 43 73 17 15 39 91)
(150 74 38 43 86 40 89 22 69 81)
(150 33 83 10 34 30 20 94 100 58)
(150 15 14 60 3 97 70 8 8 0)
(150 53 23 23 32 26 32 37 3 13)
(150 73 54 60 93 98 53 75 76 94)
(150 44 51 26 73 14 66 71 73 79)
(150 77 88 69 86 94 49 50 93 68)
(150 19 43 7 5 22 42 29 55 62))
291 #(8 2 7 3 1 9 0 5 6 4) #(6 4 1 3 9 7 8 2 0 5))
(#2A((150 69 64 23 53 94 85 16 7 77 12)
(150 12 6 22 43 73 17 15 39 91 32)
(150 74 38 43 86 40 89 22 69 81 11)
(150 33 83 10 34 30 20 94 100 58 102)
(150 15 14 60 3 97 70 8 8 0 99)
(150 53 23 23 32 26 32 37 3 13 5)
(150 73 54 60 93 98 53 75 76 94 17)
(150 44 51 26 73 14 66 71 73 79 33)
(150 77 88 69 86 94 49 50 93 68 6)
(150 19 43 7 5 22 42 29 55 62 188))
151 #(8 2 7 3 1 9 6 5 10 4) #(NIL 4 1 3 9 7 6 2 0 5 8)))))
(dolist (li assignment-list)
(mesg :test out " ** ~S: ~S~2%"
'test-munkres (car li))
(unless (equalp (multiple-value-list (funcall #'assignment (car li)))
(cdr li))
(mesg :test out " ** ~S: ERROR! Expected answer: ~S~2%"
'test-munkres (cdr li))
(incf num-err)))))
(deftest test-base64 ()
(flet ((test (vec str)
(mesg :test out "~S: ~S<->~S~%" 'test-base64 vec str)
(unless (equal str (base64-encode vec))
(mesg :test out " ** ~S: ERROR: ~S~%"
'base64-encode (base64-encode vec))
(incf num-err))
(unless (equalp vec (base64-decode str))
(mesg :test out " ** ~S: ERROR: ~S~%"
'base64-decode (base64-decode str))
(incf num-err))))
(test #(97) "YQ==")
(test #(97 98) "YWI=")
(test #(97 98 99) "YWJj")
(test #(108 105 115 112 32 115 116 114 105 110 103) "bGlzcCBzdHJpbmc=")
(test #(108 105 115 112 32 115 116 114 105 110 103 115)
"bGlzcCBzdHJpbmdz")
(test #(99 108 105 115 112 32 115 116 114 105 110 103 115)
"Y2xpc3Agc3RyaW5ncw==")
(mesg :test out "~S (random)" 'test-base64)
(loop :with str :repeat 1000 :for vec = (make-array (random 300))
:do (mesg :test out ".")
(loop :for i :from 0 :below (length vec)
:do (setf (aref vec i) (random 256)))
(setq str (base64-encode vec))
(unless (equalp vec (base64-decode str))
(mesg :test out "<~S -> ~S -> ~S>" vec str (base64-decode str))
(incf num-err)))))
(deftest test-iter ()
(let (actual expected)
(setq expected '(#(0 0) #(0 1) #(0 2) #(1 0) #(1 1) #(1 2))
actual (with-collect (c)
(do-iter (z (mk-arr 'fixnum '(2 3)))
(c (copy-seq z)))))
(unless (equalp expected actual)
(mesg :test out "~& * error in ~S:~% actual: ~S~% expected: ~S~%"
'do-iter actual expected)
(incf num-err))
(setq expected '((0 0) (0 1) (0 2) (1 0) (1 1) (1 2))
actual (with-collect (c)
(do-iter-ls (z (reverse '(2 3)))
(c (copy-seq z)))))
(unless (equalp expected actual)
(mesg :test out "~& * error in ~S:~% actual: ~S~% expected: ~S~%"
'do-iter-ls actual expected)
(incf num-err))))
(deftest test-list ()
(let* ((l (loop for i from 0 to 20 collect i)) (l1 (copy-seq l)))
(mesg :test out "~S~%" 'test-batch-map)
(let ((r (batch-map l 5 #'length)) (a '(5 5 5 5 1)))
(unless (equal r a)
(mesg :test out " ** ~S: ERROR : ~S != ~S~%" 'test-batch-map r a)
(incf num-err))
(unless (equal l l1)
(mesg :test out " ** ~S: ERROR : ~S != ~S~%" 'test-batch-map l l1)
(incf num-err))))
(flet ((test-jumps (list func ret)
(mesg :test out "~S: ~S -> ~S~%" 'test-jumps list ret)
(let ((z (jumps list :pred func)))
(unless (equal z ret)
(mesg :test out " ** ~S: ERROR : ~S~%" 'test-jumps z)
(incf num-err)))
(let ((z (count-jumps list :pred func)))
(unless (= z (length ret))
(mesg :test out " ** ~S: ERROR : ~S~%" 'test-jumps z)
(incf num-err)))))
(test-jumps '(1 2 10 11) (lambda (a b) (< (* 3 a) b)) '((2 . 10)))
(test-jumps '(12 10 11) #'> '((12 . 10))))
(flet ((test-freqs (list ret)
(mesg :test out "~S: ~S -> ~S~%" 'test-freqs list ret)
(let ((z (freqs list)))
(unless (equal z ret)
(mesg :test out " ** ~S: ERROR : ~S~%" 'test-freqs z)
(incf num-err)))))
(test-freqs '(1 2 3) '((3 . 1) (2 . 1) (1 . 1)))
(test-freqs '(1 1 2 2 2) '((2 . 3) (1 . 2)))))
(deftest test-lift ()
(let* ((lq (lift:lift-quality #(1 1 0 0 1 0 0 1 0 0) :out out
:true-value #'plusp))
(q (lift:lq-lift-quality lq)))
(mesg :test out " ** lift-quality=~S~%" q)
(unless (= 0.5 q) (incf num-err))))
(deftest test-bayes ()
(labels ((digits (num digits)
(loop :for i :below digits
:collect (cons i (ldb (byte 1 i) num))))
(make-division-model (divisor max)
;; for numbers 0..(max-1) predict the remainder
;; mod divisor from binary digits
(loop :with b =
(nb-model-make
'test (coerce (loop :for i :below divisor :collect i) 'vector))
:with nd = (1- (integer-length (1- max)))
:for n :below max :do
(nb-add-observation b (mod n divisor) (digits n nd))
:finally (return b))))
(let* ((m2 (make-division-model 2 16))
(max 32) (nd (integer-length (1- max))))
(loop :for n :below max :for d = (digits n nd)
:for lo = (nb-predict-classes m2 d) :do
(mesg :test out " ** bayes(~:D)=~S~%" n (logodds-to-prob lo))
(unless (= (best-class lo) (mod n 2))
(incf num-err))))
(multiple-value-bind (model proficiency)
(train-test (loop :for i :from 32 :to 63 :collect
(cons (evenp i) (digits i 6)))
:model-name "evenp-5")
(let ((*nb-describe-feature-grouper* #'car))
(describe model out))
(unless (= 2 (hash-table-count (nb-model-features model))) (incf num-err))
(unless (= 1 proficiency) (incf num-err)))
(multiple-value-bind (model proficiency)
(train-test (loop :for i :from 64 :to 127 :for digits = (digits i 7)
:collect (list* (mod i 4)
(cons '|01|
(+ (cdr (assoc 0 digits))
(ash (cdr (assoc 1 digits)) 1)))
digits))
:model-name "mod4-6")
(let ((*nb-describe-feature-grouper* #'car))
(describe model out))
(unless (= 8 (hash-table-count (nb-model-features model))) (incf num-err))
(unless (= 1 proficiency) (incf num-err))))
(flet ((check-logodds+ (a b c)
(let ((res (logodds+ a b)))
(mesg :test out " ** logodds+(~S ~S)=~S~:[ (should be ~S)~;~]~%"
a b res (eql res c) c)
(unless (eql res c) (incf num-err)))))
(check-logodds+ 'nan 'nan 'nan)
(check-logodds+ '+infinity 'nan 'nan)
(check-logodds+ '-infinity 'nan 'nan)
(check-logodds+ 0 'nan 'nan)
(check-logodds+ 'nan '+infinity 'nan)
(check-logodds+ '+infinity '+infinity '+infinity)
(check-logodds+ '-infinity '+infinity 'nan)
(check-logodds+ 0 '+infinity '+infinity)
(check-logodds+ 'nan '-infinity 'nan)
(check-logodds+ '+infinity '-infinity 'nan)
(check-logodds+ '-infinity '-infinity '-infinity)
(check-logodds+ 0 '-infinity '-infinity)
(check-logodds+ 'nan 0 'nan)
(check-logodds+ '+infinity 0 '+infinity)
(check-logodds+ '-infinity 0 '-infinity)
(check-logodds+ 1 0 1)
(check-logodds+ 2 -1 1)
(check-logodds+ 2 2 4)))
(deftest test-csv ()
(flet ((check-csv (s v)
(let ((v1 (csv-parse-string s)))
(mesg :test out " ** csv(~S)=~S~:[ (should be ~S)~;~]~%"
s v1 (equalp v v1) v)
(unless (equalp v v1) (incf num-err)))))
(check-csv "foo,bar,zot,quux" #("foo" "bar" "zot" "quux"))
(check-csv "foo,\"bar,zot\",quux" #("foo" "bar,zot" "quux"))
(check-csv "foo,\"bar\\\",zot\",quux" #("foo" "bar\",zot" "quux"))
(check-csv "foo,,\"\",quux" #("foo" NIL NIL "quux"))))
(defun test-all (&key (out *standard-output*)
(what '(string math date rpm url elisp xml munkres cvs base64
iter matrix list lift bayes csv))
(disable-network-dependent-tests t))
(mesg :test out "~& *** ~s: regression testing...~%" 'test-all)
(let* ((num-test 0)
(num-err (reduce #'+ what :key
(lambda (w)
(let ((sy (intern (concatenate 'string "TEST-"
(string-upcase w))
"CLLIB")))
(if (or (not (fboundp sy))
(and disable-network-dependent-tests
(member
sy *network-dependent-tests*)))
0 (progn (incf num-test)
(funcall sy :out out))))))))
(mesg :test out " *** ~s: ~:d error~:p in ~:d test~:p~2%"
'test-all num-err num-test)))
(defun post-compile-hook (all-files compiled-files)
"Test recompiled files and regenerate autoloads."
(when (member "tests" compiled-files :test #'string= :key #'pathname-name)
(test-all :what (mapcar #'pathname-name compiled-files)))
(let ((auto (translate-logical-pathname "clocc:src;cllib;auto.lisp")))
(autoload-generate all-files auto)
(compile-file auto)))
#+asdf
(defun post-compile (op)
"Call `post-compile-hook'. The argument is the return value of ASDF:OERATE."
(let ((sys (asdf:find-system :cllib)) all compiled)
(with-hash-table-iterator (iter (asdf::operation-visited-nodes op))
(loop (multiple-value-bind (re kk vv) (iter)
(unless re (return))
(destructuring-bind (o . c) kk
(when (and (not (typep c 'asdf:module))
(eq sys (asdf:component-system c)))
(let ((path (asdf:component-pathname c)))
(push path all)
(when (and (cdr vv) (eq o 'asdf:compile-op))
(push path compiled))))))))
(when compiled
(post-compile-hook (delete-duplicates all :test #'equalp) compiled))))
#+mk-defsystem
(defun post-compile (tbc)
(when tbc (post-compile-hook (mk:files-in-system :cllib) tbc)))
(provide :cllib-tests)
;;; file tests.lisp ends here

Get latest updates about Open Source Projects, Conferences and News.

Sign up for the SourceForge newsletter:





No, thanks