From 360a665c227e9f72bb3cc9d4c5cab646aa0472bf Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Tue, 22 Oct 2002 05:36:04 +0000 Subject: [PATCH] Added more tests for cons-related entities, particularly deeper checks of ordering/subform evaluation for accessors. --- ansi-tests/cons-test-01.lsp | 2 +- ansi-tests/cons-test-04.lsp | 12 +++++++ ansi-tests/cons-test-05.lsp | 60 ++++++++++++++++++++++---------- ansi-tests/cons-test-18.lsp | 68 ++++++++++++++++++++++++------------- 4 files changed, 99 insertions(+), 43 deletions(-) diff --git a/ansi-tests/cons-test-01.lsp b/ansi-tests/cons-test-01.lsp index cf278403..d573cfa8 100644 --- a/ansi-tests/cons-test-01.lsp +++ b/ansi-tests/cons-test-01.lsp @@ -103,7 +103,7 @@ 'union 'nunion )) -;; All the cons functions have a fnuction binding +;; All the cons functions have a function binding (deftest function-bound-cons-fns (loop diff --git a/ansi-tests/cons-test-04.lsp b/ansi-tests/cons-test-04.lsp index 72bf05df..17776160 100644 --- a/ansi-tests/cons-test-04.lsp +++ b/ansi-tests/cons-test-04.lsp @@ -13,6 +13,8 @@ ;;; There will be a separate test suite ;;; for ACCESSORS x SETF-like macros +;;; See also places.lsp + (deftest push-1 (let ((x nil)) (push 'a x)) @@ -47,6 +49,14 @@ (list x y))) (nil nil)) +;;; Confirm argument is executed just once. +(deftest pop-3 + (let ((i 0) + (a (vector (list 'a 'b 'c)))) + (pop (aref a (progn (incf i) 0))) + (values a i)) + #((b c)) 1) + (deftest push-and-pop (let* ((x (copy-tree '(a b))) (y x)) @@ -59,6 +69,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; pushnew +;;; See also places.lsp + (deftest pushnew-1 (let ((x nil)) (let ((y (pushnew 'a x))) diff --git a/ansi-tests/cons-test-05.lsp b/ansi-tests/cons-test-05.lsp index e6ab4079..1e43dd2e 100644 --- a/ansi-tests/cons-test-05.lsp +++ b/ansi-tests/cons-test-05.lsp @@ -47,6 +47,7 @@ (eqt (setf (rest x) 'd) 'd) x)) (a . d)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; setting of C*R accessors @@ -69,12 +70,21 @@ (symbol-name fn) "-SET") :cl-test) - (let ((x (create-c*r-test ,level))) + (let ((x (create-c*r-test ,level)) + (y (list (create-c*r-test ,level))) + (i 0)) (and - (setf (,fn x) 'a) - (eql (,fn x) 'a) + (setf (,fn (progn (incf i) x)) 'a) + (eqlt (,fn x) 'a) + (eqlt i 1) (setf (,fn x) 'none) - (equal x (create-c*r-test ,level)) + (equalt x (create-c*r-test ,level)) + (setf (,fn (progn (incf i) (car y))) 'a) + (eqlt (,fn (car y)) 'a) + (eqlt i 2) + (setf (,fn (car y)) 'none) + (null (cdr y)) + (equalt (car y) (create-c*r-test ,level)) )) t)))) @@ -89,19 +99,30 @@ (symbol-name fn) "-SET") :cl-test) - (let ((x (make-list 20 :initial-element nil))) + (let* ((x (make-list 20 :initial-element nil)) + (y (list (copy-list x))) + (cnt 0)) (and - (setf (,fn x) 'a) + (setf (,fn (progn (incf cnt) x)) 'a) + (eqlt cnt 1) (loop for i from 1 to 20 do (when (and (not (eql i ,len)) (nth (1- i) x)) (return nil)) finally (return t)) - (eql (,fn x) 'a) - (nth ,(1- len) x))) - a))) - + (setf (,fn (car y)) 'a) + (loop + for i from 1 to 20 + do (when (and (not (eql i ,len)) + (nth (1- i) (car y))) + (return nil)) + finally (return t)) + (eqlt (,fn x) 'a) + (eqlt (nth ,(1- len) x) 'a) + (eqlt (,fn (car y)) 'a) + (nth ,(1- len) (car y)))) + a))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; nth @@ -126,12 +147,15 @@ (error (c) c)) t) -#| +;;; Test side effects, evaluation order in assignment to NTH (deftest nth-3 - (catch-type-error (nth -1 (copy-tree '(a b c)))) - type-error) - -(deftest nth-4 - (catch-type-error (nth 'a (copy-tree '(a b c)))) - type-error) -|# + (let ((i 0) + (x (list 'a 'b 'c 'd)) + y z) + (and + (eqlt (setf (nth (setf y (incf i)) x) (progn (setf z (incf i)) 'z)) + 'z) + (eqlt y 1) + (eqlt z 2) + x)) + (a z c d)) diff --git a/ansi-tests/cons-test-18.lsp b/ansi-tests/cons-test-18.lsp index ff9971d8..feb0dee7 100644 --- a/ansi-tests/cons-test-18.lsp +++ b/ansi-tests/cons-test-18.lsp @@ -89,10 +89,10 @@ (setf (getf p 'c) 3) ;; Must check that only a, b, c have properties (and - (eql (getf p 'a) 1) - (eql (getf p 'b) 2) - (eql (getf p 'c) 3) - (eql + (eqlt (getf p 'a) 1) + (eqlt (getf p 'b) 2) + (eqlt (getf p 'c) 3) + (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b c)))) @@ -105,9 +105,9 @@ (setf (getf p 'a) 3) ;; Must check that only a, b have properties (and - (eql (getf p 'a) 3) - (eql (getf p 'b) 2) - (eql + (eqlt (getf p 'a) 3) + (eqlt (getf p 'b) 2) + (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b)))) @@ -120,10 +120,10 @@ (setf (getf p 'c 17) 3) ;; Must check that only a, b, c have properties (and - (eql (getf p 'a) 1) - (eql (getf p 'b) 2) - (eql (getf p 'c) 3) - (eql + (eqlt (getf p 'a) 1) + (eqlt (getf p 'b) 2) + (eqlt (getf p 'c) 3) + (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b c)))) @@ -136,9 +136,9 @@ (setf (getf p 'a 17) 3) ;; Must check that only a, b have properties (and - (eql (getf p 'a) 3) - (eql (getf p 'b) 2) - (eql + (eqlt (getf p 'a) 3) + (eqlt (getf p 'b) 2) + (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b)))) @@ -152,9 +152,9 @@ (setf (getf p 'a (progn (setf foo t) 0)) 3) ;; Must check that only a, b have properties (and - (eql (getf p 'a) 3) - (eql (getf p 'b) 2) - (eql + (eqlt (getf p 'a) 3) + (eqlt (getf p 'b) 2) + (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b)))) @@ -162,14 +162,34 @@ foo)) t) +(deftest setf-getf-6 + (let ((p (list (copy-list '(a 1 b 2)))) + (cnt1 0) (cnt2 0)) + (setf (getf (car (progn (incf cnt1) p)) 'c) + (progn (incf cnt2) 3)) + ;; Must check that only a, b, c have properties + (and + (eqlt cnt1 1) + (eqlt cnt2 1) + (eqlt (getf (car p) 'a) 1) + (eqlt (getf (car p) 'b) 2) + (eqlt (getf (car p) 'c) 3) + (eqlt + (loop + for ptr on (car p) by #'cddr count + (not (member (car ptr) '(a b c)))) + 0) + t)) + t) + (deftest incf-getf-1 (let ((p (copy-list '(a 1 b 2)))) (incf (getf p 'b)) ;; Must check that only a, b have properties (and - (eql (getf p 'a) 1) - (eql (getf p 'b) 3) - (eql + (eqlt (getf p 'a) 1) + (eqlt (getf p 'b) 3) + (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b)))) @@ -182,10 +202,10 @@ (incf (getf p 'c 19)) ;; Must check that only a, b have properties (and - (eql (getf p 'a) 1) - (eql (getf p 'b) 2) - (eql (getf p 'c) 20) - (eql + (eqlt (getf p 'a) 1) + (eqlt (getf p 'b) 2) + (eqlt (getf p 'c) 20) + (eqlt (loop for ptr on p by #'cddr count (not (member (car ptr) '(a b c)))) -- GitLab