source: trunk/source/tests/ansi-tests/hash-table-aux.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 2.7 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Oct  4 09:24:24 2003
4;;;; Contains: Aux. functions for testing hash tables
5
6(in-package :cl-test)
7
8(eval-when (:load-toplevel :compile-toplevel :execute)
9  (compile-and-load "random-aux.lsp"))
10
11(defparameter *hash-table-test-iters* 1000)
12
13(defun test-hash-table-1 (&rest args)
14  (let ((table (apply #'make-hash-table args))
15        (test (or (getf args :test) 'eql)))
16    (assert (member test '(eq eql equal equalp)))
17    (assert (hash-table-p table))
18    (assert (typep table 'hash-table))
19    ;; Build a hash table using the arguments in ARGS.
20    ;; Perform *hash-table-test-iters* iterations of
21    ;; random hash table operations
22    (let* ((universe-vec (coerce *universe* 'vector))
23           ;; (universe-size (length universe-vec))
24           (mapping nil)
25           (count 0))
26
27      (loop
28       for i from 0 below *hash-table-test-iters*
29       do (assert (eql (hash-table-count table) count))
30       do (assert (let ((size (hash-table-size table)))
31                    (and (integerp size) (>= size 0))))
32       do
33       (flet ((%remove-pair
34               (rpair)
35               (decf count)
36               (let ((key (car rpair))
37                     (expected-value (cdr rpair)))
38                 (multiple-value-bind (value present-p)
39                     (gethash key table)
40                   (assert present-p)
41                   (assert (eql expected-value value))
42                   (setf mapping
43                         (remove rpair mapping :count 1 :test 'eq)))
44                 (assert (remhash key table))
45                 (multiple-value-bind (value present-p)
46                     (gethash key table)
47                   (assert (not present-p))
48                   (assert (null value))
49                   ))))
50                           
51         (rcase
52          (1 ;; Insert
53           (let* ((new-elem (random-from-seq universe-vec))
54                  (pair (assoc new-elem mapping :test test)))
55             (cond
56              (pair
57               (multiple-value-bind
58                   (value present-p)
59                   (gethash new-elem table)
60                 (assert present-p)
61                 (assert (eql (cdr pair) value))
62                 (setf (cdr pair) i
63                       (gethash new-elem table) i)))
64              (t
65               (assert
66                (equal (multiple-value-list (gethash new-elem table))
67                       '(nil nil)))
68               (incf count)
69               (push (cons new-elem i) mapping)
70               (setf (gethash new-elem table) i)))))
71          (1 ;; Delete element in the set
72           (when mapping
73             (%remove-pair (random-from-seq mapping))))
74          (1 ;; Delete random element from universe
75           (let* ((key (random-from-seq universe-vec))
76                  (pair (assoc key mapping :test test)))
77             (cond
78              (pair (%remove-pair pair))
79              (t
80               ;; Not present -- check that this is true
81               (assert (equal (multiple-value-list (gethash key table))
82                              '(nil nil)))
83               (assert (not (remhash key table)))
84               (assert (equal (multiple-value-list (gethash key table))
85                              '(nil nil)))))
86             ))
87          ))))))
88
89             
90                 
91           
92           
93               
Note: See TracBrowser for help on using the repository browser.