Commit f20785f0 authored by Nikodemus Siivola's avatar Nikodemus Siivola
Browse files

more error-checking in RANDOM-ELT

 Check for empty sequences and invalid bounding index designators.
parent c9e15432
...@@ -104,13 +104,28 @@ error if SEQUENCE is not a proper sequence." ...@@ -104,13 +104,28 @@ error if SEQUENCE is not a proper sequence."
(defun random-elt (sequence &key (start 0) end) (defun random-elt (sequence &key (start 0) end)
"Returns a random element from SEQUENCE bounded by START and END. Signals an "Returns a random element from SEQUENCE bounded by START and END. Signals an
error if the SEQUENCE is not a proper sequence." error if the SEQUENCE is not a proper non-empty sequence, or if END and START
are not proper bounding index designators for SEQUENCE."
(declare (sequence sequence) (fixnum start) (type (or fixnum null) end)) (declare (sequence sequence) (fixnum start) (type (or fixnum null) end))
(let ((i (+ start (random (- (or end (if (listp sequence) (let* ((size (if (listp sequence)
(proper-list-length sequence) (proper-list-length sequence)
(length sequence))) (length sequence)))
start))))) (end2 (or end size)))
(elt sequence i))) (cond ((zerop size)
(error 'type-error
:datum sequence
:expected-type `(and sequence (not (satisfies emptyp)))))
((not (and (<= 0 start) (< start end2) (<= end2 size)))
(error 'simple-type-error
:datum (cons start end)
:expected-type `(cons (integer 0 (,end2))
(or null (integer (,start) ,size)))
:format-control "~@<~S and ~S are not valid bounding index designators for ~
a sequence of length ~S.~:@>"
:format-arguments (list start end size)))
(t
(let ((index (+ start (random (- end2 start)))))
(elt sequence index))))))
(declaim (inline remove/swapped-arguments)) (declaim (inline remove/swapped-arguments))
(defun remove/swapped-arguments (sequence item &rest keyword-arguments) (defun remove/swapped-arguments (sequence item &rest keyword-arguments)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment