1#lang scheme 2(require (prefix-in scheme: scheme) 3 plai/private/command-line 4 (for-syntax plai/private/command-line) 5 plai/gc2/private/collector-exports 6 plai/gc2/private/gc-core 7 scheme/gui/dynamic 8 (only-in plai/test-harness 9 exn:plai? equal~? 10 plai-error generic-test test halt-on-errors print-only-errors) 11 (for-syntax scheme) 12 (for-syntax plai/gc2/private/gc-transformer) 13 scheme/stxparam 14 (for-syntax scheme/stxparam-exptime)) 15 16(provide else require provide #%top 17 values 18 test/location=? 19 test/value=? 20 (rename-out 21 [plai-error error] 22 23 [mutator-and and] 24 [mutator-or or] 25 [mutator-cond cond] 26 [mutator-case case] 27 [mutator-define define] 28 [mutator-define-values define-values] 29 (mutator-let let) 30 [mutator-let* let*] 31 [mutator-begin begin] 32 33 [mutator-if if] 34 [mutator-let-values let-values] 35 [mutator-set! set!] 36 [mutator-lambda lambda] 37 [mutator-lambda λ] 38 (mutator-app #%app) 39 (mutator-datum #%datum) 40 (mutator-cons cons) 41 (collector:first first) 42 (collector:rest rest) 43 (mutator-quote quote) 44 (mutator-top-interaction #%top-interaction) 45 (mutator-module-begin #%module-begin))) 46 47(define-syntax-parameter mutator-name #f) 48(define-syntax-parameter mutator-tail-call? #t) 49(define-syntax-parameter mutator-env-roots empty) 50 51(define-syntax-parameter mutator-assignment-allowed? #t) 52(define-syntax-rule (no! e) (syntax-parameterize ([mutator-assignment-allowed? #f]) e)) 53(define-syntax-rule (yes! e) (syntax-parameterize ([mutator-assignment-allowed? #t]) e)) 54 55; Sugar Macros 56(define-syntax mutator-and 57 (syntax-rules () 58 [(_) (mutator-quote #t)] 59 [(_ fe) fe] 60 [(_ fe e ...) (mutator-if fe (mutator-and e ...) (mutator-quote #f))])) 61(define-syntax mutator-or 62 (syntax-rules () 63 [(_) (mutator-quote #f)] 64 [(_ fe) fe] 65 [(_ fe e ...) (mutator-let ([tmp fe]) (mutator-if tmp tmp (mutator-or e ...)))])) 66(define-syntax mutator-cond 67 (syntax-rules (else) 68 [(_) (mutator-begin)] 69 [(_ [else e ...]) (mutator-begin e ...)] 70 [(_ [q ans] e ...) (mutator-if q ans (mutator-cond e ...))])) 71(define-syntax mutator-case 72 (syntax-rules (else) 73 [(_ value 74 [(v ...) e ...] 75 ... 76 [else ee ...]) 77 (mutator-let ([tmp value]) 78 (mutator-cond [(mutator-app mutator-member? tmp (mutator-quote (v ...))) 79 e ...] 80 ... 81 [else ee ...]))] 82 [(_ value 83 [(v ...) e ...] 84 ...) 85 (mutator-case value 86 [(v ...) e ...] 87 ... 88 [else (mutator-begin)])])) 89(define-syntax mutator-define 90 (syntax-rules () 91 [(_ (f a ...) e ...) 92 (mutator-define-values (f) 93 (syntax-parameterize ([mutator-name #'f]) 94 (mutator-lambda (a ...) e ...)))] 95 [(_ id e) 96 (mutator-define-values (id) 97 (syntax-parameterize ([mutator-name #'id]) 98 e))])) 99(define-syntax-rule (mutator-let ([id e] ...) be ...) 100 (mutator-let-values ([(id) (syntax-parameterize ([mutator-name #'id]) 101 e)] 102 ...) 103 be ...)) 104(define-syntax mutator-let* 105 (syntax-rules () 106 [(_ () be ...) 107 (mutator-begin be ...)] 108 [(_ ([fid fe] [rid re] ...) be ...) 109 (mutator-let ([fid fe]) 110 (mutator-let* ([rid re] ...) 111 be ...))])) 112(define-syntax mutator-begin 113 (syntax-rules () 114 [(_) (mutator-app void)] 115 [(_ e) e] 116 [(_ fe e ...) 117 (let ([tmp 118 (syntax-parameterize ([mutator-tail-call? #f]) 119 (yes! fe))]) 120 (mutator-begin e ...))])) 121 122(define mutator-cons 123 (let ([cons 124 (λ (hd tl) 125 (define roots (compute-current-roots)) 126 (define-values (hd-roots no-hd-roots) 127 (partition (λ (x) (= hd (read-root x))) roots)) 128 (define-values (tl-roots no-hd-no-tl-roots) 129 (partition (λ (x) (= tl (read-root x))) no-hd-roots)) 130 (parameterize ([active-roots no-hd-no-tl-roots]) 131 (collector:cons (make-root 'hd 132 (λ () hd) 133 (λ (v) 134 (set! hd v) 135 (for ([r (in-list hd-roots)]) 136 (set-root! r v)))) 137 (make-root 'tl 138 (λ () tl) 139 (λ (v) 140 (set! tl v) 141 (for ([r (in-list tl-roots)]) 142 (set-root! r v)))))))]) 143 cons)) 144 145(define (do-alloc-flat flat) 146 (parameterize ([active-roots (compute-current-roots)]) 147 (collector:alloc-flat flat))) 148 149; Real Macros 150(define-syntax-rule (mutator-define-values (id ...) e) 151 (begin (define-values (id ...) 152 (syntax-parameterize ([mutator-tail-call? #f]) 153 e)) 154 (add-global-root! (make-env-root id)) 155 ...)) 156(define-syntax-rule (mutator-if test true false) 157 (if (syntax-parameterize ([mutator-tail-call? #f]) 158 (collector:deref (no! test))) 159 true 160 false)) 161(define-syntax (mutator-set! stx) 162 (syntax-case stx () 163 [(_ id e) 164 (let () 165 (if (syntax-parameter-value #'mutator-assignment-allowed?) 166 #'(begin 167 (set! id (no! e)) 168 (mutator-app void)) 169 (raise-syntax-error 'set! "allowed only inside begin expressions and at the top-level" stx)))])) 170(define-syntax (mutator-let-values stx) 171 (syntax-case stx () 172 [(_ ([(id ...) expr] ...) body-expr) 173 (with-syntax ([((tmp ...) ...) 174 (map generate-temporaries (syntax->list #'((id ...) ...)))]) 175 (let ([binding-list (syntax->list #'((id ...) ...))]) 176 (with-syntax ([((previous-id ...) ...) 177 (build-list (length binding-list) 178 (λ (n) (append-map syntax->list (take binding-list n))))]) 179 (syntax/loc stx 180 (let*-values ([(tmp ...) 181 (syntax-parameterize ([mutator-env-roots 182 (append 183 (switch-over 184 (syntax->list #'(id ... ...)) 185 (syntax->list #'(tmp ... ...)) 186 (find-referenced-locals 187 (list #'previous-id ...) 188 #'body-expr)) 189 (syntax-parameter-value #'mutator-env-roots))] 190 [mutator-tail-call? #f]) 191 (no! expr))] 192 ...) 193 (let-values ([(id ...) (values tmp ...)] ...) 194 (syntax-parameterize ([mutator-env-roots 195 (append (find-referenced-locals 196 (list #'id ... ...) 197 #'body-expr) 198 (syntax-parameter-value #'mutator-env-roots))]) 199 body-expr)))))))] 200 [(_ ([(id ...) expr] ...) body-expr ...) 201 (syntax/loc stx 202 (mutator-let-values 203 ([(id ...) expr] ...) 204 (mutator-begin body-expr ...)))])) 205(define-syntax (mutator-lambda stx) 206 (syntax-case stx () 207 [(_ (id ...) body) 208 (let ([env-roots (syntax-parameter-value #'mutator-env-roots)]) 209 (with-syntax ([(free-id ...) (map syntax-local-introduce 210 (filter 211 (λ (x) (for/and ([id (in-list (syntax->list #'(id ...)))]) 212 (not (free-identifier=? id x)))) 213 (find-referenced-locals env-roots stx)))] 214 [(env-id ...) env-roots] 215 [closure (or (syntax-parameter-value #'mutator-name) 216 (syntax-local-name) 217 (let ([prop (syntax-property stx 'inferred-name)]) 218 (if (or (identifier? prop) 219 (symbol? prop)) 220 prop 221 #f)) 222 (string->symbol "#<proc>"))]) 223 (quasisyntax/loc stx 224 (let ([closure 225 (closure-code 226 #,(length (syntax->list #'(free-id ...))) 227 (let ([closure 228 (lambda (free-id ... id ...) 229 (syntax-parameterize ([mutator-env-roots 230 (append 231 (find-referenced-locals 232 (list #'id ...) 233 #'body) 234 (list #'free-id ...))] 235 [mutator-tail-call? #t]) 236 (no! body)))]) 237 closure))]) 238 #,(if (syntax-parameter-value #'mutator-tail-call?) 239 (syntax/loc stx 240 (#%app do-collector:closure closure 241 (list (λ () free-id) ...) 242 (list (λ (v) (set! free-id v)) ...))) 243 (syntax/loc stx 244 (with-continuation-mark 245 gc-roots-key 246 (list (make-env-root env-id) ...) 247 (#%app do-collector:closure closure 248 (list (λ () free-id) ...) 249 (list (λ (v) (set! free-id v)) ...)))))))))] 250 [(_ (id ...) body ...) 251 (syntax/loc stx 252 (mutator-lambda (id ...) (mutator-begin body ...)))])) 253 254(define (do-collector:closure closure getters setters) 255 (define-values (remaining-roots closure-roots) 256 (let loop ([getters getters] 257 [setters setters] 258 [remaining-roots (compute-current-roots)] 259 [closure-roots '()]) 260 (cond 261 [(null? getters) (values remaining-roots closure-roots)] 262 [else 263 (define this-loc ((car getters))) 264 (define this-setter (car setters)) 265 (define-values (this-other-roots leftovers) 266 (partition (λ (x) (= (read-root x) this-loc)) remaining-roots)) 267 (loop (cdr getters) (cdr setters) 268 leftovers 269 (cons (make-root 'closure-root 270 (λ () this-loc) 271 (λ (v) (set! this-loc v) 272 (this-setter v) 273 (for ([root (in-list this-other-roots)]) 274 (set-root! root v)))) 275 closure-roots))]))) 276 (parameterize ([active-roots remaining-roots]) 277 (collector:closure closure (reverse closure-roots)))) 278 279(define-syntax (mutator-app stx) 280 (syntax-case stx () 281 [(_ e ...) 282 (local [(define (do-not-expand? exp) 283 (and (identifier? exp) 284 (not (set!-transformer? 285 (syntax-local-value exp (lambda () #f)))))) 286 (define exps (syntax->list #'(e ...))) 287 (define tmps 288 (generate-temporaries #'(e ...)))] 289 (with-syntax ([(ne ...) 290 (map (lambda (exp tmp) (if (do-not-expand? exp) exp tmp)) 291 exps tmps)]) 292 (for/fold ([acc (syntax/loc stx (mutator-anf-app ne ...))]) 293 ([exp (in-list (reverse exps))] 294 [tmp (in-list (reverse tmps))]) 295 (if (do-not-expand? exp) 296 acc 297 (quasisyntax/loc stx 298 (mutator-let ([#,tmp #,exp]) 299 #,acc))))))])) 300(define-syntax (mutator-anf-app stx) 301 (syntax-case stx () 302 [(_ fe ae ...) 303 (let () 304 (define prim-app? (ormap (λ (x) (free-identifier=? x #'fe)) 305 prim-ids)) 306 (define is-set-fst? (free-identifier=? #'collector:set-first! #'fe)) 307 (when (or is-set-fst? (free-identifier=? #'collector:set-rest! #'fe)) 308 (unless (syntax-parameter-value #'mutator-assignment-allowed?) 309 (raise-syntax-error (if is-set-fst? 'set-first! 'set-rest!) 310 "can appear only at the top-level or in a begin" 311 stx))) 312 (with-syntax ([(env-id ...) (syntax-parameter-value #'mutator-env-roots)] 313 [app-exp (if prim-app? 314 (syntax/loc stx (do-alloc-flat (fe (collector:deref ae) ...))) 315 (syntax/loc stx ((deref-proc fe) ae ...)))]) 316 (if (syntax-parameter-value #'mutator-tail-call?) 317 ; If this call is in tail position, we will not need access 318 ; to its environment when it returns. 319 #'app-exp 320 ; If this call is not in tail position, we make the 321 ; environment at the call site reachable. 322 #`(with-continuation-mark gc-roots-key 323 (list (make-env-root env-id) ...) 324 app-exp))))])) 325(define-syntax mutator-quote 326 (syntax-rules () 327 [(_ (a . d)) 328 (mutator-app mutator-cons (mutator-quote a) (mutator-quote d))] 329 [(_ s) 330 (mutator-datum . s)])) 331(define-syntax (mutator-datum stx) 332 (syntax-case stx () 333 [(_ . e) 334 (quasisyntax/loc stx (mutator-anf-app do-alloc-flat (#%datum . e)))])) 335 336(define-syntax (mutator-top-interaction stx) 337 (syntax-case stx (require provide mutator-define mutator-define-values test/value=? import-primitives) 338 [(_ . (require . e)) 339 (syntax/loc stx 340 (require . e))] 341 [(_ . (provide . e)) 342 (syntax/loc stx 343 (provide . e))] 344 [(_ . (mutator-define . e)) 345 (syntax/loc stx 346 (mutator-define . e))] 347 [(_ . (mutator-define-values . e)) 348 (syntax/loc stx 349 (mutator-define-values . e))] 350 [(_ . (test/value=? . e)) 351 (syntax/loc stx 352 (test/value=? . e))] 353 [(_ . (import-primitives . e)) 354 (syntax/loc stx 355 (import-primitives . e))] 356 [(_ . expr) 357 (syntax/loc stx 358 (call-with-values 359 (lambda () 360 (syntax-parameterize ([mutator-tail-call? #f]) 361 expr)) 362 (case-lambda 363 [() (void)] 364 [(result-addr) 365 (show-one-result result-addr)] 366 [result-addrs 367 (show-multiple-results result-addrs)])))])) 368 369(define (show-one-result result-addr) 370 (cond 371 [(procedure? result-addr) 372 (printf "Imported procedure:\n") 373 result-addr] 374 [(location? result-addr) 375 (printf "Value at location ~a:\n" result-addr) 376 (gc->scheme result-addr)])) 377 378(define (show-multiple-results results) 379 (define addrs 380 (for/list ([result-addr (in-list results)] 381 #:when (location? result-addr)) 382 result-addr)) 383 384 (printf "Values at locations ") 385 (cond 386 [(= (length addrs) 2) 387 (printf "~a and ~a:\n" (car addrs) (cadr addrs))] 388 [else 389 (let loop ([addr (car addrs)] 390 [addrs (cdr addrs)]) 391 (cond 392 [(null? addrs) 393 (printf "and ~a:\n" addr)] 394 [else 395 (printf "~a, " addr) 396 (loop (car addrs) (cdr addrs))]))]) 397 (apply values 398 (for/list ([result (in-list results)]) 399 (cond 400 [(procedure? result) 401 result] 402 [(location? result) 403 (gc->scheme result)])))) 404 405 406; Module Begin 407(define-for-syntax (allocator-setup-internal stx) 408 (syntax-case stx () 409 [(collector-module heap-size) 410 (with-syntax ([(args ...) 411 (map (λ (s) (datum->syntax stx s)) 412 '(init-allocator gc:deref gc:alloc-flat gc:cons 413 gc:closure gc:closure? gc:closure-code-ptr gc:closure-env-ref 414 gc:first gc:rest 415 gc:flat? gc:cons? 416 gc:set-first! gc:set-rest!))]) 417 #`(begin 418 #,(if (alternate-collector) 419 #`(require #,(datum->syntax #'collector-module (alternate-collector))) 420 #`(require #,(syntax-case #'collector-module (mutator-quote) 421 [(mutator-quote . x) 422 (datum->syntax #'collector-module (cons #'quote #'x))] 423 [else #'collector-module]))) 424 (allocator-setup/proc args ... (#%datum . heap-size))))] 425 [_ (raise-syntax-error 'mutator 426 "Mutator must start with an 'allocator-setup' expression, such as: (allocator-setup <module-path> <literal-number>)" 427 stx)])) 428 429(define (allocator-setup/proc init-allocator gc:deref gc:alloc-flat gc:cons 430 gc:closure gc:closure? gc:closure-code-ptr gc:closure-env-ref 431 gc:first gc:rest 432 gc:flat? gc:cons? 433 gc:set-first! gc:set-rest! 434 heap-size) 435 (set-collector:deref! gc:deref) 436 (set-collector:alloc-flat! gc:alloc-flat) 437 (set-collector:cons! gc:cons) 438 (set-collector:first! gc:first) 439 (set-collector:rest! gc:rest) 440 (set-collector:flat?! gc:flat?) 441 (set-collector:cons?! gc:cons?) 442 (set-collector:set-first!! gc:set-first!) 443 (set-collector:set-rest!! gc:set-rest!) 444 (set-collector:closure! gc:closure) 445 (set-collector:closure?! gc:closure?) 446 (set-collector:closure-code-ptr! gc:closure-code-ptr) 447 (set-collector:closure-env-ref! gc:closure-env-ref) 448 449 (init-heap! heap-size) 450 (when (gui-available?) 451 (if (<= heap-size 500) 452 (set-ui! (dynamic-require `plai/gc2/private/gc-gui 'heap-viz%)) 453 (printf "Large heap; the heap visualizer will not be displayed.\n"))) 454 (init-allocator)) 455 456(define-for-syntax allocator-setup-error-msg 457 "Mutator must start with an 'allocator-setup' expression, such as: (allocator-setup <module-path> <literal-number>)") 458 459(define-syntax (mutator-module-begin stx) 460 (syntax-case stx (allocator-setup) 461 [(_ (allocator-setup . setup) module-expr ...) 462 (begin 463 (syntax-case #'setup () 464 [(collector heap-size) 465 (begin 466 (unless (module-path? (syntax->datum #'collector)) 467 (raise-syntax-error 'allocator-setup "expected a module path" #'collector)) 468 (unless (number? (syntax->datum #'heap-size)) 469 (raise-syntax-error 'allocator-setup "expected a literal number" #'heap-size)))] 470 [_ 471 (raise-syntax-error 'mutator allocator-setup-error-msg (syntax/loc #'setup (allocator-setup . setup)))]) 472 (quasisyntax/loc stx 473 (#%module-begin 474 #,(allocator-setup-internal #'setup) 475 #,@(for/list ([me (in-list (syntax->list #'(module-expr ...)))]) 476 (quasisyntax/loc me 477 (mutator-top-interaction . #,me))))))] 478 [(_ first-expr module-expr ...) 479 (raise-syntax-error 'mutator allocator-setup-error-msg #'first-expr)] 480 [(_) 481 (raise-syntax-error 'mutator allocator-setup-error-msg)])) 482 483; User Macros 484(provide import-primitives) 485(define-syntax (import-primitives stx) 486 (syntax-case stx () 487 [(_ id ...) 488 (andmap identifier? (syntax->list #'(id ...))) 489 (with-syntax ([(renamed-id ...) (generate-temporaries #'(id ...))] 490 [source (datum->syntax (and (pair? (syntax-e #'(id ...))) 491 (car (syntax-e #'(id ...)))) 492 'scheme)]) 493 #`(begin 494 (require (only-in source [id renamed-id] ...)) 495 ;; XXX make a macro to unify this and provide/lift 496 (define id 497 (lambda args 498 (unless (andmap (lambda (v) (and (location? v) (collector:flat? v))) args) 499 (error 'id (string-append "all arguments must be <heap-value?>s, " 500 "even if the imported procedure accepts structured " 501 "data"))) 502 (let ([result (apply renamed-id (map collector:deref args))]) 503 (cond 504 [(void? result) (void)] 505 [(heap-value? result) (do-alloc-flat result)] 506 [else 507 (error 'id (string-append "imported primitive must return <heap-value?>, " 508 "received ~a" result))])))) 509 ...))] 510 [(_ maybe-id ...) 511 (ormap (λ (v) (and (not (identifier? v)) v)) (syntax->list #'(maybe-id ...))) 512 (let ([offending-stx (findf (λ (v) (not (identifier? v))) (syntax->list #'(maybe-id ...)))]) 513 (raise-syntax-error 514 #f "expected identifier to import" offending-stx))] 515 [(_ . __) 516 (raise-syntax-error #f "expected list of identifiers to import" stx)] 517 [_ (raise-syntax-error #f "expected open parenthesis before import-primitive")])) 518 519(define-for-syntax ((mk-id-macro p-id) stx) 520 (syntax-case stx () 521 [id 522 (identifier? #'id) 523 (raise-syntax-error (syntax-e stx) 524 "primitive must appear in the function position of an application" 525 stx)] 526 [(id exp ...) 527 #`(mutator-app #,p-id exp ...)])) 528 529(define-syntax (provide-flat-prims/lift stx) 530 (syntax-case stx () 531 [(_ prim-ids id ...) 532 (andmap identifier? (syntax->list #'(id ...))) 533 (with-syntax ([(id2 ...) (generate-temporaries #'(id ...))] 534 [(p ...) (generate-temporaries #'(id ...))]) 535 #'(begin 536 (define-for-syntax prim-ids (syntax->list #'(id ...))) 537 (provide (rename-out [id2 id] ...)) 538 (define-syntax id2 (mk-id-macro #'id)) ...))])) 539 540(provide-flat-prims/lift 541 prim-ids 542 symbol? boolean? number? symbol=? 543 add1 sub1 zero? + - * / even? odd? = < > <= >=) 544 545(define (member? v l) 546 (and (member v l) #t)) 547(define (mutator-member? v l) 548 (do-alloc-flat 549 (member? (collector:deref v) 550 (gc->scheme l)))) 551 552(provide (rename-out (mutator-set-first! set-first!))) 553(define-syntax (mutator-set-first! stx) 554 (syntax-case stx () 555 [x 556 (identifier? #'x) 557 (raise-syntax-error 'set-first! "must appear immediately following an open paren" stx)] 558 [(_ args ...) 559 (begin 560 #'(mutator-app collector:set-first! args ...))])) 561 562(provide (rename-out (mutator-set-rest! set-rest!))) 563(define-syntax (mutator-set-rest! stx) 564 (syntax-case stx () 565 [x 566 (identifier? #'x) 567 (raise-syntax-error 'set-rest! "must appear immediately following an open paren" stx)] 568 [(_ args ...) 569 (begin 570 #'(mutator-app collector:set-rest! args ...))])) 571 572(provide (rename-out [mutator-empty empty])) 573(define-syntax mutator-empty 574 (syntax-id-rules (mutator-empty) 575 [_ (mutator-quote ())])) 576 577(provide (rename-out (mutator-empty? empty?))) 578(define (mutator-empty? loc) 579 (cond 580 [(collector:flat? loc) 581 (do-alloc-flat (empty? (collector:deref loc)))] 582 [else 583 (do-alloc-flat false)])) 584 585(provide (rename-out [mutator-cons? cons?])) 586(define (mutator-cons? loc) 587 (do-alloc-flat (collector:cons? loc))) 588 589(provide (rename-out [mutator-eq? eq?])) 590(define (mutator-eq? l1 l2) 591 (do-alloc-flat (= l1 l2))) 592 593(provide (rename-out [mutator-printf printf])) 594(define-syntax (mutator-printf stx) 595 (syntax-case stx () 596 [(_ fmt arg ...) 597 ; We must invoke mutator-app to A-normalize the arguments. 598 (syntax/loc stx 599 (begin 600 (mutator-app printf (#%datum . fmt) 601 (mutator-app gc->scheme arg) ...) 602 (void)))])) 603 604(provide (rename-out 605 (mutator-halt-on-errors halt-on-errors) 606 (mutator-print-only-errors print-only-errors))) 607(define-syntax (mutator-halt-on-errors stx) 608 (syntax-case stx () 609 [(_) #'(halt-on-errors)] 610 [(_ arg) #'(#%app halt-on-errors (#%datum . arg))])) 611 612(define-syntax (mutator-print-only-errors stx) 613 (syntax-case stx () 614 [(_) #'(print-only-errors)] 615 [(_ arg) #'(#%app print-only-errors (#%datum . arg))])) 616 617; Implementation Functions 618(define (deref-proc proc/loc) 619 (define v 620 (cond 621 [(procedure? proc/loc) proc/loc] 622 [(location? proc/loc) (collector:closure-code-ptr proc/loc)] 623 [else 624 (error 'procedure-application "expected procedure, given something else")])) 625 (cond 626 [(procedure? v) 627 v] 628 [(closure-code? v) 629 (lambda args 630 (apply (closure-code-proc v) 631 (append 632 (for/list ([i (in-range (closure-code-env-count v))]) 633 (collector:closure-env-ref proc/loc i)) 634 args)))] 635 [else 636 (error 'procedure-application "expected procedure, given ~e" v)])) 637 638(define (gc->scheme loc) 639 (define-struct an-unset ()) 640 (define unset (make-an-unset)) 641 (define phs (make-hash)) 642 (define (unwrap loc) 643 (if (hash-has-key? phs loc) 644 (hash-ref phs loc) 645 (begin 646 (local [(define ph (make-placeholder unset))] 647 (hash-set! phs loc ph) 648 (cond 649 [(collector:flat? loc) 650 (placeholder-set! ph (collector:deref loc))] 651 [(collector:cons? loc) 652 (local [(define car-ph (make-placeholder unset)) 653 (define cdr-ph (make-placeholder unset))] 654 (placeholder-set! ph (cons car-ph cdr-ph)) 655 (placeholder-set! car-ph (unwrap (collector:first loc))) 656 (placeholder-set! cdr-ph (unwrap (collector:rest loc))))] 657 [(collector:closure? loc) 658 ;; XXX get env? 659 (placeholder-set! ph (closure-code-proc (collector:closure-code-ptr loc)))] 660 [else 661 (error (format "gc:flat?, gc:cons?, gc:closure? all returned false for ~a" loc))]) 662 (placeholder-get ph))))) 663 (make-reader-graph (unwrap loc))) 664 665;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 666;;; Testing support 667 668(define-syntax (test/location=? stx) 669 (syntax-case stx () 670 [(_ e1 e2) 671 (quasisyntax/loc stx 672 (generic-test 673 (λ () e1) 674 (λ (result-value) 675 (define expected-val e2) 676 (values 677 (cond 678 [(exn:plai? result-value) result-value] 679 [(equal~? result-value expected-val) true] 680 [else false]) 681 expected-val)) 682 (quote (heap-loc #,(syntax->datum #'e1))) 683 (format "at line ~a" #,(syntax-line stx))))])) 684 685(define-for-syntax (flat-heap-value? v) 686 (or (number? v) (boolean? v))) 687 688(define-syntax (expand-scheme stx) 689 (syntax-case stx (mutator-quote mutator-datum) 690 [(_ val) (flat-heap-value? (syntax->datum #'val)) #'(#%datum . val)] 691 [(_ (mutator-datum . val)) 692 #'(#%datum . val)] 693 [(_ (mutator-quote e)) 694 #'(quote e)] 695 [_ 696 (raise-syntax-error 'test/value=? "must be a number, boolean or a quoted value" stx)])) 697 698(define-syntax (test/value=? stx) 699 (syntax-case stx (mutator-quote) 700 [(_ mutator-expr scheme-datum) 701 (quasisyntax/loc stx 702 (generic-test 703 (λ () 704 (mutator-let ([v1 mutator-expr]) 705 (gc->scheme v1))) 706 (λ (result-value) 707 (define expected-val (expand-scheme scheme-datum)) 708 (values 709 (cond 710 [(exn:plai? result-value) result-value] 711 [(equal~? result-value expected-val) true] 712 [else false]) 713 expected-val)) 714 (quote #,(syntax->datum #'mutator-expr)) 715 (format "at line ~a" #,(syntax-line stx))))])) 716