From nsiivola at common-lisp.net  Sun Apr 22 16:40:31 2012
From: nsiivola at common-lisp.net (Nikodemus Siivola)
Date: Sun, 22 Apr 2012 09:40:31 -0700
Subject: [alexandria.git] updated branch master: a8fa399 adjust tests
Message-ID: <E1SLzpv-0006un-Bl@common-lisp.net>

The branch master has been updated:
       via  a8fa399482c548f6a8c2b517e0c30c921dc55890 (commit)
      from  49555427d8019a56132def9a4440663c66339131 (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 a8fa399482c548f6a8c2b517e0c30c921dc55890
Author: Nikodemus Siivola <nikodemus at random-state.net>
Date:   Sun Apr 22 19:33:51 2012 +0300

    adjust tests
    
      Workarounds for the Clisp and CMUCL failures.
    
      Newer Clisp's no longer have the stack-overflow for the hash-table test, so
      enable it too.

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

Summary of changes:
 tests.lisp |   30 ++++++++++++++----------------
 1 files changed, 14 insertions(+), 16 deletions(-)

diff --git a/tests.lisp b/tests.lisp
index b875382..e07694d 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -10,6 +10,10 @@
 (defun run-tests (&key ((:compiled *compile-tests*)))
   (do-tests))
 
+(defun hash-table-test-name (name)
+  ;; Workaround for Clisp calling EQL in a hash-table FASTHASH-EQL.
+  (hash-table-test (make-hash-table :test name)))
+
 ;;;; Arrays
 
 (deftest copy-array.1
@@ -250,8 +254,6 @@
                     (= 42 (gethash x table)))))))
   t)
 
-#+clisp (pushnew 'copy-hash-table.1 *expected-failures*)
-
 (deftest copy-hash-table.1
     (let ((orig (make-hash-table :test 'eq :size 123))
           (foo "foo"))
@@ -260,9 +262,7 @@
       (let ((eq-copy (copy-hash-table orig))
             (eql-copy (copy-hash-table orig :test 'eql))
             (equal-copy (copy-hash-table orig :test 'equal))
-            ;; CLISP overflows the stack with this bit.
-            ;; See <http://sourceforge.net/tracker/index.php?func=detail&aid=2029069&group_id=1355&atid=101355>.
-            #-clisp (equalp-copy (copy-hash-table orig :test 'equalp)))
+            (equalp-copy (copy-hash-table orig :test 'equalp)))
         (list (eql (hash-table-size eq-copy) (hash-table-size orig))
               (eql (hash-table-rehash-size eq-copy)
                    (hash-table-rehash-size orig))
@@ -272,7 +272,7 @@
               (gethash foo eql-copy)
               (gethash (copy-seq foo) equal-copy)
               (gethash "FOO" equal-copy)
-              #-clisp (gethash "FOO" equalp-copy))))
+              (gethash "FOO" equalp-copy))))
   (t t 2 t nil t t nil t))
 
 (deftest copy-hash-table.2
@@ -351,8 +351,6 @@
               (getf plist nil))))
   (20 0 -2 -7 nil))
 
-#+clisp (pushnew 'alist-hash-table.1 *expected-failures*)
-
 (deftest alist-hash-table.1
     (let* ((alist '((0 a) (1 b) (2 c)))
            (table (alist-hash-table alist)))
@@ -360,10 +358,9 @@
             (gethash 0 table)
             (gethash 1 table)
             (gethash 2 table)
-            (hash-table-test table))) ; CLISP returns EXT:FASTHASH-EQL.
-  (3 (a) (b) (c) eql))
-
-#+clisp (pushnew 'plist-hash-table.1 *expected-failures*)
+            (eq (hash-table-test-name 'eql)
+                (hash-table-test table))))
+  (3 (a) (b) (c) t))
 
 (deftest plist-hash-table.1
     (let* ((plist '(:a 1 :b 2 :c 3))
@@ -374,8 +371,9 @@
             (gethash :c table)
             (gethash 2 table)
             (gethash nil table)
-            (hash-table-test table))) ; CLISP returns EXT:FASTHASH-EQ.
-  (3 1 2 3 nil nil eq))
+            (eq (hash-table-test-name 'eq)
+                (hash-table-test table))))
+  (3 1 2 3 nil nil t))
 
 ;;;; Functions
 
@@ -1285,8 +1283,8 @@
               (member v (list v.vector v.list v.string))
               (equal l.list l)
               (equalp l.vector #(1 2 3))
-              (eql (upgraded-array-element-type 'fixnum)
-                   (array-element-type l.spec-v))
+              (type= (upgraded-array-element-type 'fixnum)
+                     (array-element-type l.spec-v))
               (equalp v.vector v)
               (equal v.list '(#\a #\b #\c))
               (equal "abc" v.string))))
-- 
Alexandria hooks/post-receive



From nsiivola at common-lisp.net  Sun Apr 22 16:47:38 2012
From: nsiivola at common-lisp.net (Nikodemus Siivola)
Date: Sun, 22 Apr 2012 09:47:38 -0700
Subject: [alexandria.git] updated branch master: daa0872 untabify tests
Message-ID: <E1SLzwo-0007Px-08@common-lisp.net>

The branch master has been updated:
       via  daa087258b7edd0fa2c31d2e4583c2dc8380a143 (commit)
      from  a8fa399482c548f6a8c2b517e0c30c921dc55890 (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 daa087258b7edd0fa2c31d2e4583c2dc8380a143
Author: Nikodemus Siivola <nikodemus at random-state.net>
Date:   Sun Apr 22 19:45:36 2012 +0300

    untabify tests
    
      Yech. Phui. Tabs.

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

Summary of changes:
 tests.lisp |  120 ++++++++++++++++++++++++++++++------------------------------
 1 files changed, 60 insertions(+), 60 deletions(-)

diff --git a/tests.lisp b/tests.lisp
index e07694d..d104bda 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -60,43 +60,43 @@
 (deftest unwind-protect-case.1
     (let (result)
       (unwind-protect-case ()
-	  (random 10)
-	(:normal (push :normal result))
-	(:abort  (push :abort result))
-	(:always (push :always result)))
+          (random 10)
+        (:normal (push :normal result))
+        (:abort  (push :abort result))
+        (:always (push :always result)))
       result)
   (:always :normal))
 
 (deftest unwind-protect-case.2
     (let (result)
       (unwind-protect-case ()
-	  (random 10)
-	(:always (push :always result))
-	(:normal (push :normal result))
-	(:abort  (push :abort result)))
+          (random 10)
+        (:always (push :always result))
+        (:normal (push :normal result))
+        (:abort  (push :abort result)))
       result)
   (:normal :always))
 
 (deftest unwind-protect-case.3
     (let (result1 result2 result3)
       (ignore-errors
-	(unwind-protect-case ()
-	    (error "FOOF!")
-	  (:normal (push :normal result1))
-	  (:abort  (push :abort result1))
-	  (:always (push :always result1))))
+        (unwind-protect-case ()
+            (error "FOOF!")
+          (:normal (push :normal result1))
+          (:abort  (push :abort result1))
+          (:always (push :always result1))))
       (catch 'foof
-	(unwind-protect-case ()
-	    (throw 'foof 42)
-	  (:normal (push :normal result2))
-	  (:abort  (push :abort result2))
-	  (:always (push :always result2))))
+        (unwind-protect-case ()
+            (throw 'foof 42)
+          (:normal (push :normal result2))
+          (:abort  (push :abort result2))
+          (:always (push :always result2))))
       (block foof
-	(unwind-protect-case ()
-	    (return-from foof 42)
-	  (:normal (push :normal result3))
-	  (:abort  (push :abort result3))
-	  (:always (push :always result3))))
+        (unwind-protect-case ()
+            (return-from foof 42)
+          (:normal (push :normal result3))
+          (:abort  (push :abort result3))
+          (:always (push :always result3))))
       (values result1 result2 result3))
   (:always :abort)
   (:always :abort)
@@ -105,17 +105,17 @@
 (deftest unwind-protect-case.4
     (let (result)
       (unwind-protect-case (aborted-p)
-	  (random 42)
-	(:always (setq result aborted-p)))
+          (random 42)
+        (:always (setq result aborted-p)))
       result)
   nil)
 
 (deftest unwind-protect-case.5
     (let (result)
       (block foof
-	(unwind-protect-case (aborted-p)
-	    (return-from foof)
-	  (:always (setq result aborted-p))))
+        (unwind-protect-case (aborted-p)
+            (return-from foof)
+          (:always (setq result aborted-p))))
       result)
   t)
 
@@ -280,17 +280,17 @@
           (list (list :list (vector :A :B :C))))
       (setf (gethash 'list ht) list)
       (let* ((shallow-copy (copy-hash-table ht))
-	     (deep1-copy (copy-hash-table ht :key 'copy-list))
-	     (list         (gethash 'list ht))
-	     (shallow-list (gethash 'list shallow-copy))
-	     (deep1-list   (gethash 'list deep1-copy)))
+             (deep1-copy (copy-hash-table ht :key 'copy-list))
+             (list         (gethash 'list ht))
+             (shallow-list (gethash 'list shallow-copy))
+             (deep1-list   (gethash 'list deep1-copy)))
         (list (eq ht shallow-copy)
-	      (eq ht deep1-copy)
-	      (eq list shallow-list)
-	      (eq list deep1-list)	             ; outer list was copied.
-	      (eq (second list) (second shallow-list))
-	      (eq (second list) (second deep1-list)) ; inner vector wasn't copied.
-	      )))
+              (eq ht deep1-copy)
+              (eq list shallow-list)
+              (eq list deep1-list)                   ; outer list was copied.
+              (eq (second list) (second shallow-list))
+              (eq (second list) (second deep1-list)) ; inner vector wasn't copied.
+              )))
   (nil nil t nil t t))
 
 (deftest maphash-keys.1
@@ -1429,26 +1429,26 @@
 
 (deftest sequences.passing-improper-lists
     (macrolet ((signals-error-p (form)
-		 `(handler-case 
+                 `(handler-case 
                       (progn ,form nil)
-		    (type-error (e)
+                    (type-error (e)
                       t)))
                (cut (fn &rest args)
                  (with-gensyms (arg)
                    (print`(lambda (,arg)
                        (apply ,fn (list ,@(substitute arg '_ args))))))))
       (let ((circular-list (make-circular-list 5 :initial-element :foo))
-	    (dotted-list (list* 'a 'b 'c 'd)))
-	(loop for nth from 0
-	      for fn in (list
-			 (cut #'lastcar _)
-			 (cut #'rotate _ 3)
-			 (cut #'rotate _ -3)
-			 (cut #'shuffle _)
-			 (cut #'random-elt _)
-			 (cut #'last-elt _)
-			 (cut #'ends-with :foo _))
-	      nconcing
+            (dotted-list (list* 'a 'b 'c 'd)))
+        (loop for nth from 0
+              for fn in (list
+                         (cut #'lastcar _)
+                         (cut #'rotate _ 3)
+                         (cut #'rotate _ -3)
+                         (cut #'shuffle _)
+                         (cut #'random-elt _)
+                         (cut #'last-elt _)
+                         (cut #'ends-with :foo _))
+              nconcing
                  (let ((on-circular-p (signals-error-p (funcall fn circular-list)))
                        (on-dotted-p (signals-error-p (funcall fn dotted-list))))
                    (when (or (not on-circular-p) (not on-dotted-p))
@@ -1656,15 +1656,15 @@
 (macrolet
     ((test (type numbers)
        `(deftest ,(format-symbol t '#:cdr5.~a (string type))
-	    (let ((numbers ,numbers))
-	      (values (mapcar (of-type ',(format-symbol t '#:negative-~a (string type))) numbers)
-		      (mapcar (of-type ',(format-symbol t '#:non-positive-~a (string type))) numbers)
-		      (mapcar (of-type ',(format-symbol t '#:non-negative-~a (string type))) numbers)
-		      (mapcar (of-type ',(format-symbol t '#:positive-~a (string type))) numbers)))
-	  (t t t nil nil nil nil)
-	  (t t t t nil nil nil)
-	  (nil nil nil t t t t)
-	  (nil nil nil nil t t t))))
+            (let ((numbers ,numbers))
+              (values (mapcar (of-type ',(format-symbol t '#:negative-~a (string type))) numbers)
+                      (mapcar (of-type ',(format-symbol t '#:non-positive-~a (string type))) numbers)
+                      (mapcar (of-type ',(format-symbol t '#:non-negative-~a (string type))) numbers)
+                      (mapcar (of-type ',(format-symbol t '#:positive-~a (string type))) numbers)))
+          (t t t nil nil nil nil)
+          (t t t t nil nil nil)
+          (nil nil nil t t t t)
+          (nil nil nil nil t t t))))
   (test fixnum       (list most-negative-fixnum       -42      -1     0     1     42      most-positive-fixnum))
   (test integer      (list (1- most-negative-fixnum)  -42      -1     0     1     42      (1+ most-positive-fixnum)))
   (test rational     (list (1- most-negative-fixnum)  -42/13   -1     0     1     42/13   (1+ most-positive-fixnum)))
-- 
Alexandria hooks/post-receive



From nsiivola at common-lisp.net  Wed Apr 25 12:29:02 2012
From: nsiivola at common-lisp.net (Nikodemus Siivola)
Date: Wed, 25 Apr 2012 05:29:02 -0700
Subject: [alexandria.git] updated branch master: 3448822 add EXTREMUM
Message-ID: <E1SN1LC-00024b-9k@common-lisp.net>

The branch master has been updated:
       via  34488223ff5b7eb19d73075481c91f829af5d6bd (commit)
      from  daa087258b7edd0fa2c31d2e4583c2dc8380a143 (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 34488223ff5b7eb19d73075481c91f829af5d6bd
Author: Nikodemus Siivola <nikodemus at random-state.net>
Date:   Wed Apr 25 15:24:49 2012 +0300

    add EXTREMUM
    
      From http://www.cliki.net/EXTREMUM
    
      A simple version built on top of REDUCE for now.

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

Summary of changes:
 package.lisp   |    4 +++-
 sequences.lisp |   51 +++++++++++++++++++++++++++++++++++++++++++++++++++
 tests.lisp     |   28 ++++++++++++++++++++++++++++
 3 files changed, 82 insertions(+), 1 deletions(-)

diff --git a/package.lisp b/package.lisp
index 673ed30..babeb95 100644
--- a/package.lisp
+++ b/package.lisp
@@ -107,17 +107,19 @@
    #:emptyp
    #:ends-with
    #:ends-with-subseq
+   #:extremum
    #:first-elt
    #:last-elt
+   #:length=
    #:map-combinations
    #:map-derangements
    #:map-permutations
+   #:no-extremum
    #:proper-sequence
    #:random-elt
    #:removef
    #:rotate
    #:sequence-of-length-p
-   #:length=
    #:shuffle
    #:starts-with
    #:starts-with-subseq
diff --git a/sequences.lisp b/sequences.lisp
index 9e4ff74..cb01081 100644
--- a/sequences.lisp
+++ b/sequences.lisp
@@ -484,3 +484,54 @@ if calling FUNCTION modifies either the derangement or SEQUENCE."
       sequence)))
 
 (declaim (notinline sequence-of-length-p))
+
+(define-condition no-extremum (error)
+  ()
+  (:report (lambda (condition stream)
+             (declare (ignore condition))
+             (format stream "Empty sequence in ~S." 'extremum))))
+
+
+(defun extremum (sequence predicate &key key (start 0) end)
+  "Returns the element of SEQUENCE that would appear first if the subsequence
+bounded by START and END was sorted using PREDICATE and KEY.
+
+EXTREMUM determines the relationship between two elements of SEQUENCE by using
+the PREDICATE function. PREDICATE should return true if and only if the first
+argument is strictly less than the second one (in some appropriate sense). Two
+arguments X and Y are considered to be equal if (FUNCALL PREDICATE X Y)
+and (FUNCALL PREDICATE Y X) are both false.
+
+The arguments to the PREDICATE function are computed from elements of SEQUENCE
+using the KEY function, if supplied. If KEY is not supplied or is NIL, the
+sequence element itself is used.
+
+If SEQUENCE is empty, then the error NO-EXTREMUM is signalled. Invoking the
+CONTINUE restart will cause extremum to return NIL."
+  (let* ((pred-fun (ensure-function predicate))
+         (key-fun (unless (or (not key) (eq key 'identity) (eq key #'identity))
+                    (ensure-function key)))
+         (real-end (or end (length sequence))))
+    (cond ((> real-end start)
+           (if key-fun
+               (flet ((reduce-keys (a b)
+                        (if (funcall pred-fun
+                                     (funcall key-fun a)
+                                     (funcall key-fun b))
+                            a
+                            b)))
+                 (declare (dynamic-extent #'reduce-keys))
+                 (reduce #'reduce-keys sequence :start start :end real-end))
+               (flet ((reduce-elts (a b)
+                        (if (funcall pred-fun a b)
+                            a
+                            b)))
+                 (declare (dynamic-extent #'reduce-elts))
+                 (reduce #'reduce-elts sequence :start start :end real-end))))
+          ((= real-end start)
+           (cerror "Return NIL instead." 'no-extremum))
+          (t
+           (error "Invalid bounding indexes for sequence of length ~S: ~S ~S, ~S ~S"
+                  (length sequence)
+                  :start start
+                  :end end)))))
diff --git a/tests.lisp b/tests.lisp
index d104bda..e218113 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -1828,3 +1828,31 @@
   t
   t
   t)
+
+(deftest extremum.1
+    (let ((n 0))
+      (dotimes (i 10)
+       (let ((data (shuffle (coerce (iota 10000 :start i) 'vector)))
+             (ok t))
+         (unless (eql i (extremum data #'<))
+           (setf ok nil))
+         (unless (eql i (extremum (coerce data 'list) #'<))
+           (setf ok nil))
+         (unless (eql (+ 9999 i) (extremum data #'>))
+           (setf ok nil))
+         (unless (eql (+ 9999 i) (extremum (coerce  data 'list) #'>))
+           (setf ok nil))
+         (when ok
+           (incf n))))
+      (when (eql 10 (extremum #(100 1 10 1000) #'> :start 1 :end 3))
+        (incf n))
+      (when (eql -1000 (extremum #(100 1 10 -1000) #'> :key 'abs))
+        (incf n))
+      (let ((err nil))
+        (handler-bind ((no-extremum (lambda (c)
+                                      (setf err c)
+                                      (continue c))))
+          (when (eq nil (extremum "" #'error))
+            (when err
+              (incf n))))))
+  13)
-- 
Alexandria hooks/post-receive



From nsiivola at common-lisp.net  Thu Apr 26 09:06:48 2012
From: nsiivola at common-lisp.net (Nikodemus Siivola)
Date: Thu, 26 Apr 2012 02:06:48 -0700
Subject: [alexandria.git] updated branch master: 0c39310 tweak EXTREMUM
Message-ID: <E1SNKf2-0006Zs-Mc@common-lisp.net>

The branch master has been updated:
       via  0c39310ebc2de5543157e6b862e909036b39d936 (commit)
      from  34488223ff5b7eb19d73075481c91f829af5d6bd (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 0c39310ebc2de5543157e6b862e909036b39d936
Author: Nikodemus Siivola <nikodemus at random-state.net>
Date:   Thu Apr 26 12:01:35 2012 +0300

    tweak EXTREMUM
    
     Return NIL if the sequence is empty, instead of the NO-EXTREMUM nonsense.
    
     It was bad design, because it's not an error someone higher up the stack can
     sensibly handle, and handling it locally is too verbose and slow.
    
        (or (extremum ...) (error ...))
    
     expresses the common case succintly, and fits the pattern of existing
     sequence functions.
    
     If it is deemed necessary, we can also add &KEY DEFAULT, but that seems
     overkill and has little precedent in sequence functions.

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

Summary of changes:
 package.lisp   |    1 -
 sequences.lisp |    5 ++---
 tests.lisp     |   10 +++-------
 3 files changed, 5 insertions(+), 11 deletions(-)

diff --git a/package.lisp b/package.lisp
index babeb95..cf258fc 100644
--- a/package.lisp
+++ b/package.lisp
@@ -114,7 +114,6 @@
    #:map-combinations
    #:map-derangements
    #:map-permutations
-   #:no-extremum
    #:proper-sequence
    #:random-elt
    #:removef
diff --git a/sequences.lisp b/sequences.lisp
index cb01081..8b9a443 100644
--- a/sequences.lisp
+++ b/sequences.lisp
@@ -506,8 +506,7 @@ The arguments to the PREDICATE function are computed from elements of SEQUENCE
 using the KEY function, if supplied. If KEY is not supplied or is NIL, the
 sequence element itself is used.
 
-If SEQUENCE is empty, then the error NO-EXTREMUM is signalled. Invoking the
-CONTINUE restart will cause extremum to return NIL."
+If SEQUENCE is empty, NIL is returned."
   (let* ((pred-fun (ensure-function predicate))
          (key-fun (unless (or (not key) (eq key 'identity) (eq key #'identity))
                     (ensure-function key)))
@@ -529,7 +528,7 @@ CONTINUE restart will cause extremum to return NIL."
                  (declare (dynamic-extent #'reduce-elts))
                  (reduce #'reduce-elts sequence :start start :end real-end))))
           ((= real-end start)
-           (cerror "Return NIL instead." 'no-extremum))
+           nil)
           (t
            (error "Invalid bounding indexes for sequence of length ~S: ~S ~S, ~S ~S"
                   (length sequence)
diff --git a/tests.lisp b/tests.lisp
index e218113..7ffe30f 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -1848,11 +1848,7 @@
         (incf n))
       (when (eql -1000 (extremum #(100 1 10 -1000) #'> :key 'abs))
         (incf n))
-      (let ((err nil))
-        (handler-bind ((no-extremum (lambda (c)
-                                      (setf err c)
-                                      (continue c))))
-          (when (eq nil (extremum "" #'error))
-            (when err
-              (incf n))))))
+      (when (eq nil (extremum "" (lambda (a b) (error "wtf? ~S, ~S" a b))))
+        (incf n))
+      n)
   13)
-- 
Alexandria hooks/post-receive