← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to ansi-tests/random-intern.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
ansi-tests/random-intern.lsp
 
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