diff --git a/ansi-tests/cons-test-01.lsp b/ansi-tests/cons-test-01.lsp index cf2784034a4139c6509d28f325f3e42cba6714d2..d573cfa824a7cb68891c345df1e3110703c3764f 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 72bf05df1adbcb16160a15b69dec2b8e969901c2..1777616005b7113e6e323e6f352b2c45d9b8b2b0 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 e6ab40794724e8a87461101f5933808824dc9eb6..1e43dd2e7607d55fca2ef4848774de4959bea8d5 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 ff9971d888aaee7887936bc06a65bc533eace2bb..feb0dee723a3acd6e869d24e848ed2daf8926b90 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))))