environments.k (14681B)
1 ;; check.k & test-helpers.k should be loaded 2 3 ;;; 4 ;;; Basic Functionality 5 ;;; 6 7 ;; 4.8.1 environment? 8 9 ($check-predicate (applicative? environment?)) 10 ($check-predicate (environment?)) 11 ($check-predicate (environment? (get-current-environment))) 12 ($check-not-predicate (environment? ())) 13 14 ;; 4.8.2 ignore? 15 16 ($check-predicate (applicative? ignore?)) 17 ($check-predicate (ignore?)) 18 ($check-predicate (ignore? #ignore)) 19 ($check-not-predicate (ignore? #f)) 20 ($check-not-predicate (ignore? 0)) 21 ($check-not-predicate (ignore? ())) 22 ($check-not-predicate (ignore? #inert)) 23 ($check-not-predicate (ignore? #undefined)) 24 25 ;; 4.8.3 eval 26 27 ($check-predicate (applicative? eval)) 28 ($check-error (eval)) 29 ($check-error (eval 0)) 30 ($check-error (eval 0 1)) 31 ($check-error (eval 0 (get-current-environment) 2)) 32 33 ($let* 34 ((env (make-environment)) 35 ((encapsulate #ignore #ignore) (make-encapsulation-type)) 36 (encapsulation (encapsulate 0)) 37 (promise ($lazy (+ 1 1))) 38 (bytevector (make-bytevector 1))) 39 ($check eq? (eval #t env) #t) 40 ($check eq? (eval #inert env) #inert) 41 ($check eq? (eval () env) ()) 42 ($check eq? (eval #ignore env) #ignore) 43 ($check eq? (eval env env) env) 44 ($check eq? (eval eval env) eval) 45 ($check eq? (eval $vau env) $vau) 46 ($check eq? (eval root-continuation env) root-continuation) 47 ($check eq? (eval encapsulation env) encapsulation) 48 ($check eq? (eval promise env) promise) 49 ($check eq? (eval 0 env) 0) 50 ($check eq? (eval "string" env) "string") 51 ($check eq? (eval #\c env) #\c) 52 ($check eq? (eval (get-current-input-port) env) (get-current-input-port)) 53 ($check eq? (eval bytevector env) bytevector) 54 ($check-error (eval (string->symbol "eval") env)) 55 ($check eq? (eval (list $quote 1) env) 1) 56 ($check equal? (eval (list + 1 1) env) 2) 57 ($check-error (eval (list* not? #t) env)) 58 ($check-error (eval (list 1) env))) 59 60 ($let ((env ($bindings->environment (+ *)))) 61 ($check equal? (eval ($quote (+ 1 1)) env) 1)) 62 63 ; eval semantics in the presence of continuation capturing and 64 ; mutation 65 66 ; This check will try to mutate the list argument to eval 67 ; during the evaluation of the list to see if eval makes a 68 ; copy of the list previous to start evaluating (this test 69 ; contemplates the two more usual cases of left-to-right and 70 ; right-to-left list evaluation) 71 ($check equal? 72 ($let* ((ls (list list (list list 1) #ignore (list list 3))) 73 (mut-ls! ($lambda () 74 (set-car! (cdr ls) (list -1)) 75 (set-car! (cdddr ls) (list -3)) 76 2))) 77 (set-car! (cddr ls) (list mut-ls!)) 78 (eval ls (get-current-environment))) 79 (list (list 1) 2 (list 3))) 80 81 ; This check will capture the continuation in the middle of list 82 ; evaluation to see whether restarting the continuation later 83 ; works as expected 84 ($check equal? 85 ($let* ((cc ($lambda () ($let/cc cont cont))) 86 (ls (list list (list list 1) (list cc) (list list 3))) 87 (res (eval ls (get-current-environment))) 88 (cont (cadr res))) 89 ;; in the first pass cont has the continuation 90 ;; in the second pass it has the 2 passed in 91 ;; apply-continuation 92 ($if (continuation? cont) 93 (apply-continuation cont 2) 94 res)) 95 (list (list 1) 2 (list 3))) 96 97 ; This check is a combination of the last two. 98 ; It will capture the continuation in the middle of list 99 ; evaluation and later mutate the result list to see whether restarting 100 ; the continuation later works as expected 101 ($check equal? 102 ($let* ((cc ($lambda () ($let/cc cont cont))) 103 (ls (list list 1 (list cc) 3)) 104 (res (eval ls (get-current-environment))) 105 (cont (cadr res))) 106 ;; in the first pass cont has the continuation 107 ;; in the second pass it has the 2 passed in 108 ;; apply-continuation 109 ($if (continuation? cont) 110 ($sequence (set-car! res -1) 111 (set-car! (cddr res) -3) 112 (apply-continuation cont 2)) 113 res)) 114 (list 1 2 3)) 115 116 117 ;; TODO add checks to also test what happens when cyclic lists are 118 ;; mixed with continuation capturing and mutation 119 120 121 ;; 4.8.4 make-environment 122 123 ($check-predicate (applicative? make-environment)) 124 ($check-predicate (environment? (make-environment))) 125 ($let* 126 ((x 0) 127 (e1 (make-environment)) 128 (e2 (make-environment (get-current-environment))) 129 (e3 (make-environment e1)) 130 (e4 (make-environment e2)) 131 (es (list e1 e2 e3 e4))) 132 ($check-not-predicate ($binds? e1 x)) 133 ($check-predicate ($binds? e2 x)) 134 ($check-not-predicate ($binds? e3 x)) 135 ($check-predicate ($binds? e4 x)) 136 (encycle! es 1 3) 137 ($check-predicate ($binds? (apply make-environment es)))) 138 139 ($check-not-predicate (eq? (make-environment) (make-environment))) 140 ($check-not-predicate (equal? (make-environment) (make-environment))) 141 ($check-not-predicate (equal? (make-environment) (get-current-environment))) 142 143 ;; 5.10.1 $let 144 145 ($check-predicate (operative? $let)) 146 ($check equal? ($let () #t) #t) 147 ($check-error ($let (sym) #inert)) 148 ($check-error ($let (sym 0) #inert)) 149 ($check-error ($let loop ((x 0)) #inert)) 150 ($check-error ($let ((sym 0 1)) #inert)) 151 152 ($check-predicate 153 ($let 154 ((a (and? 155 (not? ($binds? (get-current-environment) a)) 156 (not? ($binds? (get-current-environment) b)))) 157 (b (and? 158 (not? ($binds? (get-current-environment) a)) 159 (not? ($binds? (get-current-environment) b)))) 160 (f ($lambda () 161 (and? 162 (not? ($binds? (get-current-environment) f)) 163 (not? ($binds? (get-current-environment) g))))) 164 (g ($lambda () 165 (and? 166 (not? ($binds? (get-current-environment) f)) 167 (not? ($binds? (get-current-environment) g)))))) 168 (and? a b (f) (g)))) 169 170 ;; 6.7.1 $binds? 171 172 ($check-predicate (operative? $binds?)) 173 ($check-predicate ($binds? (make-environment))) 174 175 ;; 6.7.2 get-current-environment 176 177 ($check-predicate (applicative? get-current-environment)) 178 ($check-predicate (environment? (get-current-environment))) 179 ($check-not-predicate ($binds? (get-current-environment) x)) 180 ($let ((x 0)) 181 ($check-predicate ($binds? (get-current-environment) x))) 182 183 ;; 6.7.3 make-kernel-standard-environment 184 185 ($check-predicate (applicative? make-kernel-standard-environment)) 186 187 ($let ((x 0)) 188 ($check-not-predicate 189 ($binds? (make-kernel-standard-environment) x))) 190 191 ;; symbols defined in the Kernel Report 192 193 ($check-predicate 194 ($binds? (make-kernel-standard-environment) 195 ;; 4.1 - 4.10 196 boolean? 197 eq? 198 equal? 199 symbol? 200 inert? $if 201 pair? null? cons 202 set-car! set-cdr! copy-es-immutable 203 environment? ignore? eval make-environment 204 $define! 205 operative? applicative? $vau wrap unwrap 206 ;; 5.1 - 5.10 207 $sequence 208 list list* 209 $vau $lambda 210 car cdr 211 caar cadr cdar cddr 212 caaar caadr cadar caddr cdaar cdadr cddar cdddr 213 caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr 214 cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr 215 apply 216 $cond 217 get-list-metrics list-tail 218 encycle! 219 map 220 $let 221 ;; 6.1 - 6.4, 6.7 - 6.9 222 not? and? or? $and? $or? 223 combiner? 224 length list-ref append list-neighbors filter 225 assoc member? finite-list? countable-list? reduce 226 append! copy-es assq memq? 227 $binds? get-current-environment make-kernel-standard-environment 228 $let* $letrec $letrec* $let-redirect $let-safe $remote-eval 229 $bindings->environment 230 $set! $provide! $import! 231 for-each 232 ;; 7.1 - 7.3 233 continuation? call/cc extend-continuation guard-continuation 234 continuation->applicative root-continuation error-continuation 235 apply-continuation $let/cc guard-dynamic-extent exit 236 ;; 8.1 237 make-encapsulation-type 238 ;; 9.1 239 promise? force $lazy memoize 240 ;; 10.1 241 make-keyed-dynamic-variable 242 ;; 11.1 243 make-keyed-static-variable 244 ;; 12.1 - 12.10 245 number? finite? integer? 246 =? <? <=? >=? >? 247 + * - 248 zero? 249 div mod div-and-mod 250 div0 mod0 div0-and-mod0 251 positive? negative? 252 odd? even? 253 abs 254 max min 255 lcm gcd 256 exact? inexact? robust? undefined? 257 get-real-internal-bounds get-real-exact-bounds 258 get-real-internal-primary get-real-exact-primary 259 make-inexact 260 real->inexact real->exact 261 with-strict-arithmetic get-strict-arithmetic? 262 ;; not implemented: with-narrow-arithmetic get-narrow-arithmetic? 263 rational? 264 / 265 numerator denominator 266 floor ceiling truncate round 267 rationalize simplest-rational 268 real? 269 exp log 270 sin cos tan asin acos atan 271 sqrt expt 272 ;; not implemented: complex? 273 ;; not implemented: make-rectangular real-part imag-part 274 ;; not implemented: make-polar magnitude angle 275 ;; 13.1 276 string->symbol 277 ;; 15.1 - 15.2 278 port? 279 input-port? output-port? 280 with-input-from-file with-output-to-file 281 get-current-input-port get-current-output-port 282 open-input-file open-output-file 283 close-input-file close-output-file 284 read 285 write 286 call-with-input-file call-with-output-file 287 load 288 get-module)) 289 290 ;; Additional symbols defined in klisp. 291 ($check-predicate 292 ($binds? (make-kernel-standard-environment) 293 ;; symbols 294 symbol->string 295 ;; strings 296 string? 297 symbol->string 298 ;; TODO 299 ;; chars 300 char? 301 char=? char<? char<=? char>=? char>? 302 char->integer integer->char 303 ;; TODO 304 ;; ports 305 textual-port? binary-port? 306 flush-output-port 307 with-error-to-file 308 get-current-error-port 309 open-binary-input-file open-binary-output-file 310 close-input-port close-output-port close-port 311 eof-object? 312 read-char peek-char char-ready? write-char 313 newline 314 display 315 read-u8 peek-u8 u8-ready? write-u8 316 ;; system functions 317 get-current-second get-current-jiffy get-jiffies-per-second 318 file-exists? delete-file rename-file 319 ;; bytevectors 320 bytevector? 321 ;; error handling 322 error system-error-continuation)) 323 324 ;; 6.7.4 $let* 325 326 ($check-predicate (operative? $let*)) 327 ($check equal? ($let* () #f) #f) 328 ($check equal? ($let* () #f #t) #t) 329 ($check-error ($let* (sym) #inert)) 330 ($check-error ($let* (sym 0) #inert)) 331 ($check-error ($let* loop ((x 0)) #inert)) 332 ($check-error ($let* ((sym 0 1)) #inert)) 333 334 ($check-predicate 335 ($let* 336 ((a (and? 337 (not? ($binds? (get-current-environment) a)) 338 (not? ($binds? (get-current-environment) b)) 339 (not? ($binds? (get-current-environment) c)))) 340 (b (and? 341 ($binds? (get-current-environment) a) 342 (not? ($binds? (get-current-environment) b)) 343 (not? ($binds? (get-current-environment) c)))) 344 (c (and? 345 ($binds? (get-current-environment) a) 346 ($binds? (get-current-environment) b) 347 (not? ($binds? (get-current-environment) c)))) 348 (f ($lambda () 349 (and? 350 ($binds? (get-current-environment) a) 351 ($binds? (get-current-environment) b) 352 ($binds? (get-current-environment) c) 353 (not? ($binds? (get-current-environment) f)) 354 (not? ($binds? (get-current-environment) g))))) 355 (g ($lambda () 356 (and? 357 ($binds? (get-current-environment) a) 358 ($binds? (get-current-environment) b) 359 ($binds? (get-current-environment) c) 360 ($binds? (get-current-environment) f) 361 (not? ($binds? (get-current-environment) g)))))) 362 (and? a b c (f) (g)))) 363 364 ;; 6.7.5 $letrec 365 366 ($check-predicate (operative? $letrec)) 367 ($check-no-error ($letrec () #inert)) 368 369 ($check-predicate 370 ($letrec ((x (not? ($binds? (get-current-environment) x)))) x)) 371 372 ($check-predicate 373 ($letrec 374 ((f ($lambda () 375 (and? 376 ($binds? (get-current-environment) f) 377 ($binds? (get-current-environment) g)))) 378 (g ($lambda () 379 (and? 380 ($binds? (get-current-environment) f) 381 ($binds? (get-current-environment) g))))) 382 (and? (f) (g)))) 383 384 ;; 6.7.6 $letrec* 385 386 ($check-predicate (operative? $letrec*)) 387 ($check equal? ($letrec* () 123) 123) 388 389 ($check-predicate 390 ($letrec* ((x (not? ($binds? (get-current-environment) x)))) x)) 391 392 ($check-predicate 393 ($letrec* 394 ((a 1) 395 (f ($lambda () 396 (and? 397 ($binds? (get-current-environment) a) 398 ($binds? (get-current-environment) f))))) 399 (f))) 400 401 ($check-predicate 402 ($letrec* 403 ((f ($lambda () 404 ($binds? (get-current-environment) f))) 405 (g ($lambda () 406 (and? 407 ($binds? (get-current-environment) f) 408 ($binds? (get-current-environment) g))))) 409 (and? (f) (g)))) 410 411 ($check-predicate 412 ($letrec* 413 ((a 1) 414 (b 2) 415 (f ($lambda () ($binds? (get-current-environment) f)))) 416 (f))) 417 418 ;; 6.7.7 $let-redirect 419 420 ($check-predicate (operative? $let-redirect)) 421 ($check equal? ($let-redirect (make-environment) () 42) 42) 422 423 ($let 424 ((a 1) 425 (env ($let ((a 2)) (get-current-environment)))) 426 ($check equal? ($let-redirect (get-current-environment) () a) 1) 427 ($check equal? ($let-redirect env () a) 2) 428 ($check equal? ($let-redirect env ((a 3)) a) 3) 429 ($check equal? ($let-redirect env ((a a)) a) 1)) 430 431 ;; 6.7.8 $let-safe 432 433 ($check-predicate (operative? $let-safe)) 434 ($check equal? ($let-safe () 42) 42) 435 ($let 436 (($lambda 42)) 437 ($check equal? ($let-safe ((x $lambda)) (($lambda () x))) 42) 438 ($check-error ($let ((x $lambda)) (($lambda () x))))) 439 440 ;; 6.7.9 $remote-eval 441 442 ($check-predicate (operative? $remote-eval)) 443 ($check equal? ($remote-eval 42 (make-environment)) 42) 444 445 ($let 446 ((e0 (make-kernel-standard-environment)) 447 (e1 ($let ((or? not?)) (get-current-environment)))) 448 ($check equal? ($remote-eval (or? #t) e0) #t) 449 ($check equal? ($remote-eval (or? #t) e1) #f)) 450 451 ;; 6.7.10 $bindings->environment 452 453 ($check-predicate (operative? $bindings->environment)) 454 ($check-predicate (environment? ($bindings->environment))) 455 ($let 456 ((env ($bindings->environment (a 1) (b 2)))) 457 ($check-predicate ($binds? env a b)) 458 ($check equal? (eval ($quote a) env) 1) 459 ($check equal? (eval ($quote b) env) 2))