pair-mutation.k (7305B)
1 ;; check.k & test-helpers.k should be loaded 2 3 ;;; 4 ;;; Basic Functionality 5 ;;; 6 7 ;; set-car! & set-cdr! 8 ($let ((pair (cons () ()))) 9 ($check-predicate (inert? (set-car! pair 1))) 10 ($check-predicate (inert? (set-cdr! pair 2))) 11 ($check equal? (car pair) 1) 12 ($check equal? (cdr pair) 2) 13 (set-car! pair pair) 14 (set-cdr! pair pair) 15 ($check eq? (car pair) pair) 16 ($check eq? (cdr pair) pair)) 17 18 ;; copy-es-immutable 19 ($let* ((orig (list (cons 1 2) (cons 3 4))) 20 (copy (copy-es-immutable orig)) 21 (copy2 (copy-es-immutable copy))) 22 ($check equal? orig copy) 23 ($check-predicate (mutable-pair? orig)) 24 ($check-predicate (immutable-pair? copy)) 25 ($check equal? orig copy2) 26 ($check-predicate (immutable-pair? copy2))) 27 28 ;; encycle! 29 ($check equal? ($let ((l 1)) (encycle! l 0 0) l) 30 1) 31 ($check equal? ($let ((l (list 1 2 3 4 5))) (encycle! l 4 0) l) 32 (list 1 2 3 4 5)) 33 ($check equal? ($let ((l (list 1 2 3 4 5))) (encycle! l 2 3) l) 34 (list 1 2 . #0=(3 4 5 . #0#))) 35 ($check equal? ($let ((l (list* 1 2 3 4 5))) (encycle! l 0 3) l) 36 (list . #0=(1 2 3 . #0#))) 37 38 ;; list-set! 39 ($check-predicate (inert? (list-set! (list 0 1 2 3) 0 10))) 40 ($check equal? ($let ((l (list 0 1 2 3))) 41 (list-set! l 1 10) 42 (list-set! l 3 30) 43 l) 44 (list 0 10 2 30)) 45 ($check equal? ($let ((l (list 0 . #1=(1 2 . #1#)))) 46 (list-set! l 1 10) 47 (list-set! l 4 20) 48 l) 49 (list 0 . #2=(10 20 . #2#))) 50 ;; see kgpair_mut.c for rationale on allowing 51 ;; improper lists as argument to list-set! 52 ($check equal? ($let ((l (list* 0 1 2 3))) 53 (list-set! l 1 10) 54 (list-set! l 2 20) 55 l) 56 (list* 0 10 20 3)) 57 58 ;; append! 59 ($check-predicate (inert? (append! (list 1) (list 2)))) 60 61 ($let () 62 ($define! l1 (list 1 2)) 63 ($define! l2 (list 3 4)) 64 ($define! l3 (list 5 6)) 65 66 ($check equal? ($sequence (append! l1 ()) l1) (list 1 2)) 67 ($check equal? ($sequence (append! l1 () ()) l1) (list 1 2)) 68 ($check equal? ($sequence (append! l1 l2) l1) (list 1 2 3 4)) 69 ($check equal? ($sequence (append! l1 () () l3 ()) l1) (list 1 2 3 4 5 6)) 70 71 ($define! l1 (list 1 2)) 72 ($define! l2 (list 3 4)) 73 ($define! l3 (list . #0=(5 6 . #0#))) 74 75 (append! l1 l2 l3) 76 ($check equal? l1 (list 1 2 3 4 . #2=(5 6 . #2#))) 77 ($check eq? (cddddr l1) l3) 78 79 ($define! l1 (list 1 2)) 80 ($define! l2 (list 3 4)) 81 ($define! l3 (list 5 6)) 82 83 ($check equal? 84 ($sequence (append! l1 . #3=(l2 l3 . #3#)) l1) 85 (list 1 2 . #4=(3 4 5 6 . #4#))) 86 87 ($define! l1 (list 1 2)) 88 ($define! l2 (list 3 4)) 89 ($define! l3 (list 5 6)) 90 91 ($check equal? 92 ($sequence (append! l1 l2 l3 . #5=(() () . #5#)) l1) 93 (list 1 2 3 4 5 6)) 94 95 ($define! l1 (list 1 2)) 96 ($define! l2 (list 3 4)) 97 ($define! l3 (list 5 6)) 98 99 ($check equal? 100 ($sequence (append! l1 () . #6=(() l2 () l3 () . #6#)) l1) 101 (list 1 2 . #7=(3 4 5 6 . #7#)))) 102 103 ;; copy-es 104 ($let* ((orig (list (cons 1 2) (cons 3 4))) 105 (copy (copy-es orig))) 106 ($check equal? orig copy) 107 ($check-predicate (mutable-pair? orig)) 108 ($check-predicate (mutable-pair? copy)) 109 ($check not-eq? orig copy)) 110 111 ;; assq 112 ($check equal? (assq #inert ()) ()) 113 ($check equal? (assq 3 (list (list 1 10) (list 2 20))) ()) 114 ($check equal? (assq 1 (list (list 1 10) (list 2 20))) (list 1 10)) 115 ($check equal? 116 (assq 1 (list . #0=((list 1 10) (list 2 20) (list 1 15) . #0#))) 117 (list 1 10)) 118 ($check equal? 119 (assq 4 (list . #0=((list 1 10) (list 2 20) (list 1 15) . #0#))) 120 ()) 121 ($check equal? 122 (assq (list 1) (list (list (list 1) 1) (list (list 2) 2))) 123 ()) 124 125 ;; memq 126 ($check-predicate (memq? 1 (list 1 2))) 127 ($check-predicate (memq? 2 (list 1 2))) 128 ($check-not-predicate (memq? 1 ())) 129 ($check-not-predicate (memq? 3 (list 1 2))) 130 ($check-not-predicate (memq? (list 1) (list (list 1) 2))) 131 ($check-not-predicate (memq? (list 2) (list 1 (list 2)))) 132 ($check-predicate 133 (memq? 3 (list . #0=(1 2 3 . #0#)))) 134 ($check-not-predicate 135 (memq? 4 (list . #0=(1 2 1 . #0#)))) 136 137 138 ;;; 139 ;;; Error Checking and Robustness 140 ;;; 141 142 ;; set-car! & set-cdr! 143 ($check-error (set-car!)) 144 ($check-error (set-car! (cons () ()))) 145 ($check-error (set-car! (cons () ()) #inert #inert)) 146 147 ($check-error (set-car! () #inert)) 148 ($check-error (set-car! 1 #inert)) 149 ($check-error (set-car! (get-current-environment) #inert)) 150 ($check-error (set-car! ($lambda #ignore) #inert)) 151 ($check-error (set-car! ($vau #ignore #ignore) #inert)) 152 153 ($check-error (set-cdr!)) 154 ($check-error (set-cdr! (cons () ()))) 155 ($check-error (set-cdr! (cons () ()) #inert #inert)) 156 157 ($check-error (set-cdr! () #inert)) 158 ($check-error (set-cdr! 1 #inert)) 159 ($check-error (set-cdr! (get-current-environment) #inert)) 160 ($check-error (set-cdr! ($lambda #ignore) #inert)) 161 ($check-error (set-cdr! ($vau #ignore #ignore) #inert)) 162 163 ($let ((imm-pair (copy-es-immutable (cons () ())))) 164 ($check-error (set-car! imm-pair #inert)) 165 ($check-error (set-cdr! imm-pair #inert)) 166 ($check-predicate (null? (car imm-pair))) 167 ($check-predicate (null? (cdr imm-pair)))) 168 169 ;; copy-es-immutable 170 ($check-error (copy-es-immutable)) 171 ($check-error (copy-es-immutable (cons () ()) (cons () ()))) 172 173 ;; encycle! 174 ($check-error (encycle!)) 175 ($check-error (encycle! (list 1 2 3))) 176 ($check-error (encycle! (list 1 2 3) 1)) 177 ($check-error (encycle! (list 1 2 3) 1 2 3)) 178 179 ($check-error (encycle! (list 1 2 3) 2 2)) 180 ($check-error (encycle! (list 1 2 3) -1 2)) 181 ($check-error (encycle! (list 1 2 3) 0 -2)) 182 ($check-error (encycle! (list 1 2 3) 0 #e+infinity)) 183 184 ;; list-set! 185 ;; set-car! & set-cdr! 186 ($check-error (list-set!)) 187 ($check-error (list-set! (list 1))) 188 ($check-error (list-set! (list 1) 0)) 189 ($check-error (list-set! (list 1) 0 1 1)) 190 191 ($check-error (list-set! #inert 0 0)) 192 ($check-error (list-set! () 0 0)) 193 ($check-error (list-set! (list 1 2) 2 0)) 194 ($check-error (list-set! (list 1 2) -1 0)) 195 ($check-error (list-set! (list* 1 2 3) 2 0)) 196 197 ;; append! 198 ;; ASK does the report assert that the lists remains unmodified?? 199 ;; probably should for robust implementations 200 201 ($check-error (append!)) 202 ($check-error (append! ())) 203 ($check-error (append! (list . #0=(1 2 . #0#)) ())) 204 ($check-error (append! (list 1 2) 3 (list 4 5))) 205 ($check-error (append! (list 1 2) 3 ())) 206 207 ($check-error (append! ((unwrap list) . (1 2 . #0=(3))) 208 ((unwrap list) . (4 5 . #0#)) 209 ())) 210 211 ;; ASK if this is valid or not 212 ;; ($check-error (append! ((unwrap list) . (1 2 . #0=(3))) 213 ;; ((unwrap list) . (4 5 . #0#)))) 214 215 216 ;; copy-es 217 ($check-error (copy-es)) 218 ($check-error (copy-es (cons () ()) (cons () ()))) 219 220 ;; assq 221 ($check-error (assq)) 222 ($check-error (assq 2)) 223 ($check-error (assq 2 (list (list 1 1) (list 2 2)) ())) 224 ($check-error (assq . #0=(2 (list (list 1 1) (list 2 2)) . #0#))) 225 226 ($check-error (assq 2 (list* (list 1 1) 2))) 227 ($check-error (assq 2 (list* (list 1 1) (list 2 2) #inert))) 228 ($check-error (assq 4 (list (list 1 1) (list 2 2) #inert (list 4 4)))) 229 ($check-error (assq 2 (list (list 1 1) (list 2 2) #inert (list 4 4)))) 230 231 ;; memq 232 ($check-error (memq?)) 233 ($check-error (memq? 2)) 234 ($check-error (memq? 2 (list 1 2) ())) 235 ($check-error (memq? . #0=(2 (list 1 2) . #0#))) 236 237 ($check-error (memq? 2 (list* 1 2))) 238 ($check-error (memq? 2 (list* 1 2 3))) 239