continuations.k (10612B)
1 ;; check.k & test-helpers.k should be loaded 2 ;; 3 ;; Tests of features related to continuations. 4 ;; 5 6 ;; R(-1)KR 7.2.1 continuation? 7 8 ($check-predicate (applicative? continuation?)) 9 ($check-predicate (continuation?)) 10 ($check-predicate (continuation? root-continuation error-continuation)) 11 ($check-not-predicate (continuation? ($lambda () ()))) 12 ($check-not-predicate (continuation? ())) 13 ($check-not-predicate (continuation? (get-current-environment))) 14 15 ;; 7.2.2 call/cc 16 17 ($check-predicate (applicative? call/cc)) 18 ($check equal? (call/cc ($lambda (c) (apply-continuation c 1))) 1) 19 ($check-error (call/cc)) 20 ($check-error (call/cc 1)) 21 ($check-error (call/cc ($lambda (c) c) ($lambda (c) c))) 22 23 ($check equal? 24 (call/cc 25 ($lambda (c) 26 (list 27 (continuation? c) 28 (eq? c root-continuation) 29 (eq? c error-continuation) 30 (eq? c (call/cc ($lambda (c) c)))))) 31 (list #t #f #f #f)) 32 33 ($check equal? 34 ($let 35 ((b1 ($vau #ignore denv ($binds? denv the-var))) 36 (b2 (wrap ($vau #ignore denv ($binds? denv the-var))))) 37 (list 38 (list (b1) (b2) (call/cc b1) (call/cc b2)) 39 ($let ((the-var 1)) 40 (list (b1) (b2) (call/cc b1) (call/cc b2))))) 41 (list (list #f #f #f #f) (list #t #t #t #t))) 42 43 ($check equal? 44 (call/cc 45 ($lambda (abort) 46 ($let 47 ((f ($lambda (k) ($when (=? k 2) (apply-continuation abort k))))) 48 (f 1) 49 (f 2) 50 (f 3)))) 51 2) 52 53 ($check equal? 54 ($let () 55 ($define! r ()) 56 ($define! c (call/cc ($lambda (c) c))) 57 ($set! (get-current-environment) r (cons (length r) r)) 58 ($if (<? (length r) 5) 59 (apply-continuation c c) 60 r)) 61 (list 4 3 2 1 0)) 62 63 ;; 7.2.3 extend-continuation 64 65 ($check-predicate (applicative? extend-continuation)) 66 ($check-predicate 67 (continuation? 68 (extend-continuation root-continuation abs) 69 (extend-continuation root-continuation abs (get-current-environment)))) 70 71 ($check-error (extend-continuation)) 72 ($check-error (extend-continuation root-continuation)) 73 ($check-error (extend-continuation root-continuation abs abs)) 74 ($check-error (extend-continuation root-continuation abs (get-current-environment) 123)) 75 ($check-error (extend-continuation abs root-continuation abs)) 76 77 ($check equal? 78 (call/cc 79 ($lambda (c) 80 (apply-continuation (extend-continuation c abs) (list -10)))) 81 10) 82 83 ($check equal? 84 (call/cc 85 ($lambda (c) 86 (apply-continuation 87 (extend-continuation c 88 (wrap ($vau #ignore denv 89 ($binds? denv c)))) 90 ()))) 91 #f) 92 93 ($check equal? 94 ($let 95 ((comb 96 (wrap 97 ($vau x denv 98 (string-append x ($remote-eval suffix denv)))))) 99 (call/cc 100 ($lambda (k0) 101 ($let* 102 ((k1 (extend-continuation k0 comb 103 ($bindings->environment (suffix "a")))) 104 (k2 (extend-continuation k1 comb 105 ($bindings->environment (suffix "b")))) 106 (k3 (extend-continuation k2 comb 107 ($bindings->environment (suffix "c"))))) 108 (apply-continuation k3 "0"))))) 109 "0cba") 110 111 ;; 7.2.4 guard-continuation 112 113 ($check-predicate (applicative? guard-continuation)) 114 ($check-predicate (continuation? (guard-continuation () root-continuation ()))) 115 ($check-error (guard-continuation)) 116 ($check-error (guard-continuation () root-continuation)) 117 ($check-error (guard-continuation () root-continuation () ())) 118 ($check-error (guard-continuation ($lambda () ()) root-continuation)) 119 ($check-error (guard-continuation () ($lambda () ()) ())) 120 ($check-error (guard-continuation () root-continuation ($lambda () ()))) 121 122 ($check equal? 123 (call/cc 124 ($lambda (c) 125 (apply-continuation (guard-continuation () c ()) "arg"))) 126 "arg") 127 128 ($check equal? 129 (call/cc ($lambda (k1) 130 (apply-continuation 131 (guard-continuation 132 (list 133 (list error-continuation 134 ($lambda (obj divert) 135 (string-append "entry-1-" obj))) 136 (list root-continuation 137 ($lambda (obj divert) 138 (string-append "entry-2-" obj))) 139 (list root-continuation 140 ($lambda (obj divert) 141 (string-append "entry-3-" obj)))) 142 k1 143 ()) 144 "arg"))) 145 "entry-2-arg") 146 147 ($check equal? 148 (call/cc ($lambda (k1) 149 (apply-continuation 150 (extend-continuation 151 (guard-continuation 152 (list 153 (list root-continuation 154 ($lambda (obj divert) 155 (string-append "entry-" obj)))) 156 k1 157 ()) 158 ($lambda arg 159 (string-append "extension-" arg))) 160 "arg"))) 161 "extension-entry-arg") 162 163 ($check equal? 164 (call/cc ($lambda (k1) 165 (apply-continuation 166 (extend-continuation 167 (guard-continuation 168 (list 169 (list root-continuation 170 ($lambda (obj divert) 171 (apply divert "diverted")))) 172 k1 173 (list 174 (list root-continuation 175 ($lambda (obj divert) 176 (apply divert "never"))))) 177 ($lambda arg "result")) 178 "arg"))) 179 "diverted") 180 181 ($check equal? 182 (call/cc ($lambda (k1) 183 (apply-continuation 184 (extend-continuation 185 (guard-continuation 186 () 187 k1 188 (list 189 (list root-continuation 190 ($lambda (obj divert) 191 (string-append "exit-" obj))))) 192 ($lambda arg 193 (string-append "extension-" arg))) 194 "arg"))) 195 "extension-arg") 196 197 ($check equal? 198 (call/cc ($lambda (k1) 199 (apply-continuation 200 (extend-continuation 201 (guard-continuation 202 () 203 k1 204 (list 205 (list root-continuation 206 ($lambda (obj divert) 207 (string-append "exit-" obj))))) 208 ($lambda arg 209 (apply-continuation k1 "result"))) 210 "arg"))) 211 "exit-result") 212 213 ($check equal? 214 (call/cc ($lambda (a) 215 ($let* 216 ((b1 (extend-continuation a ($lambda x (cons "b1" x)))) 217 (b2 (extend-continuation b1 ($lambda x (cons "b2" x)))) 218 (c1 (extend-continuation a ($lambda x (cons "c1" x)))) 219 (c2 (extend-continuation c1 ($lambda x (cons "c2" x))))) 220 (apply-continuation 221 (extend-continuation 222 (guard-continuation 223 () 224 b2 225 (list 226 (list b2 ($lambda (x divert) (apply divert (cons "catch-b2" x)))) 227 (list a ($lambda (x divert) (apply divert (cons "catch-a" x)))) 228 (list b1 ($lambda (x divert) (apply divert (cons "catch-b1" x)))))) 229 ($lambda arg 230 (apply-continuation c1 (cons "body" arg)))) 231 (list "arg"))))) 232 (list "b1" "b2" "catch-a" "body" "arg")) 233 234 ($check equal? 235 (call/cc ($lambda (a) 236 ($let* 237 ((b1 (extend-continuation a ($lambda x (cons "b1" x)))) 238 (b2 (extend-continuation b1 ($lambda x (cons "b2" x)))) 239 (c1 (extend-continuation a ($lambda x (cons "c1" x)))) 240 (c2 (extend-continuation c1 ($lambda x (cons "c2" x))))) 241 (apply-continuation 242 (extend-continuation 243 (guard-continuation 244 () 245 b2 246 (list 247 (list b2 ($lambda (x divert) (cons "catch-b2" x))) 248 (list a ($lambda (x divert) (cons "catch-a" x))) 249 (list b1 ($lambda (x divert) (cons "catch-b1" x))))) 250 ($lambda arg 251 (apply-continuation c1 (cons "body" arg)))) 252 (list "arg"))))) 253 (list "c1" "catch-a" "body" "arg")) 254 255 ;; 7.2.5 continuation->applicative 256 257 ($check-predicate (applicative? continuation->applicative)) 258 ($check-predicate (applicative? (continuation->applicative root-continuation))) 259 260 ($check-error (continuation->applicative)) 261 ($check-error (continuation->applicative ($lambda () ()))) 262 ($check-error (continuation->applicative root-continuation 0)) 263 264 ($check equal? 265 (call/cc ($lambda (k1) 266 (call/cc ($lambda (k2) 267 (apply (continuation->applicative k1) "x") 268 "y")))) 269 "x") 270 271 ;; 7.2.6 root-continuation 272 ;; tested in test-interpreter.sh 273 274 ;; 7.2.7 error-continuation 275 ;; tested in error.k 276 277 ;; 7.3.1 apply-continuation 278 ;; sufficiently tested above 279 280 ;; 7.3.2 $let/cc 281 282 ($check-predicate (operative? $let/cc)) 283 ($check-error ($let/cc)) 284 ($check equal? ($let/cc sym) #inert) 285 ($check-error ($let/cc 1 0)) 286 287 ($check equal? 288 ($let/cc sym 289 (list 290 (continuation? sym) 291 (eq? sym root-continuation) 292 (eq? sym error-continuation))) 293 (list #t #f #f)) 294 295 ($check equal? 296 ($let/cc abort 297 (apply-continuation abort "aborted") 298 "not aborted") 299 "aborted") 300 301 ;; 7.3.3 guard-dynamic-extent 302 303 ($check-predicate (applicative? guard-dynamic-extent)) 304 ($check equal? (guard-dynamic-extent () ($lambda x x) ()) ()) 305 ($check-error (guard-dynamic-extent)) 306 ($check-error (guard-dynamic-extent ($lambda x x) ($lambda x x) ())) 307 ($check-error (guard-dynamic-extent () ($lambda x x) ($lambda x x))) 308 ($check-error (guard-dynamic-extent () #t ())) 309 310 ($check equal? 311 ($let ((comb ($vau #ignore denv ($remote-eval var denv)))) 312 ($let ((var "v")) 313 (guard-dynamic-extent () comb ()))) 314 "v") 315 316 ($check equal? 317 (guard-dynamic-extent 318 () 319 ($lambda x x) 320 (list 321 (list root-continuation ($lambda (obj divert) "catch")))) 322 ()) 323 324 ($check equal? 325 (guard-dynamic-extent 326 (list 327 (list root-continuation 328 ($lambda (obj divert) (apply divert "catch")))) 329 ($lambda x x) 330 ()) 331 ()) 332 333 ($check equal? 334 (guard-dynamic-extent 335 () 336 ($lambda #ignore (error "error")) 337 (list 338 (list error-continuation 339 ($lambda (obj divert) (apply divert "catch"))))) 340 "catch") 341 342 ($check equal? 343 ($letrec ((r ()) (k #f) (env (get-current-environment))) 344 ($set! env r 345 (guard-dynamic-extent 346 (list 347 (list root-continuation 348 ($lambda (obj divert) (apply divert (list* "catch" obj r))))) 349 ($lambda () 350 ($let/cc k0 351 ($set! env k k0) 352 (cons "body" r))) 353 ())) 354 ($when (<? (length r) 5) 355 (apply-continuation k "x")) 356 r) 357 (list "catch" "x" "catch" "x" "body")) 358 359 ($check equal? 360 ($letrec ((r ()) (k #f) (env (get-current-environment))) 361 ($set! env r 362 (guard-dynamic-extent 363 (list 364 (list root-continuation 365 ($lambda (obj divert) (list* "catch" obj)))) 366 ($lambda () 367 (cons "next" 368 ($let/cc k0 369 ($set! env k k0) 370 (cons "first" r)))) 371 ())) 372 ($when (<? (length r) 8) 373 (apply-continuation k (cons "redo" r))) 374 r) 375 (list "next" "catch" "redo" "next" "catch" "redo" "next" "first")) 376 377 ;; 7.3.4 exit 378 ;; effects tested in test-interpreter.sh 379 ($check-predicate (applicative? exit)) 380 ($check-error (exit "too many" "args")) 381