control.k (15245B)
1 ;; check.k & test-helpers.k should be loaded 2 3 ;;; 4 ;;; Basic Functionality 5 ;;; 6 7 ;; inert? 8 ($check-predicate (applicative? inert?)) 9 ($check-predicate (inert?)) 10 ($check-predicate (inert? #inert)) 11 ($check-predicate (inert? #inert #inert #inert)) 12 ($check-predicate (inert? #inert . #0=(#inert . #0#))) 13 14 ($check-not-predicate (inert? ((unwrap list) . symbol))) 15 ($check-not-predicate (inert? ())) 16 ($check-not-predicate (inert? (cons () ()))) 17 ($check-not-predicate (inert? #ignore)) 18 ($check-not-predicate (inert? (make-environment))) 19 ($check-not-predicate (inert? #t)) 20 ($check-not-predicate (inert? #f)) 21 ($check-not-predicate (inert? $vau)) 22 ($check-not-predicate (inert? wrap)) 23 ($check-not-predicate (inert? (call/cc ($lambda (c) c)))) 24 ($check-not-predicate (inert? ($let (((enc . #ignore) 25 (make-encapsulation-type))) 26 (enc #inert)))) 27 ($check-not-predicate (inert? (memoize #inert))) 28 ($check-not-predicate (inert? 1)) 29 ($check-not-predicate (inert? 1.0)) 30 ($check-not-predicate (inert? #e+infinity)) 31 ($check-not-predicate (inert? #i+infinity)) 32 ($check-not-predicate (inert? #undefined)) 33 ($check-not-predicate (inert? #real)) 34 ($check-not-predicate (inert? "string")) 35 ($check-not-predicate (inert? #\a)) 36 ($check-not-predicate (inert? (get-current-input-port))) 37 38 ;; basic eq?-ness 39 ($check eq? #inert #inert) 40 41 ;; basic equal?-ness and not? 42 ($check equal? #inert #inert) 43 44 ;; $if 45 ($check-predicate (operative? $if)) 46 ($check eq? ($if #t #t #f) #t) 47 ($check eq? ($if #f #t #f) #f) 48 ($check eq? ($if #t (get-current-environment) #f) (get-current-environment)) 49 ($check eq? ($if #f #t (get-current-environment)) (get-current-environment)) 50 ($let ((p (cons () ()))) 51 ($check eq? ($if (($vau #ignore env 52 (set-car! p env) 53 #t)) (car p) #f) 54 (get-current-environment))) 55 56 ;; $sequence 57 ($check-predicate (operative? $sequence)) 58 ($check eq? ($sequence) #inert) 59 ($check eq? ($sequence 1) 1) 60 ($check eq? ($sequence 1 2 3) 3) 61 ($check eq? ($sequence (get-current-environment)) (get-current-environment)) 62 ($check eq? ($sequence #inert #inert (get-current-environment)) 63 (get-current-environment)) 64 65 ($let ((p (cons 0 ()))) 66 ($check eq? 67 ($let/cc cont 68 ($sequence . #0=(($if (=? (car p) 3) 69 (apply-continuation cont #t) 70 (set-car! p (+ (car p) 1))) 71 . #0#))) 72 #t)) 73 74 ;; $cond 75 ($check-predicate (operative? $cond)) 76 ($check eq? ($cond) #inert) 77 ($check eq? ($cond (#f 1) (#f 2) (#f 3)) #inert) 78 ($check eq? ($cond (#t 1) (#t 2) (#t 3)) 1) 79 80 ($check eq? ($cond (#t (get-current-environment))) (get-current-environment)) 81 ($let ((p (cons () ()))) 82 ($check eq? 83 ($cond (#f) 84 (($sequence (set-car! p (get-current-environment)) 85 #t) 86 (car p)) 87 (#f)) 88 (get-current-environment))) 89 ($check eq? ($cond . #0=((#f) (#t 1) . #0#)) 1) 90 ($let ((p (cons 0 ()))) 91 ($check eq? 92 ($cond . #0=(((=? (car p) 3) 3) 93 (($sequence (set-car! p (+ (car p) 1)) 94 #f) 95 0) 96 (#f) 97 . #0#)) 98 3)) 99 100 101 ;; for-each 102 ($check-predicate (applicative? for-each)) 103 ($check eq? (for-each + (list 1 2 3 4)) #inert) 104 ($check eq? (for-each cons (list 1 2 3 4) (list 10 20 30 40)) #inert) 105 ($let ((p (cons () ()))) 106 ($check eq? 107 ($sequence (for-each (wrap ($vau #ignore env 108 (set-car! p env))) 109 (list 1)) 110 (car p)) 111 (get-current-environment))) 112 ($let ((p (cons 0 ()))) 113 ($check eq? 114 ($sequence (for-each ($lambda (x) 115 (set-car! p (+ (car p) x))) 116 (list 1 2 3 4)) 117 (car p)) 118 10)) 119 ($let ((p (cons 0 ()))) 120 ($check eq? 121 ($sequence (for-each ($lambda (x y ) 122 (set-car! p (+ (car p) x y))) 123 (list 1 2 3 4) 124 (list 10 20 30 40)) 125 (car p)) 126 110)) 127 128 ($let ((p (cons 0 ()))) 129 ($check eq? 130 ($let/cc cont 131 (for-each ($lambda (x) 132 ($if (=? (car p) 10) 133 (apply-continuation cont 10) 134 (set-car! p (+ (car p) 1)))) 135 (list 1 . #0=(2 3 4 . #0#)))) 136 #inert)) 137 138 ($let ((p (cons 0 ()))) 139 ($check eq? 140 ($sequence (for-each ($lambda ls 141 (set-car! p (finite-list? ls))) 142 . #0=((list 1 2 3 4) 143 (list 10 20 30 40) 144 . #0#)) 145 (car p)) 146 #f)) 147 148 149 ;; string-for-each 150 ($check-predicate (applicative? string-for-each)) 151 ($check eq? (string-for-each char-upcase "abcd") #inert) 152 ($check eq? (string-for-each char<? "abcd" "efgh") #inert) 153 154 ($let ((p (cons () ()))) 155 ($check eq? 156 ($sequence (string-for-each (wrap ($vau #ignore env 157 (set-car! p env))) 158 "a") 159 (car p)) 160 (get-current-environment))) 161 ($let ((p (cons 0 ()))) 162 ($check eq? 163 ($sequence (string-for-each ($lambda (x) 164 (set-car! p (+ (car p) 165 (char->integer x)))) 166 "abcd") 167 (car p)) 168 (apply + (map char->integer (string->list "abcd"))))) 169 ($let ((p (cons 0 ()))) 170 ($check eq? 171 ($sequence (string-for-each ($lambda (x y ) 172 (set-car! p (+ (car p) 173 (char->integer x) 174 (char->integer y)))) 175 "abc" 176 "def") 177 (car p)) 178 (apply + (map char->integer (string->list "abcdef"))))) 179 180 181 ($let ((p (cons 0 ()))) 182 ($check eq? 183 ($sequence (string-for-each ($lambda ls 184 (set-car! p (finite-list? ls))) 185 . #0=("abc" 186 "def" 187 . #0#)) 188 (car p)) 189 #f)) 190 191 192 ;; vector-for-each 193 ($check-predicate (applicative? vector-for-each)) 194 ($check eq? (vector-for-each + (vector 1 2 3)) #inert) 195 ($check eq? (vector-for-each <? (vector 1 2) (vector 3 4)) 196 #inert) 197 198 ($let ((p (cons () ()))) 199 ($check eq? 200 ($sequence (vector-for-each (wrap ($vau #ignore env 201 (set-car! p env))) 202 (vector 1)) 203 (car p)) 204 (get-current-environment))) 205 ($let ((p (cons 0 ()))) 206 ($check eq? 207 ($sequence (vector-for-each ($lambda (x) 208 (set-car! p (+ (car p) x))) 209 (vector 1 2 3 4)) 210 (car p)) 211 10)) 212 ($let ((p (cons 0 ()))) 213 ($check eq? 214 ($sequence (vector-for-each ($lambda (x y ) 215 (set-car! p (+ (car p) x y))) 216 (vector 1 2 3 4) 217 (vector 10 20 30 40)) 218 (car p)) 219 110)) 220 221 222 ($let ((p (cons 0 ()))) 223 ($check eq? 224 ($sequence (vector-for-each ($lambda ls 225 (set-car! p (finite-list? ls))) 226 . #0=((vector 1 2) 227 (vector 3 4) 228 . #0#)) 229 (car p)) 230 #f)) 231 232 ;; bytevector-for-each 233 ($check-predicate (applicative? bytevector-for-each)) 234 ($check eq? (bytevector-for-each + (bytevector 1 2 3)) #inert) 235 ($check eq? (bytevector-for-each <? (bytevector 1 2) (bytevector 3 4)) 236 #inert) 237 238 ($let ((p (cons () ()))) 239 ($check eq? 240 ($sequence (bytevector-for-each (wrap ($vau #ignore env 241 (set-car! p env))) 242 (bytevector 1)) 243 (car p)) 244 (get-current-environment))) 245 ($let ((p (cons 0 ()))) 246 ($check eq? 247 ($sequence (bytevector-for-each ($lambda (x) 248 (set-car! p (+ (car p) x))) 249 (bytevector 1 2 3 4)) 250 (car p)) 251 10)) 252 ($let ((p (cons 0 ()))) 253 ($check eq? 254 ($sequence (bytevector-for-each ($lambda (x y ) 255 (set-car! p (+ (car p) x y))) 256 (bytevector 1 2 3 4) 257 (bytevector 10 20 30 40)) 258 (car p)) 259 110)) 260 261 ($let ((p (cons 0 ()))) 262 ($check eq? 263 ($sequence (bytevector-for-each ($lambda ls 264 (set-car! p (finite-list? ls))) 265 . #0=((bytevector 1 2) 266 (bytevector 3 4) 267 . #0#)) 268 (car p)) 269 #f)) 270 271 ;; $when 272 ($check-predicate (operative? $when)) 273 ($check-predicate (inert? ($when #t))) 274 ($check-predicate (inert? ($when #f))) 275 ($check-predicate (inert? ($when #t 1))) 276 ($check-predicate (inert? ($when #f 1))) 277 ($check-predicate (inert? ($when #t 1 2))) 278 ($check-predicate (inert? ($when #f 1 2))) 279 280 ($let ((p (cons () ()))) 281 ($check equal? ($sequence ($when #f (set-car! p 1)) 282 (car p)) 283 ())) 284 285 ($let ((p (cons () ()))) 286 ($check eq? ($sequence ($when ($sequence 287 (set-car! p (get-current-environment)) 288 #f)) 289 (car p)) 290 (get-current-environment))) 291 292 ($let ((p (cons () ()))) 293 ($check eq? ($sequence ($when #t (set-car! p (get-current-environment))) 294 (car p)) 295 (get-current-environment))) 296 297 ;; check tail recursiveness 298 ($let ((p (cons 1 2))) 299 ($check-predicate ($sequence ($when #t ($let/cc cont1 300 (set-car! p cont1) 301 ($when #t 302 ($let/cc cont2 303 (set-cdr! p cont2))))) 304 (eq? (car p) (cdr p))))) 305 306 ;; $unless 307 ($check-predicate (operative? $unless)) 308 ($check-predicate (inert? ($unless #t))) 309 ($check-predicate (inert? ($unless #f))) 310 ($check-predicate (inert? ($unless #t 1))) 311 ($check-predicate (inert? ($unless #f 1))) 312 ($check-predicate (inert? ($unless #t 1 2))) 313 ($check-predicate (inert? ($unless #f 1 2))) 314 315 ($let ((p (cons () ()))) 316 ($check equal? ($sequence ($unless #t (set-car! p 1)) 317 (car p)) 318 ())) 319 320 ($let ((p (cons () ()))) 321 ($check eq? ($sequence ($unless ($sequence 322 (set-car! p (get-current-environment)) 323 #t)) 324 (car p)) 325 (get-current-environment))) 326 327 ($let ((p (cons () ()))) 328 ($check eq? ($sequence ($unless #f (set-car! p (get-current-environment))) 329 (car p)) 330 (get-current-environment))) 331 332 ;; check tail recursiveness 333 ($let ((p (cons 1 2))) 334 ($check-predicate ($sequence ($unless #f ($let/cc cont1 335 (set-car! p cont1) 336 ($unless #f 337 ($let/cc cont2 338 (set-cdr! p cont2))))) 339 (eq? (car p) (cdr p))))) 340 341 ;;; 342 ;;; Error Checking and Robustness 343 ;;; 344 345 ;; inert? 346 ($check-error (inert? #inert . #inert)) 347 ($check-error (inert? #t . #inert)) 348 349 ;; $if 350 ($check-error ($if)) 351 ($check-error ($if #t)) 352 353 ;; this short form isn't allowed in Kernel 354 ($check-error ($if #f #t)) 355 ($check-error ($if #t #t)) 356 357 ($check-error ($if #t #t #t #t)) 358 ($check-error ($if . #0=(#t . #0#))) 359 360 ($check-error ($if 0 #t #f)) 361 ($check-error ($if () #t #f)) 362 ($check-error ($if #inert #t #f)) 363 ($check-error ($if #ignore #t #f)) 364 ($check-error ($if (cons #t #f) #t #f)) 365 ($check-error ($if (cons #t #f) #t #f)) 366 367 ;; $sequence 368 ($check-error ($sequence . #inert)) 369 ($check-error ($sequence #inert #inert . #inert)) 370 371 ;; $cond 372 ($check-error ($cond . #inert)) 373 ($check-error ($cond (#t #t) . #inert)) 374 ($check-error ($cond #inert)) 375 ($check-error ($cond (1 1) (#t #t))) 376 377 ;; for-each 378 379 ($check-error (for-each)) 380 ($check-error (for-each list)) ; the list can't be empty 381 382 ($check-error (for-each list (list 1 2) (list 1 2 3))) 383 ($check-error (for-each list (list . #0=(1 2 . #0#)) (list 1 2 3))) 384 385 ($check-error (for-each list #inert)) 386 ($check-error (for-each #inert (list 1 2))) 387 ($check-error (for-each ((unwrap list) #inert) (list 1 2))) 388 389 ($check-error (for-each list (list 1 2) #inert)) 390 ($check-error (for-each cons (list 1 2))) 391 392 393 ;; string-for-each 394 ($check-error (string-for-each)) 395 ($check-error (string-for-each char-upcase)) ; the list can't be empty 396 397 ($check-error (string-for-each char<? "ab" "abc")) 398 399 ($check-error (string-for-each char-upcase #inert)) 400 ($check-error (string-for-each #inert "abc")) 401 ($check-error (string-for-each (unwrap char-upcase) "abc")) 402 403 ($check-error (string-for-each char<? "abc" #inert)) 404 ($check-error (string-for-each cons "abc")) 405 406 ;; vector-for-each 407 ($check-error (vector-for-each)) 408 ($check-error (vector-for-each char-upcase)) ; the list can't be empty 409 410 ($check-error (vector-for-each <? (vector 1 2) (vector 1 2 3))) 411 412 ($check-error (vector-for-each char-upcase #inert)) 413 ($check-error (vector-for-each #inert (vector 1 2))) 414 ($check-error (vector-for-each (unwrap char-upcase) (vector 1))) 415 416 ($check-error (vector-for-each <? (vector 1 2) #inert)) 417 ($check-error (vector-for-each cons (vector 1 2 3))) 418 419 ;; bytevector-for-each 420 ($check-error (bytevector-for-each)) 421 ($check-error (bytevector-for-each +)) ; the list can't be empty 422 423 ($check-error (bytevector-for-each <? (bytevector 1 2) 424 (bytevector 1 2 3))) 425 426 ($check-error (bytevector-for-each + #inert)) 427 ($check-error (bytevector-for-each #inert (bytevector 1 2 3))) 428 ($check-error (bytevector-for-each (unwrap char-upcase) 429 (bytevector 1 2))) 430 431 ($check-error (bytevector-for-each <? (bytevector 1 2) #inert)) 432 ($check-error (bytevector-for-each cons 433 (bytevector 1 2 3))) 434 435 436 ;; $when 437 ($check-error ($when)) 438 ($check-error ($when #t . 3)) 439 ($check-error ($when #f . 3)) 440 ($check-error ($when #inert 1)) 441 442 ;; $unless 443 ($check-error ($unless)) 444 ($check-error ($unless #t . 3)) 445 ($check-error ($unless #f . 3)) 446 ($check-error ($unless #inert 1)) 447 448 449