[alexandria.git] updated branch master: f20785f more error-checking in RANDOM-ELT

[Nikodemus Siivola]

The branch master has been updated:
       via  f20785f0a69490059454f08cd42f84ddb4bdc307 (commit)
       via  c9e15432a5ee16e9cbeb802f38571d0a6bead7fd (commit)
       via  d6e2b3f484623a766d421be5300659bf4db87ed6 (commit)
      from  03dc209e00afbfe51cf746adc39d303d1cfe4fb3 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit f20785f0a69490059454f08cd42f84ddb4bdc307
Author: Nikodemus Siivola <nikodemus at random-state.net>
Date:   Sun Mar 6 13:37:10 2011 +0200

    more error-checking in RANDOM-ELT
    
     Check for empty sequences and invalid bounding index designators.

commit c9e15432a5ee16e9cbeb802f38571d0a6bead7fd
Author: Nikodemus Siivola <nikodemus at random-state.net>
Date:   Sun Mar 6 13:36:37 2011 +0200

    missing final punctuation in a docstring

commit d6e2b3f484623a766d421be5300659bf4db87ed6
Author: Nikodemus Siivola <nikodemus at random-state.net>
Date:   Sun Mar 6 13:35:25 2011 +0200

    clarify INLINE/NOTINLINE issue with compiler-macros

-----------------------------------------------------------------------

Summary of changes:
 sequences.lisp |   31 +++++++++++++++++++++++--------
 1 files changed, 23 insertions(+), 8 deletions(-)

diff --git a/sequences.lisp b/sequences.lisp
index a4b2a95..f1e3f50 100644
--- a/sequences.lisp
+++ b/sequences.lisp
@@ -2,7 +2,7 @@
 
 ;; Make these inlinable by declaiming them INLINE here and some of them
 ;; NOTINLINE at the end of the file. Exclude functions that have a compiler
-;; macro, because inlining seems to cancel compiler macros (at least on SBCL).
+;; macro, because NOTINLINE is required to prevent compiler-macro expansion.
 (declaim (inline copy-sequence sequence-of-length-p))
 
 (defun sequence-of-length-p (sequence length)
@@ -104,13 +104,28 @@ error if SEQUENCE is not a proper sequence."
 
 (defun random-elt (sequence &key (start 0) end)
   "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))
-  (let ((i (+ start (random (- (or end  (if (listp sequence)
-                                            (proper-list-length sequence)
-                                            (length sequence)))
-                               start)))))
-    (elt sequence i)))
+  (let* ((size (if (listp sequence)
+                   (proper-list-length sequence)
+                   (length sequence)))
+         (end2 (or end size)))
+    (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))
 (defun remove/swapped-arguments (sequence item &rest keyword-arguments)
@@ -138,7 +153,7 @@ that are not lists."
 
 (defun emptyp (sequence)
   "Returns true if SEQUENCE is an empty sequence. Signals an error if SEQUENCE
-is not a sequence"
+is not a sequence."
   (etypecase sequence
     (list (null sequence))
     (sequence (zerop (length sequence)))))
-- 
Alexandria hooks/post-receive