/[gcl]/gcl/ansi-tests/vector-push-extend.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/vector-push-extend.lsp

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

revision 1.4 by pfdietz, Sat Jan 17 22:54:18 2004 UTC revision 1.5 by pfdietz, Sun Dec 12 02:43:24 2004 UTC
# Line 252  Line 252 
252    5 5 6 nil #(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0 0.0l0))    5 5 6 nil #(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0 0.0l0))
253    
254    
255    ;;; Tests on displaced arrays
256    
257    (deftest vector-push-extend.21
258      (let* ((a1 (make-array 10 :initial-element nil))
259             (a2 (make-array 6 :displaced-to a1
260                             :displaced-index-offset 2
261                             :fill-pointer 0)))
262        (values
263         (fill-pointer a2)
264         (map 'list #'identity a2)
265         (vector-push-extend 'foo a2)
266         (fill-pointer a2)
267         (map 'list #'identity a2)
268         (map 'list #'identity a1)))
269      0
270      ()
271      0
272      1
273      (foo)
274      (nil nil foo nil nil nil nil nil nil nil))
275    
276    (deftest vector-push-extend.22
277      (let* ((a1 (make-array 6 :initial-element nil))
278             (a2 (make-array 0 :displaced-to a1
279                             :displaced-index-offset 2
280                             :adjustable t
281                             :fill-pointer 0)))
282        (values
283         (fill-pointer a2)
284         (map 'list #'identity a2)
285         (vector-push-extend 'foo a2)
286         (fill-pointer a2)
287         (map 'list #'identity a2)
288         (map 'list #'identity a1)
289         (notnot (adjustable-array-p a2))
290         (multiple-value-list (array-displacement a2))
291         ))
292      0
293      ()
294      0
295      1
296      (foo)
297      (nil nil nil nil nil nil)
298      t
299      (nil 0))
300    
301    (deftest vector-push-extend.23
302      (let* ((a1 (make-array 10 :initial-element nil))
303             (a2 (make-array 6 :displaced-to a1
304                             :displaced-index-offset 2
305                             :adjustable t
306                             :fill-pointer 1)))
307        (values
308         (fill-pointer a2)
309         (map 'list #'identity a2)
310         (vector-push-extend 'foo a2)
311         (fill-pointer a2)
312         (map 'list #'identity a2)
313         (map 'list #'identity a1)
314         (notnot (adjustable-array-p a2))
315         (eqt (array-displacement a2) a1)
316         (nth-value 1 (array-displacement a2))
317         ))
318      1
319      (nil)
320      1
321      2
322      (nil foo)
323      (nil nil nil foo nil nil nil nil nil nil)
324      t
325      t
326      2)
327    
328    (deftest vector-push-extend.24
329      (let* ((a1 (make-array 4 :initial-element nil))
330             (a2 (make-array 2 :displaced-to a1
331                             :displaced-index-offset 2
332                             :adjustable t
333                             :fill-pointer 2)))
334        (values
335         (map 'list #'identity a1)
336         (map 'list #'identity a2)
337         (vector-push-extend 'foo a2 7)
338         (fill-pointer a2)
339         (map 'list #'identity a1)
340         (map 'list #'identity a2)
341         (array-dimension a2 0)
342         (notnot (adjustable-array-p a2))
343         (multiple-value-list (array-displacement a2))))
344      (nil nil nil nil)
345      (nil nil)
346      2
347      3
348      (nil nil nil nil)
349      (nil nil foo)
350      9
351      t
352      (nil 0))
353    
354    ;;; Integer vectors
355    
356    (deftest vector-push-extend.25
357      (loop for adj in '(nil t)
358            nconc
359            (loop for bits from 1 to 64
360                  for etype = `(unsigned-byte ,bits)
361                  for a1 = (make-array 10 :initial-element 0
362                                       :element-type etype)
363                  for a2 =(make-array 6
364                                      :element-type etype
365                                      :displaced-to a1
366                                      :displaced-index-offset 2
367                                      :adjustable adj
368                                      :fill-pointer 0)
369                  for result = (list (fill-pointer a2)
370                                     (map 'list #'identity a2)
371                                     (vector-push-extend 1 a2)
372                                     (fill-pointer a2)
373                                     (map 'list #'identity a2)
374                                     (map 'list #'identity a1))
375                  unless (equal result '(0 () 0 1 (1) (0 0 1 0 0 0 0 0 0 0)))
376                  collect (list etype adj result)))
377      nil)
378    
379    (deftest vector-push-extend.26
380      (loop for bits from 1 to 64
381            for etype = `(unsigned-byte ,bits)
382            for a1 = (make-array 8 :initial-element 0
383                                 :element-type etype)
384            for a2 = (make-array 6
385                                 :element-type etype
386                                 :displaced-to a1
387                                 :displaced-index-offset 2
388                                 :adjustable t
389                                 :fill-pointer 6)
390            for result = (list (fill-pointer a2)
391                               (map 'list #'identity a2)
392                               (vector-push-extend 1 a2)
393                               (fill-pointer a2)
394                               (map 'list #'identity a2)
395                               (map 'list #'identity a1)
396                               (notnot (adjustable-array-p a2))
397                               (multiple-value-list (array-displacement a1)))
398            unless (equal result '(6 (0 0 0 0 0 0) 6 7 (0 0 0 0 0 0 1)
399                                     (0 0 0 0 0 0 0 0) t (nil 0)))
400            collect (list etype result))
401      nil)
402    
403  ;;; Error tests  ;;; Error tests
404    

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5

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