source: trunk/source/tests/ansi-tests/random-intern.lsp @ 8991

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

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

File size: 1.7 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Contains: Code to randomly intern and unintern random strings
4;;;;           in a package.  Exercises package and hash table routines
5
6(in-package :cl-test)
7
8(defconstant +max-len-random-symbol+ 63)
9
10(defun make-random-symbol (package)
11  (declare (optimize (speed 3) (safety 3)))
12  (loop
13   (let* ((len (random (1+ +max-len-random-symbol+)))
14          (str (make-string len)))
15     (declare (type (integer 0 #.+max-len-random-symbol+) len))
16     (loop
17      for i from 0 to (1- len) do
18      (setf (schar str i)
19            (schar +base-chars+
20                   (random +num-base-chars+))))
21     (multiple-value-bind
22      (symbol status)
23      (intern (copy-seq str) package)
24      (unless (equal str (symbol-name symbol))
25              (error "Intern gave bad symbol: ~A, ~A~%" str symbol))
26      (unless status (return symbol))))))
27
28(defun queue-insert (q x)
29  (declare (type cons q))
30  (push x (cdr q)))
31
32(defun queue-remove (q)
33  (declare (type cons q))
34  (when (null (car q))
35        (when (null (cdr q))
36              (error "Attempty to remove from empty queue.~%"))
37        (setf (car q) (nreverse (cdr q)))
38        (setf (cdr q) nil))
39  (pop (car q)))
40
41(defun queue-empty (q)
42  (and (null (car q))
43       (null (cdr q))))
44
45(defun random-intern (n)
46  (declare (fixnum n))
47  (let ((q (list nil))
48        (xp (defpackage "X" (:use))))
49    (declare (type cons q))
50    (loop
51     for i from 1 to n do
52     (if (and
53          (= (random 2) 0)
54          (not (queue-empty q)))
55         (unintern (queue-remove q) xp)
56       (queue-insert q (make-random-symbol xp))))))
57
58(defun fill-intern (n)
59  (declare (fixnum n))
60  (let ((xp (defpackage "X" (:use))))
61    (loop
62     for i from 1 to n do
63     (make-random-symbol xp))))
64
65         
66
67
68
69
70
71
72
Note: See TracBrowser for help on using the repository browser.