/[gcl]/gcl/ansi-tests/cons-test-05.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/cons-test-05.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by pfdietz, Thu Oct 17 13:16:56 2002 UTC revision 1.3 by pfdietz, Tue Oct 22 05:36:04 2002 UTC
# Line 47  Line 47 
47         (eqt (setf (rest x) 'd) 'd)         (eqt (setf (rest x) 'd) 'd)
48         x))         x))
49    (a . d))    (a . d))
50    
51  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
52  ;;; setting of C*R accessors  ;;; setting of C*R accessors
53    
# Line 69  Line 70 
70                              (symbol-name fn)                              (symbol-name fn)
71                              "-SET")                              "-SET")
72                            :cl-test)                            :cl-test)
73                     (let ((x (create-c*r-test ,level)))                     (let ((x (create-c*r-test ,level))
74                             (y (list (create-c*r-test ,level)))
75                             (i 0))
76                       (and                       (and
77                        (setf (,fn x) 'a)                        (setf (,fn (progn (incf i) x)) 'a)
78                        (eql (,fn x) 'a)                        (eqlt (,fn x) 'a)
79                          (eqlt i 1)
80                        (setf (,fn x) 'none)                        (setf (,fn x) 'none)
81                        (equal x (create-c*r-test ,level))                        (equalt x (create-c*r-test ,level))
82                          (setf (,fn (progn (incf i) (car y))) 'a)
83                          (eqlt (,fn (car y)) 'a)
84                          (eqlt i 2)
85                          (setf (,fn (car y)) 'none)
86                          (null (cdr y))
87                          (equalt (car y) (create-c*r-test ,level))
88                        ))                        ))
89                   t))))                   t))))
90    
# Line 89  Line 99 
99                       (symbol-name fn)                       (symbol-name fn)
100                       "-SET")                       "-SET")
101                     :cl-test)                     :cl-test)
102              (let ((x (make-list 20 :initial-element nil)))              (let* ((x (make-list 20 :initial-element nil))
103                       (y (list (copy-list x)))
104                       (cnt 0))
105                (and                (and
106                 (setf (,fn x) 'a)                 (setf (,fn (progn (incf cnt) x)) 'a)
107                   (eqlt cnt 1)
108                 (loop                 (loop
109                     for i from 1 to 20                     for i from 1 to 20
110                     do (when (and (not (eql i ,len))                     do (when (and (not (eql i ,len))
111                                   (nth (1- i) x))                                   (nth (1- i) x))
112                          (return nil))                          (return nil))
113                     finally (return t))                     finally (return t))
114                 (eql (,fn x) 'a)                 (setf (,fn (car y)) 'a)
115                 (nth ,(1- len) x)))                 (loop
116            a)))                     for i from 1 to 20
117                       do (when (and (not (eql i ,len))
118                                     (nth (1- i) (car y)))
119                            (return nil))
120                       finally (return t))
121                   (eqlt (,fn x) 'a)
122                   (eqlt (nth ,(1- len) x) 'a)
123                   (eqlt (,fn (car y)) 'a)
124                   (nth ,(1- len) (car y))))
125                a)))
126    
127  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
128  ;;; nth  ;;; nth
# Line 126  Line 147 
147      (error (c) c))      (error (c) c))
148    t)    t)
149    
150  #|  ;;; Test side effects, evaluation order in assignment to NTH
151  (deftest nth-3  (deftest nth-3
152    (catch-type-error (nth -1 (copy-tree '(a b c))))    (let ((i 0)
153    type-error)          (x (list 'a 'b 'c 'd))
154                      y z)
155  (deftest nth-4      (and
156    (catch-type-error (nth 'a (copy-tree '(a b c))))       (eqlt (setf (nth (setf y (incf i)) x) (progn (setf z (incf i)) 'z))
157    type-error)             'z)
158  |#       (eqlt y 1)
159         (eqlt z 2)
160         x))
161      (a z c d))

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26