sublis.lsp 5.18 KB
Newer Older
1 2 3 4 5 6 7
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Apr 19 21:32:50 2003
;;;; Contains: Tests of SUBLIS

(in-package :cl-test)

8 9
(compile-and-load "cons-aux.lsp")

10 11
(deftest sublis.1
  (check-sublis '((a b) g (d e 10 g h) 15 . g)
sds's avatar
sds committed
12
                '((e . e2) (g . 17)))
13 14 15 16
  ((a b) 17 (d e2 10 17 h) 15 . 17))

(deftest sublis.2
  (check-sublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b)))
sds's avatar
sds committed
17 18
                '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b)))
                :test #'equal)
19 20 21 22
  (f6 10 (f4 (f3 (f2 a b) (f1 a p)) (f1 a b))))

(deftest sublis.3
  (check-sublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40))))
sds's avatar
sds committed
23
                '((30 . "foo")))
24 25 26 27
  (10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40)))))

(deftest sublis.4
  (check-sublis (sublis
sds's avatar
sds committed
28 29 30 31 32
                 (copy-tree '((a . 2) (b . 4) (c . 1)))
                 (copy-tree '(a b c d e (a b c a d b) f)))
                '((t . "yes"))
                :key #'(lambda (x) (and (typep x 'integer)
                                        (evenp x))))
33 34 35 36
  ("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f))

(deftest sublis.5
  (check-sublis '("fee" (("fee" "Fie" "foo"))
sds's avatar
sds committed
37 38
                  fie ("fee" "fie"))
                `((,(copy-seq "fie") . #\f)))
39 40 41 42
  ("fee" (("fee" "Fie" "foo")) fie ("fee" "fie")))

(deftest sublis.6
  (check-sublis '("fee" fie (("fee" "Fie" "foo") 1)
sds's avatar
sds committed
43 44 45
                  ("fee" "fie"))
                `((,(copy-seq "fie") . #\f))
                :test 'equal)
46 47 48 49
  ("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f)))

(deftest sublis.7
  (check-sublis '(("aa" a b)
sds's avatar
sds committed
50 51 52 53 54 55 56
                  (z "bb" d)
                  ((x . "aa")))
                `((,(copy-seq "aa") . 1)
                  (,(copy-seq "bb") . 2))
                :test 'equal
                :key #'(lambda (x) (if (consp x) (car x)
                                     '*not-present*)))
57 58 59 60 61
  (1 (z . 2) ((x . "aa"))))

;; Check that a null key arg is ignored.

(deftest sublis.8
sds's avatar
sds committed
62
  (check-sublis
63 64 65 66 67
   '(1 2 a b)
   '((1 . 2) (a . b))
   :key nil)
  (2 2 b b))

68 69
(deftest sublis.9
  (check-sublis  (list 0 3 8 20)
sds's avatar
sds committed
70 71
                 '((1 . x) (5 . y) (10 . z))
                :test #'(lambda (x y) (and (realp x) (realp y) (< x y))))
72 73 74 75
  (x y z 20))

(deftest sublis.10
  (check-sublis  (list 0 3 8 20)
sds's avatar
sds committed
76 77 78
                 '((1 . x) (5 . y) (10 . z))
                :test-not
                #'(lambda (x y) (not (and (realp x) (realp y) (< x y)))))
79 80
  (x y z 20))

81 82
(defharmless sublis.test-and-test-not.1
  (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd)
sds's avatar
sds committed
83
           :test #'eql :test-not #'eql))
84 85 86

(defharmless sublis.test-and-test-not.2
  (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd)
sds's avatar
sds committed
87
           :test-not #'eql :test #'eql))
88

89 90 91 92 93 94
;;; Order of argument evaluation
(deftest sublis.order.1
  (let ((i 0) w x y z)
    (values
     (sublis
      (progn (setf w (incf i))
sds's avatar
sds committed
95
             '((a . z)))
96
      (progn (setf x (incf i))
sds's avatar
sds committed
97
             (copy-tree '(a b c d)))
98 99 100 101 102 103 104 105 106 107 108
      :test (progn (setf y (incf i)) #'eql)
      :key (progn (setf z (incf i)) #'identity))
     i w x y z))
  (z b c d)
  4 1 2 3 4)

(deftest sublis.order.2
  (let ((i 0) w x y z)
    (values
     (sublis
      (progn (setf w (incf i))
sds's avatar
sds committed
109
             '((a . z)))
110
      (progn (setf x (incf i))
sds's avatar
sds committed
111
             (copy-tree '(a b c d)))
112 113 114 115 116 117 118
      :key (progn (setf y (incf i)) #'identity)
      :test-not (progn (setf z (incf i)) (complement #'eql))
      )
     i w x y z))
  (z b c d)
  4 1 2 3 4)

pfdietz's avatar
pfdietz committed
119 120 121 122
;;; Const fold tests

(def-fold-test sublis.fold.1 (sublis '((a . b)) '(a x y . a)))

123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147

;;; Keyword tests

(deftest sublis.allow-other-keys.1
  (sublis nil 'a :bad t :allow-other-keys t)
  a)

(deftest sublis.allow-other-keys.2
  (sublis nil 'a :allow-other-keys t :bad t)
  a)

(deftest sublis.allow-other-keys.3
  (sublis nil 'a :allow-other-keys t)
  a)

(deftest sublis.allow-other-keys.4
  (sublis nil 'a :allow-other-keys nil)
  a)

(deftest sublis.allow-other-keys.5
  (sublis nil 'a :allow-other-keys t :allow-other-keys t :bad t)
  a)

(deftest sublis.keywords.6
  (sublis '((1 . a)) (list 0 1 2) :key #'(lambda (x) (if (numberp x) (1+ x) x))
sds's avatar
sds committed
148
          :key #'identity)
149 150 151 152 153 154
  (a 1 2))


;; Argument error cases

(deftest sublis.error.1
155 156
  (signals-error (sublis) program-error)
  t)
157 158

(deftest sublis.error.2
159 160
  (signals-error (sublis nil) program-error)
  t)
161 162

(deftest sublis.error.3
163 164
  (signals-error (sublis nil 'a :test) program-error)
  t)
165 166

(deftest sublis.error.4
167 168
  (signals-error (sublis nil 'a :bad-keyword t) program-error)
  t)
169 170

(deftest sublis.error.5
171
  (signals-error (sublis '((a . 1) (b . 2))
sds's avatar
sds committed
172 173 174
                          (list 'a 'b 'c 'd)
                          :test #'identity)
                 program-error)
175
  t)
176 177

(deftest sublis.error.6
178
  (signals-error (sublis '((a . 1) (b . 2))
sds's avatar
sds committed
179 180 181
                          (list 'a 'b 'c 'd)
                          :key #'cons)
                 program-error)
182
  t)
183 184

(deftest sublis.error.7
185
  (signals-error (sublis '((a . 1) (b . 2))
sds's avatar
sds committed
186 187 188
                          (list 'a 'b 'c 'd)
                          :test-not #'identity)
                 program-error)
189
  t)
190 191

(deftest sublis.error.8
192
  (signals-error (sublis '((a . 1) . bad)
sds's avatar
sds committed
193 194
                          (list 'a 'b 'c 'd))
                 type-error)
195
  t)
196 197 198

(deftest sublis.shared
  (let* ((shared-piece (list 'a 'b))
sds's avatar
sds committed
199
         (a (list shared-piece shared-piece)))
200 201
    (check-sublis a '((a . b) (b . a))))
  ((b a) (b a)))