From 6b106e65bc6857cb1b944a881502bf4ec450fea0 Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Fri, 1 Jun 2007 17:30:59 +0300
Subject: [PATCH] MAP-IOTA, misc. fixes, and tests up to 100% coverage

---
 control-flow.lisp |   2 +-
 functions.lisp    |   4 +-
 numbers.lisp      |  19 +++
 package.lisp      |   5 +-
 sequences.lisp    |   5 +-
 tests.lisp        | 354 +++++++++++++++++++++++++++++++++++++++++++++++++++---
 6 files changed, 365 insertions(+), 24 deletions(-)

diff --git a/control-flow.lisp b/control-flow.lisp
index 5f68368..d4de01c 100644
--- a/control-flow.lisp
+++ b/control-flow.lisp
@@ -26,7 +26,7 @@ returns the values of DEFAULT if no keys match."
               (error "No keys match in ESWITCH. Testing against ~S with ~S."
                      ,value ',test))))))
 
-(defmacro eswitch ((object &key (test 'eql) (key 'identity)) &body clauses)
+(defmacro cswitch ((object &key (test 'eql) (key 'identity)) &body clauses)
   "Like SWITCH, but signals a continuable error if no key matches."
   (with-gensyms (value)
     `(let ((,value (,key ,object)))
diff --git a/functions.lisp b/functions.lisp
index 6d02660..9e9bbd1 100644
--- a/functions.lisp
+++ b/functions.lisp
@@ -103,8 +103,7 @@ with and ARGUMENTS to FUNCTION."
 (defmacro named-lambda (name lambda-list &body body)
   "Expands into a lambda-expression within whose BODY NAME denotes the
 function corresponding function."
-  (let* ((simplep (union lambda-list-keywords lambda-list))
-         (restp (and (not simplep) (find '&rest lambda-list))))
+  (let ((simplep (not (intersection lambda-list-keywords lambda-list))))
     (if simplep
         ;; Required arguments only, no need for APPLY
         `(lambda ,lambda-list
@@ -114,6 +113,5 @@ function corresponding function."
         ;; get &KEY and &REST handled correctly.
         (with-gensyms (arguments)
           `(lambda (&rest ,arguments)
-             ,@(unless restp `((declare (dynamic-extent ,arguments))))
              (labels ((,name ,lambda-list ,@body))
                (apply #',name ,arguments)))))))
diff --git a/numbers.lisp b/numbers.lisp
index 8b5ca1e..ceb9b8f 100644
--- a/numbers.lisp
+++ b/numbers.lisp
@@ -58,6 +58,25 @@ Examples:
      for i = (+ start (- step step)) then (+ i step)
      collect i))
 
+(declaim (inline map-iota))
+(defun map-iota (function n &key (start 0) (step 1))
+  "Calls FUNCTION with N numbers, starting from START (with numeric contagion
+from STEP applied), each consequtive number being the sum of the previous one
+and STEP. START defaults to 0 and STEP to 0. Returns N.
+
+Examples:
+
+  (iota 4)                      => (0 1 2 3 4)
+  (iota 3 :start 1 :step 1.0)   => (1.0 2.0 3.0)
+  (iota 3 :start -1 :step -1/2) => (-1 -3/2 -2)
+"
+  (declare (type (integer 0) n) (number start step))
+  (loop repeat n
+        ;; KLUDGE: get numeric contagion right for the first element too
+        for i = (+ start (- step step)) then (+ i step)
+        do (funcall function i))
+  n)
+
 (declaim (inline lerp))
 (defun lerp (v a b)
   "Returns the result of linear interpolation between A and B, using the
diff --git a/package.lisp b/package.lisp
index c05f2c0..1842c20 100644
--- a/package.lisp
+++ b/package.lisp
@@ -58,9 +58,10 @@
    ;; Numbers
    #:clamp
    #:gaussian-random
-   #:iota
+   #:iota   
    #:lerp
-   #:maxf
+   #:map-iota
+   #:maxf   
    #:mean   
    #:median
    #:minf
diff --git a/sequences.lisp b/sequences.lisp
index f9760ad..8df526d 100644
--- a/sequences.lisp
+++ b/sequences.lisp
@@ -137,12 +137,13 @@ not a sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE.
   ;; type-error.
   (cond ((consp sequence)
          (setf (car sequence) object))
-        ((and (typep sequence '(and sequence (not list))) (plusp (length sequence)))
+        ((and (typep sequence '(and sequence (not list)))
+              (plusp (length sequence)))
          (setf (elt sequence 0) object))
         (t
          (error 'type-error 
                 :datum sequence 
-                :expected-type '(and proper-sequence (not (satisfies emptyp)))))))
+                :expected-type '(and sequence (not (satisfies emptyp)))))))
 
 (defun last-elt (sequence)
   "Returns the last element of SEQUENCE. Signals a type-error if SEQUENCE is
diff --git a/tests.lisp b/tests.lisp
index 496878f..11ceebd 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -9,6 +9,107 @@
 
 (in-package :alexandria-test)
 
+;;;; Arrays
+
+(deftest copy-array.1
+    (let* ((orig (vector 1 2 3))
+           (copy (copy-array orig)))
+      (values (eq orig copy) (equalp orig copy)))
+  nil t)
+
+(deftest copy-array.2
+    (let ((orig (make-array 1024 :fill-pointer 0)))
+      (vector-push-extend 1 orig)
+      (vector-push-extend 2 orig)
+      (vector-push-extend 3 orig)
+      (let ((copy (copy-array orig)))
+        (values (eq orig copy) (equalp orig copy)
+                (array-has-fill-pointer-p copy)
+                (eql (fill-pointer orig) (fill-pointer copy)))))
+  nil t t t)
+
+(deftest array-index.1
+    (typep 0 'array-index)
+  t)
+
+;;;; Control flow
+
+(deftest switch.1
+    (switch (13 :test =)
+      (12 :oops)
+      (13.0 :yay))
+  :yay)
+
+(deftest switch.2
+    (switch (13 :default :yay)
+      ((+ 12 2) :oops)
+      ((- 13 1) :oops2))
+  :yay)
+
+(deftest eswitch.1
+    (let ((x 13))
+      (eswitch (x :test =)
+        (12 :oops)
+        (13.0 :yay)))
+  :yay)
+
+(deftest eswitch.2
+    (let ((x 13))
+      (eswitch (x :key 1+)
+        (11 :oops)
+        (14 :yay)))
+  :yay)
+
+(deftest cswitch.1
+    (cswitch (13 :test =)
+      (12 :oops)
+      (13.0 :yay))
+  :yay)
+
+(deftest cswitch.2
+    (cswitch (13 :key 1-)
+      (12 :yay)
+      (13.0 :oops))
+  :yay)
+
+(deftest whichever.1
+    (let ((x (whichever 1 2 3)))
+      (and (member x '(1 2 3)) t))
+  t)
+
+(deftest xor.1
+    (xor nil nil 1 nil)
+  1
+  t)
+
+;;;; Definitions
+
+(deftest define-constant.1
+    (let ((name (gensym)))
+      (eval `(define-constant ,name "FOO" :test equal))
+      (eval `(define-constant ,name "FOO" :test equal))
+      (values (equal "FOO" (symbol-value name))
+              (constantp name)))
+  t
+  t)
+
+(deftest define-constant.2
+    (let ((name (gensym)))
+      (eval `(define-constant ,name 13))
+      (eval `(define-constant ,name 13))
+      (values (eql 13 (symbol-value name))
+              (constantp name)))
+  t
+  t)
+
+;;;; Errors
+
+(deftest required-argument.1
+    (multiple-value-bind (res err)
+        (ignore-errors (required-argument))
+      (typep err 'error))
+  t)
+
 ;;;; Hash tables
 
 (deftest copy-hash-table.1
@@ -33,6 +134,7 @@
 (deftest maphash-keys.1
     (let ((keys nil)
           (table (make-hash-table)))
+      (declare (notinline maphash-keys))
       (dotimes (i 10)
         (setf (gethash i table) t))
       (maphash-keys (lambda (k) (push k keys)) table)
@@ -42,6 +144,7 @@
 (deftest maphash-values.1
     (let ((vals nil)
           (table (make-hash-table)))
+      (declare (notinline maphash-values))
       (dotimes (i 10)
         (setf (gethash i table) (- i)))
       (maphash-values (lambda (v) (push v vals)) table)
@@ -221,8 +324,55 @@
       (funcall r 8))
   4)
 
+(deftest named-lambda.1
+    (let ((fac (named-lambda fac (x)
+                 (if (> x 1)
+                     (* x (fac (- x 1)))
+                     x))))
+      (funcall fac 5))
+  120)
+
+(deftest named-lambda.2
+    (let ((fac (named-lambda fac (&key x)
+                 (if (> x 1)
+                     (* x (fac :x (- x 1)))
+                     x))))
+      (funcall fac :x 5))
+  120)
+
 ;;;; Lists
 
+(deftest alist-plist.1
+    (alist-plist '((a . 1) (b . 2) (c . 3)))
+  (a 1 b 2 c 3))
+
+(deftest plist-alist.1
+    (plist-alist '(a 1 b 2 c 3))
+  ((a . 1) (b . 2) (c . 3)))
+
+(deftest unionf.1
+    (let* ((list '(1 2 3))
+           (orig list))
+      (unionf list '(1 2 4))
+      (values (equal orig (list 1 2 3))
+              (eql (length list) 4)
+              (set-difference list (list 1 2 3 4))
+              (set-difference (list 1 2 3 4) list)))
+  t
+  t
+  nil
+  nil)
+
+(deftest nunionf.1
+    (let ((list '(1 2 3)))
+      (nunionf list '(1 2 4))
+      (values (eql (length list) 4)
+              (set-difference (list 1 2 3 4) list)
+              (set-difference list (list 1 2 3 4))))
+  t
+  nil
+  nil)
+
 (deftest appendf.1
     (let* ((list '(1 2 3))
            (orig list))
@@ -252,6 +402,10 @@
             (circular-list-p tailcirc)))
   (t nil nil nil t))
 
+(deftest circular-list-p.2
+    (circular-list-p 'foo)
+  nil)
+
 (deftest circular-tree-p.1
     (let* ((circle (circular-list 1 2 3 4))
            (tree1 (list circle circle))
@@ -287,6 +441,10 @@
             (proper-list-p l5)))
   (t t nil t nil))
 
+(deftest proper-list-p.2
+    (proper-list-p '(1 2 . 3))
+  nil)
+
 (deftest proper-list.type.1
     (let ((l1 (list 1))
           (l2 (list 1 2))
@@ -325,6 +483,13 @@
   4
   42)
 
+(deftest setf-lastcar.2
+    (let ((l (circular-list 1 2 3)))
+      (multiple-value-bind (res err)
+          (ignore-errors (setf (lastcar l) 4))
+        (typep err 'type-error)))
+  t)
+
 (deftest make-circular-list.1
     (let ((l (make-circular-list 3 :initial-element :x)))
       (setf (car l) :y)
@@ -351,6 +516,17 @@
             (ensure-list y)))
   ((1) (2)))
 
+(deftest ensure-cons.1
+    (let ((x (cons 1 2))
+          (y nil)
+          (z "foo"))
+      (values (ensure-cons x)
+              (ensure-cons y)
+              (ensure-cons z)))
+  (1 . 2)
+  (nil)
+  ("foo"))
+
 (deftest setp.1
     (setp '(1))
   t)
@@ -404,10 +580,18 @@
     (set-equal '(a d c) '(:a :b :c) :key 'string :test 'equal)
   nil)
 
+(deftest set-equal.6
+    (set-equal '(a b c) '(a b c d))
+  nil)
+
 (deftest map-product.1
     (map-product 'cons '(2 3) '(1 4))
   ((2 . 1) (2 . 4) (3 . 1) (3 . 4)))
 
+(deftest map-product.2
+    (map-product #'cons '(2 3) '(1 4))
+  ((2 . 1) (2 . 4) (3 . 1) (3 . 4)))
+
 (deftest flatten.1
     (flatten '((1) 2 (((3 4))) ((((5)) 6)) 7))
   (1 2 3 4 5 6 7))
@@ -445,10 +629,18 @@
           (clamp 0 1 2))
   (1.5 2.0 1.0 2 1))
 
-#+(or)
 (deftest gaussian-random.1
-    ???
-  )
+    (let ((min -0.2)
+          (max +0.2))
+      (multiple-value-bind (g1 g2)
+          (gaussian-random min max)
+        (values (<= min g1 max)
+                (<= min g2 max)
+                (/= g1 g2) ;uh
+                )))
+  t
+  t
+  t)
 
 (deftest iota.1
     (iota 3)
@@ -462,6 +654,17 @@
     (iota 3 :start 2 :step 3.0)
   (2.0 5.0 8.0))
 
+(deftest map-iota.1
+    (let (all)
+      (declare (notinline map-iota))
+      (values (map-iota (lambda (x) (push x all))
+                        3
+                        :start 2
+                        :step 1.1d0)
+              all))
+  3
+  (4.2d0 3.1d0 2.0d0))
+
 (deftest lerp.1
     (lerp 0.5 1 2)
   1.5)
@@ -490,11 +693,13 @@
     (median '(100 0 99 1 98 2 97 96))
   195/2)
 
-#+(or)
-(deftest variance)
+(deftest variance.1
+    (variance (list 1 2 3))
+  2/3)
 
-#+nil
-(deftest standard-deviation)
+(deftest standard-deviation.1
+    (< 0 (standard-deviation (list 1 2 3)) 1)
+  t)
 
 (deftest maxf.1
     (let ((x 1))
@@ -597,8 +802,14 @@
    #(1 2 3 4)
    #(2 3 4 1)))
 
-(deftest suffle.1
-    (let ((s (suffle (iota 100))))
+(deftest rotate.5
+    (values (rotate (list 1) 17)
+            (rotate (list 1) -5))
+  (1)
+  (1))
+
+(deftest shuffle.1
+    (let ((s (shuffle (iota 100))))
       (list (equal s (iota 100))
             (every (lambda (x)
                      (member x s))
@@ -608,6 +819,17 @@
                    s)))
   (nil t t))
 
+(deftest shuffle.2
+    (let ((s (shuffle (coerce (iota 100) 'vector))))
+      (list (equal s (coerce (iota 100) 'vector))
+            (every (lambda (x)
+                     (find x s))
+                   (iota 100))
+            (every (lambda (x)
+                     (typep x '(integer 0 99)))
+                   s)))
+  (nil t t))
+
 (deftest random-elt.1
     (let ((s1 #(1 2 3 4))
           (s2 '(1 2 3 4)))
@@ -692,6 +914,7 @@
 (deftest copy-sequence.1
     (let ((l (list 1 2 3))
           (v (vector #\a #\b #\c)))
+      (declare (notinline copy-sequence))
       (let ((l.list (copy-sequence 'list l))
             (l.vector (copy-sequence 'vector l))
             (l.spec-v (copy-sequence '(vector fixnum) l))
@@ -742,6 +965,13 @@
   "xoobar"
   #(zot :b :c))
 
+(deftest setf-first-elt.error.1
+    (let ((l 'foo))
+      (multiple-value-bind (res err)
+          (ignore-errors (setf (first-elt l) 4))
+        (typep err 'type-error)))
+  t)
+
 (deftest last-elt.1
     (mapcar #'last-elt
             (list (list 1 2 3)
@@ -782,6 +1012,13 @@
   "fooba?"
   #*010101000)
 
+(deftest setf-last-elt.error.1
+    (handler-case
+        (setf (last-elt 'foo) 13)
+      (type-error ()
+        :type-error))
+  :type-error)
+
 (deftest starts-with.1
     (list (starts-with 1 '(1 2 3))
           (starts-with 1 #(1 2 3))
@@ -840,6 +1077,29 @@
                      (mapcar #'symbol-name syms)))))
   (nil t))
 
+(deftest with-unique-names.2
+    (let ((*gensym-counter* 0))
+      (let ((syms (with-unique-names ((foo "_foo_") (bar -bar-) (quux #\q))
+                    (list foo bar quux))))
+        (list (find-if #'symbol-package syms)
+              (equal '("_foo_0" "-BAR-1" "q2")
+                     (mapcar #'symbol-name syms)))))
+  (nil t))
+
+(deftest with-unique-names.3
+    (let ((*gensym-counter* 0))
+      (multiple-value-bind (res err)
+          (ignore-errors
+            (eval
+             '(let ((syms
+                     (with-unique-names ((foo "_foo_") (bar -bar-) (quux 42))
+                       (list foo bar quux))))
+               (list (find-if #'symbol-package syms)
+                (equal '("_foo_0" "-BAR-1" "q2")
+                 (mapcar #'symbol-name syms))))))
+        (typep err 'error)))
+  t)
+
 (deftest once-only.1
     (macrolet ((cons1.good (x)
                  (once-only (x)
@@ -883,23 +1143,35 @@
   ((declare (foo)))
   nil)
 
+(deftest parse-body.6
+    (multiple-value-bind (res err)
+        (ignore-errors
+          (parse-body '("foo" "bar" "quux")
+                      :documentation t))
+      (typep err 'error))
+  t)
+
 ;;;; Symbols
 
 (deftest ensure-symbol.1
     (ensure-symbol :cons :cl)
-  cons)
+  cons
+  :external)
 
 (deftest ensure-symbol.2
-    (ensure-symbol "CONS")
-  cons)
+    (ensure-symbol "CONS" :alexandria)
+  cons
+  :inherited)
 
 (deftest ensure-symbol.3
     (ensure-symbol 'foo :keyword)
-  :foo)
+  :foo
+  :external)
 
 (deftest ensure-symbol.4
-    (ensure-symbol #\*)
-  *)
+    (ensure-symbol #\* :alexandria)
+  *
+  :inherited)
 
 (deftest format-symbol.1
     (let ((s (format-symbol nil "X-~D" 13)))
@@ -933,9 +1205,11 @@
 ;;;; Type-system
 
 (deftest of-type.1
+    (locally
+        (declare (notinline of-type))
     (let ((f (of-type 'string)))
       (list (funcall f "foo")
-            (funcall f 'bar)))
+            (funcall f 'bar))))
   (t nil))
 
 (deftest type=.1
@@ -996,6 +1270,21 @@
             (and (not y) x))
   1)
 
+(deftest if-let.5
+    (if-let (x)
+            :oops
+            (not x))
+  t)
+
+(deftest if-let.error.1
+    (handler-case
+        (eval '(if-let x
+                :oops
+                :oops))
+      (type-error ()
+        :type-error))
+  :type-error)
+
 (deftest if-let*.1
     (let ((x 1))
       (if-let* ((x 2)
@@ -1011,6 +1300,19 @@
              (and (not x) y))
   2)
 
+(deftest if-let*.3
+    (if-let* (x 1)
+             x
+             :oops)
+  1)
+
+(deftest if-let*.error.1
+    (handler-case
+        (eval '(if-let* x :oops :oops))
+      (type-error ()
+        :type-error))
+  :type-error)
+
 (deftest when-let.1
     (when-let (x (opaque :ok))
       (setf x (cons x x))
@@ -1031,9 +1333,29 @@
         (+ x y)))
   3)
 
+(deftest when-let.error.1
+    (handler-case
+        (eval '(when-let x :oops))
+      (type-error ()
+        :type-error))
+  :type-error)
+
 (deftest when-let*.1
     (let ((x 1))
       (when-let* ((x 2)
                   (y x))
         (+ x y)))
   4)
+
+(deftest when-let*.2
+    (let ((y 1))
+      (when-let* (x y)
+        (1+ x)))
+  2)
+
+(deftest when-let*.error.1
+    (handler-case
+        (eval '(when-let* x :oops))
+      (type-error ()
+        :type-error))
+  :type-error)
-- 
2.11.4.GIT