;-*- 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 +base-chars+ #.(concatenate 'string "abcdefghijklmnopqrstuvwxyz" "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "0123456789" "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|")) (defconstant +num-base-chars+ (length +base-chars+)) (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+))) (str (make-string len))) (declare (type (integer 0 #.+max-len-random-symbol+) len)) (loop for i from 0 to (1- len) do (setf (schar str i) (schar +base-chars+ (random +num-base-chars+)))) (multiple-value-bind (symbol status) (intern (copy-seq str) package) (unless (equal str (symbol-name symbol)) (error "Intern gave bad symbol: ~A, ~A~%" str symbol)) (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)) (when (null (cdr q)) (error "Attempty to remove from empty queue.~%")) (setf (car q) (nreverse (cdr q))) (setf (cdr q) nil)) (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)) (xp (defpackage "X" (:use)))) (declare (type cons q)) (loop for i from 1 to n do (if (and (= (random 2) 0) (not (queue-empty q))) (unintern (queue-remove q) xp) (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))))