random-intern.lsp 1.75 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Contains: Code to randomly intern and unintern random strings
;;;;           in a package.  Exercises package and hash table routines

(in-package :cl-test)

(defconstant +max-len-random-symbol+ 63)

(defun make-random-symbol (package)
  (declare (optimize (speed 3) (safety 3)))
  (loop
   (let* ((len (random (1+ +max-len-random-symbol+)))
sds's avatar
sds committed
14
          (str (make-string len)))
15 16 17 18
     (declare (type (integer 0 #.+max-len-random-symbol+) len))
     (loop
      for i from 0 to (1- len) do
      (setf (schar str i)
sds's avatar
sds committed
19 20
            (schar +base-chars+
                   (random +num-base-chars+))))
21 22 23 24
     (multiple-value-bind
      (symbol status)
      (intern (copy-seq str) package)
      (unless (equal str (symbol-name symbol))
sds's avatar
sds committed
25
              (error "Intern gave bad symbol: ~A, ~A~%" str symbol))
26 27 28 29 30 31 32 33 34
      (unless status (return symbol))))))

(defun queue-insert (q x)
  (declare (type cons q))
  (push x (cdr q)))

(defun queue-remove (q)
  (declare (type cons q))
  (when (null (car q))
sds's avatar
sds committed
35 36 37 38
        (when (null (cdr q))
              (error "Attempty to remove from empty queue.~%"))
        (setf (car q) (nreverse (cdr q)))
        (setf (cdr q) nil))
39 40 41 42 43 44 45 46 47
  (pop (car q)))

(defun queue-empty (q)
  (and (null (car q))
       (null (cdr q))))

(defun random-intern (n)
  (declare (fixnum n))
  (let ((q (list nil))
sds's avatar
sds committed
48
        (xp (defpackage "X" (:use))))
49 50 51 52
    (declare (type cons q))
    (loop
     for i from 1 to n do
     (if (and
sds's avatar
sds committed
53 54 55
          (= (random 2) 0)
          (not (queue-empty q)))
         (unintern (queue-remove q) xp)
56 57 58 59 60 61 62 63 64
       (queue-insert q (make-random-symbol xp))))))

(defun fill-intern (n)
  (declare (fixnum n))
  (let ((xp (defpackage "X" (:use))))
    (loop
     for i from 1 to n do
     (make-random-symbol xp))))

sds's avatar
sds committed
65

66 67 68 69 70 71 72