Skip to content
Snippets Groups Projects
Commit a5b00ef0 authored by pfdietz's avatar pfdietz
Browse files

Various tweaks, including a workaround for the Lispworks bug in make-strings's...

Various tweaks, including a workaround for the Lispworks bug in make-strings's :element-type default value
parent 98b334e7
No related branches found
No related tags found
No related merge requests found
...@@ -72,49 +72,40 @@ ...@@ -72,49 +72,40 @@
(declaim (special +standard-chars+ *cl-symbols-vector*)) (declaim (special +standard-chars+ *cl-symbols-vector*))
#|
(defun make-random-string (n)
(make-array n
:initial-contents
(loop repeat n collect
(random-from-seq +standard-chars+))
:element-type (random-from-seq
#(character standard-char base-char))))
|#
(defparameter *use-random-byte* t) (defparameter *use-random-byte* t)
(defparameter *random-readable* nil) (defparameter *random-readable* nil)
(defun make-random-string (n) (defun make-random-string (size-spec &key simple)
(let* (let*
((use-random-byte nil) ((size (if (eql size-spec '*) (random 30) size-spec))
(use-random-byte nil)
(etype 'character) (etype 'character)
(s (random-case (s (random-case
(progn (progn
(setf use-random-byte *use-random-byte*) (setf use-random-byte *use-random-byte*)
(make-string n)) (make-string size :element-type 'character))
(progn (progn
(setf use-random-byte *use-random-byte*) (setf use-random-byte *use-random-byte*)
(make-array n :element-type 'character (make-array size :element-type 'character
:initial-element #\a)) :initial-element #\a))
(make-array n :element-type (setf etype (if *random-readable* 'character 'standard-char)) (make-array size :element-type (setf etype (if *random-readable* 'character 'standard-char))
:adjustable (and (not *random-readable*) (rcase (3 nil) (1 t))) :adjustable (and (not simple) (not *random-readable*) (rcase (3 nil) (1 t)))
:fill-pointer (and (not *random-readable*) (rcase (3 nil) (1 (random (1+ n))))) :fill-pointer (and (not simple) (not *random-readable*) (rcase (3 nil) (1 (random (1+ size)))))
:initial-element #\a) :initial-element #\a)
(make-array n :element-type (setf etype (if *random-readable* 'character 'base-char)) (make-array size :element-type (setf etype (if *random-readable* 'character 'base-char))
:adjustable (and (not *random-readable*) (rcase (3 nil) (1 t))) :adjustable (and (not simple) (not *random-readable*) (rcase (3 nil) (1 t)))
:fill-pointer (and (not *random-readable*) (rcase (3 nil) (1 (random (1+ n))))) :fill-pointer (and (not simple) (not *random-readable*) (rcase (3 nil) (1 (random (1+ size)))))
:initial-element #\a)))) :initial-element #\a))))
(if (coin) (if (coin)
(dotimes (i n) (dotimes (i size)
(setf (char s i) (elt #(#\a #\b #\A #\B) (random 4)))) (setf (char s i) (elt #(#\a #\b #\A #\B) (random 4))))
(dotimes (i n) (dotimes (i size)
(setf (char s i) (setf (char s i)
(or (and use-random-byte (or (code-char (random (min char-code-limit (ash 1 16)))) (or (and use-random-byte (or (code-char (random (min char-code-limit (ash 1 16))))
(code-char (random 256)))) (code-char (random 256))))
(elt "abcdefghijklmnopqrstuvwyxzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" (elt "abcdefghijklmnopqrstuvwyxzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
(random 62)))))) (random 62))))))
(when (and (not *random-readable*) (coin 5)) (when (and (not simple) (not *random-readable*) (coin 5))
(let* ((len (length s)) (let* ((len (length s))
(len2 (random (1+ len)))) (len2 (random (1+ len))))
(setf s (make-array len2 (setf s (make-array len2
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment