cons-test-05.lsp 4.2 KB
Newer Older
1 2 3 4 5 6 7
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Mar 28 07:34:08 1998
;;;; Contains:  Testing of CL Features related to "CONS", part 5

(in-package :cl-test)

8 9
(compile-and-load "cons-aux.lsp")

10 11 12 13 14 15 16
(defparameter *cons-accessors*
  '(first second third fourth fifth sixth seventh eighth ninth tenth
    car cdr caar cadr cdar cddr
    caaar caadr cadar caddr cdaar cdadr cddar cdddr
    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr))

17 18 19 20
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; first, ..., tenth

(deftest first-etc-1
21 22
  (let ((x (loop for i from 1 to 20 collect i)))
    (list (first x)
sds's avatar
sds committed
23 24 25 26 27 28 29 30 31
          (second x)
          (third x)
          (fourth x)
          (fifth x)
          (sixth x)
          (seventh x)
          (eighth x)
          (ninth x)
          (tenth x)))
32 33 34
  (1 2 3 4 5 6 7 8 9 10))

(deftest first-etc-2
35 36 37 38 39 40 41 42 43 44 45 46 47
  (let ((x (make-list 15 :initial-element 'a)))
    (and
     (eql (setf (first x) 1) 1)
     (eql (setf (second x) 2) 2)
     (eql (setf (third x) 3) 3)
     (eql (setf (fourth x) 4) 4)
     (eql (setf (fifth x) 5) 5)
     (eql (setf (sixth x) 6) 6)
     (eql (setf (seventh x) 7) 7)
     (eql (setf (eighth x) 8) 8)
     (eql (setf (ninth x) 9) 9)
     (eql (setf (tenth x) 10) 10)
     x))
48 49 50
  (1 2 3 4 5 6 7 8 9 10 a a a a a))

(deftest rest-set-1
51 52 53 54
  (let ((x (list 'a 'b 'c)))
    (and
     (eqt (setf (rest x) 'd) 'd)
     x))
55
  (a . d))
56

57 58 59 60
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; setting of C*R accessors

(loop
61
 for fn in '(car cdr caar cadr cdar cddr
sds's avatar
sds committed
62 63 64
                 caaar caadr cadar caddr cdaar cdadr cddar cdddr
                 caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
                 cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)
65 66 67
 do
 (let ((level (- (length (symbol-name fn)) 2)))
   (eval `(deftest ,(intern
sds's avatar
sds committed
68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88
                     (concatenate 'string
                                  (symbol-name fn)
                                  "-SET")
                     :cl-test)
            (let ((x (create-c*r-test ,level))
                  (y (list (create-c*r-test ,level)))
                  (i 0))
              (and
               (setf (,fn (progn (incf i) x)) 'a)
               (eqlt (,fn x) 'a)
               (eqlt i 1)
               (setf (,fn x) 'none)
               (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 90 91

(loop
 for (fn len) in '((first 1) (second 2) (third 3) (fourth 4)
sds's avatar
sds committed
92 93
                   (fifth 5) (sixth 6) (seventh 7) (eighth 8)
                   (ninth 9) (tenth 10))
94 95 96
 do
 (eval
  `(deftest ,(intern
sds's avatar
sds committed
97 98 99 100
              (concatenate 'string
                           (symbol-name fn)
                           "-SET")
              :cl-test)
101
     (let* ((x (make-list 20 :initial-element nil))
sds's avatar
sds committed
102 103
            (y (list (copy-list x)))
            (cnt 0))
104
       (and
sds's avatar
sds committed
105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123
        (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))
        (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))))
124
     a)))
125

126
;; set up program-error tests
127 128 129

(loop for name in *cons-accessors*
      do (eval
sds's avatar
sds committed
130 131 132 133 134
          `(deftest ,(intern (concatenate 'string (symbol-name name)
                                          ".ERROR.NO-ARGS")
                             :cl-test)
             (signals-error (,name) program-error)
             t))
135
      do (eval
sds's avatar
sds committed
136 137 138 139 140
          `(deftest ,(intern (concatenate 'string (symbol-name name)
                                          ".ERROR.EXCESS-ARGS")
                             :cl-test)
             (signals-error (,name nil nil) program-error)
             t)))