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