diff --git a/cons/assoc-if.lsp b/cons/assoc-if.lsp new file mode 100644 index 0000000000000000000000000000000000000000..2372b92a017ce34505a8646e3f3bd21726ea8cdf --- /dev/null +++ b/cons/assoc-if.lsp @@ -0,0 +1,179 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:27:57 2003 +;;;; Contains: Tests of ASSOC-IF + +(in-package :cl-test) + +(deftest assoc-if.1 + (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if #'evenp x))) + (and + (check-scaffold-copy x xcopy) + (eqt result (third x)) + result)) + (6 . c)) + +(deftest assoc-if.2 + (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if #'oddp x :key #'1+))) + (and + (check-scaffold-copy x xcopy) + (eqt result (third x)) + result)) + (6 . c)) + +(deftest assoc-if.3 + (let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if #'evenp x))) + (and + (check-scaffold-copy x xcopy) + (eqt result (fourth x)) + result)) + (6 . c)) + +(deftest assoc-if.4 + (assoc-if #'null '((a . b) nil (c . d) (nil . e) (f . g))) + (nil . e)) + +(deftest assoc-if.5 + (let () (assoc-if #'null '((a . b) nil (c . d) (nil . e) (f . g)))) + (nil . e)) + + +;;; Order of argument evaluation + +(deftest assoc-if.order.1 + (let ((i 0) x y) + (values + (assoc-if (progn (setf x (incf i)) #'null) + (progn (setf y (incf i)) + '((a . 1) (b . 2) (nil . 17) (d . 4)))) + i x y)) + (nil . 17) 2 1 2) + +(deftest assoc-if.order.2 + (let ((i 0) x y z) + (values + (assoc-if (progn (setf x (incf i)) #'null) + (progn (setf y (incf i)) + '((a . 1) (b . 2) (nil . 17) (d . 4))) + :key (progn (setf z (incf i)) #'null)) + i x y z)) + (a . 1) 3 1 2 3) + +;;; Keyword tests + +(deftest assoc-if.allow-other-keys.1 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :bad t :allow-other-keys t) + (nil . 2)) + +(deftest assoc-if.allow-other-keys.2 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) + :allow-other-keys t :also-bad t) + (nil . 2)) + +(deftest assoc-if.allow-other-keys.3 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) + :allow-other-keys t :also-bad t :key #'not) + (a . 1)) + +(deftest assoc-if.allow-other-keys.4 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t) + (nil . 2)) + +(deftest assoc-if.allow-other-keys.5 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :allow-other-keys nil) + (nil . 2)) + +(deftest assoc-if.keywords.6 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :key #'identity :key #'null) + (nil . 2)) + +(deftest assoc-if.keywords.7 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :key nil :key #'null) + (nil . 2)) + +;;; Macro env tests + +(deftest assoc-if.env.1 + (macrolet + ((%m (z) z)) + (let ((alist '((1 . a) (3 . b) (6 . c) (8 . d) (-1 . e)))) + (values + (assoc-if (expand-in-current-env (%m 'evenp)) alist) + (assoc-if (expand-in-current-env (%m #'evenp)) alist) + (assoc-if #'evenp (expand-in-current-env (%m alist))) + (assoc-if 'oddp alist (expand-in-current-env (%m :key)) '1+) + (assoc-if 'oddp alist :key (expand-in-current-env (%m #'1+))) + ))) + (6 . c) + (6 . c) + (6 . c) + (6 . c) + (6 . c)) + +;;; Error cases + +(deftest assoc-if.error.1 + (signals-error (assoc-if) program-error) + t) + +(deftest assoc-if.error.2 + (signals-error (assoc-if #'null) program-error) + t) + +(deftest assoc-if.error.3 + (signals-error (assoc-if #'null nil :bad t) + program-error) + t) + +(deftest assoc-if.error.4 + (signals-error (assoc-if #'null nil :key) + program-error) + t) + +(deftest assoc-if.error.5 + (signals-error (assoc-if #'null nil 1 1) + program-error) + t) + +(deftest assoc-if.error.6 + (signals-error (assoc-if #'null nil :bad t :allow-other-keys nil) + program-error) + t) + +(deftest assoc-if.error.7 + (signals-error (assoc-if #'cons '((a b)(c d))) + program-error) + t) + +(deftest assoc-if.error.8 + (signals-error (assoc-if #'identity '((a b)(c d)) :key #'cons) + program-error) + t) + +(deftest assoc-if.error.9 + (signals-type-error x 'a (assoc-if #'car '((a b)(c d)))) + t) + +(deftest assoc-if.error.10 + (signals-type-error x 'a (assoc-if #'identity '((a b)(c d)) :key #'car)) + t) + +(deftest assoc-if.error.11 + (signals-error (assoc-if #'null '((a . b) . c)) + type-error) + t) + +(deftest assoc-if.error.12 + (signals-error (assoc-if #'null '((a . b) :bad (c . d))) + type-error) + t) + +(deftest assoc-if.error.13 + (signals-type-error x 'y (assoc-if #'null x)) + t)