Test cleanup
svn: r18150
This commit is contained in:
Jay McCarthy
parent
b51f3e0940
commit
25dbc6a418
|
|
@ -272,9 +272,9 @@
|
|||
(gc->scheme result-addr)])])))]))
|
||||
|
||||
; Module Begin
|
||||
(define-for-syntax required-allocator-stx false)
|
||||
|
||||
(define-for-syntax (allocator-setup-internal stx)
|
||||
(syntax-case stx ()
|
||||
[(collector-module heap-size)
|
||||
(with-syntax ([(init-allocator gc:deref gc:alloc-flat gc:cons
|
||||
gc:first gc:rest
|
||||
gc:flat? gc:cons?
|
||||
|
|
@ -284,13 +284,7 @@
|
|||
gc:first gc:rest
|
||||
gc:flat? gc:cons?
|
||||
gc:set-first! gc:set-rest!))])
|
||||
(syntax-case stx ()
|
||||
[(collector-module heap-size)
|
||||
(begin
|
||||
(set! required-allocator-stx
|
||||
(if (alternate-collector)
|
||||
(datum->syntax stx (alternate-collector))
|
||||
#'collector-module))
|
||||
#`(begin
|
||||
#,(if (alternate-collector)
|
||||
#`(require #,(datum->syntax #'collector-module (alternate-collector)))
|
||||
|
|
@ -311,10 +305,10 @@
|
|||
(if (<= (#%datum . heap-size) 500)
|
||||
(set-ui! (dynamic-require `plai/private/gc-gui 'heap-viz%))
|
||||
(printf "Large heap; the heap visualizer will not be displayed.~n")))
|
||||
(init-allocator)))]
|
||||
(init-allocator))))]
|
||||
[_ (raise-syntax-error 'mutator
|
||||
"Mutator must start with an 'allocator-setup' expression, such as: (allocator-setup <literal-string> <literal-number>)"
|
||||
stx)])))
|
||||
stx)]))
|
||||
|
||||
(define-for-syntax allocator-setup-error-msg
|
||||
"Mutator must start with an 'allocator-setup' expression, such as: (allocator-setup <literal-string> <literal-number>)")
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang plai/mutator
|
||||
(allocator-setup "../good-collectors/no-compact-cheat.ss" 100)
|
||||
(allocator-setup "../good-collectors/good-collector.ss" 100)
|
||||
(define x (cons 1 2))
|
||||
((set-first! x 2) 1)
|
||||
|
|
@ -1,129 +1,86 @@
|
|||
#lang plai/collector
|
||||
; This collector was written by Robby.
|
||||
; It is advanced and particular enough, that I do not expect a student would be brazen enough to copy or plagiarize it, so it is public.
|
||||
|
||||
(print-only-errors #t)
|
||||
|
||||
#|
|
||||
|
||||
heap-layout:
|
||||
|
||||
0 during gc : left-side of queue
|
||||
non-gc time : free pointer
|
||||
1 during-gc : right-side-of-queue
|
||||
non-gc time : out of memory pointer
|
||||
2 '()
|
||||
3 #f
|
||||
4 #t
|
||||
5 0
|
||||
6 1
|
||||
7 2
|
||||
8 3
|
||||
9 4
|
||||
10 .... (n-10/2): space 1.
|
||||
(n-10/2)+1 ... n: space 2.
|
||||
A collector for use in testing the random mutator generator.
|
||||
|
||||
|#
|
||||
|
||||
;; the bounds on the initial half of a heap.
|
||||
(define (first-start) 10)
|
||||
(define (second-start)
|
||||
(unless (even? (- (heap-size) (first-start)))
|
||||
(error 'second-start "bad heap size ~s" (heap-size)))
|
||||
(+ (first-start) (/ (- (heap-size) (first-start)) 2)))
|
||||
(print-only-errors #t)
|
||||
|
||||
(define (find-free-space start size)
|
||||
(cond
|
||||
[(= start (heap-size))
|
||||
#f]
|
||||
[(n-free-blocks? start size)
|
||||
start]
|
||||
[else
|
||||
(find-free-space (+ start 1) size)]))
|
||||
|
||||
(define (n-free-blocks? start size)
|
||||
(cond
|
||||
[(= size 0) #t]
|
||||
[(= start (heap-size)) #f]
|
||||
[else
|
||||
(and (eq? 'free (heap-ref start))
|
||||
(n-free-blocks? (+ start 1) (- size 1)))]))
|
||||
|
||||
(test (with-heap #(free free free)
|
||||
(n-free-blocks? 0 2))
|
||||
#t)
|
||||
(test (with-heap #(free free free)
|
||||
(n-free-blocks? 0 3))
|
||||
#t)
|
||||
(test (with-heap #(free free free)
|
||||
(n-free-blocks? 0 4))
|
||||
#f)
|
||||
(test (with-heap #(free free free)
|
||||
(n-free-blocks? 2 1))
|
||||
#t)
|
||||
(test (with-heap #(free free free)
|
||||
(n-free-blocks? 2 2))
|
||||
#f)
|
||||
|
||||
(test (with-heap #(free free free)
|
||||
(find-free-space 0 1))
|
||||
0)
|
||||
(test (with-heap #(pair free free)
|
||||
(find-free-space 0 1))
|
||||
1)
|
||||
(test (with-heap #(pair free free)
|
||||
(find-free-space 0 2))
|
||||
1)
|
||||
(test (with-heap #(pair free free)
|
||||
(find-free-space 0 3))
|
||||
#f)
|
||||
|
||||
(define (init-allocator)
|
||||
(unless (even? (heap-size))
|
||||
(error 'two-space.ss "must have an even sized heap"))
|
||||
(when (<= (heap-size) 10)
|
||||
(error 'two-space.ss "heap too small"))
|
||||
(for ([i (in-range 0 (heap-size))])
|
||||
(heap-set!
|
||||
i
|
||||
(cond
|
||||
[(= i 0) (first-start)]
|
||||
[(= i 1) (second-start)]
|
||||
[(immediate-loc? i) (immediate-loc->val i)]
|
||||
[(< i (second-start)) 'free]
|
||||
[else 'bad]))))
|
||||
|
||||
(define (immediate-loc? i) (< 1 i (first-start)))
|
||||
|
||||
(define (immediate-loc->val i)
|
||||
(case i
|
||||
[(2) #f]
|
||||
[(3) #t]
|
||||
[(4) '()]
|
||||
[else (- i 5)]))
|
||||
|
||||
(define (immediate-val? v)
|
||||
(or (and (exact-integer? v)
|
||||
(<= 0 v 4))
|
||||
(eq? v #t)
|
||||
(eq? v #f)
|
||||
(eq? v null)))
|
||||
|
||||
(define (immediate-val->loc v)
|
||||
(case v
|
||||
[(#f) 2]
|
||||
[(#t) 3]
|
||||
[(()) 4]
|
||||
[else (+ v 5)]))
|
||||
|
||||
(test (immediate-loc? 1) #f)
|
||||
(test (immediate-loc? 2) #t)
|
||||
(test (immediate-loc? 4) #t)
|
||||
(test (immediate-loc? 10) #f)
|
||||
(test (immediate-loc->val 5) 0)
|
||||
(test (immediate-loc->val 4) '())
|
||||
(test (immediate-val->loc (immediate-loc->val 2)) 2)
|
||||
(test (immediate-val->loc (immediate-loc->val 3)) 3)
|
||||
(test (immediate-val->loc (immediate-loc->val 4)) 4)
|
||||
(test (immediate-val->loc (immediate-loc->val 5)) 5)
|
||||
(test (immediate-val->loc (immediate-loc->val 6)) 6)
|
||||
(test (immediate-val->loc (immediate-loc->val 7)) 7)
|
||||
(test (immediate-val->loc (immediate-loc->val 8)) 8)
|
||||
(test (immediate-val->loc (immediate-loc->val 9)) 9)
|
||||
|
||||
(define (mkheap alloc-ptr alloc-stop . args)
|
||||
(unless (and (number? alloc-ptr) (number? alloc-stop))
|
||||
(error 'mkheap "expected numbers for first two args, got ~e and ~e" alloc-ptr alloc-stop))
|
||||
(apply vector (append (list alloc-ptr alloc-stop #f #t '() 0 1 2 3 4) args)))
|
||||
(heap-set! i 'free)))
|
||||
|
||||
(test (let ([v (make-vector 12 'x)])
|
||||
(with-heap v (init-allocator))
|
||||
v)
|
||||
(mkheap 10 11 'free 'bad))
|
||||
|
||||
(test (let ([v (make-vector 20 'x)])
|
||||
(with-heap v (init-allocator))
|
||||
v)
|
||||
(mkheap 10 15
|
||||
'free 'free 'free 'free 'free
|
||||
'bad 'bad 'bad 'bad 'bad))
|
||||
(make-vector 12 'free))
|
||||
|
||||
(define (gc:deref loc)
|
||||
(cond
|
||||
[(immediate-loc? loc)
|
||||
(immediate-loc->val loc)]
|
||||
[(equal? (heap-ref loc) 'flat)
|
||||
(heap-ref (+ loc 1))]
|
||||
[else
|
||||
(error 'gc:deref "attempted to deref a non flat value, loc ~s" loc)]))
|
||||
|
||||
(test (with-heap (mkheap 10 20 'flat 14)
|
||||
(gc:deref 10))
|
||||
(test (with-heap (vector 'free 'free 'free 'flat 14 'free 'free)
|
||||
(gc:deref 3))
|
||||
14)
|
||||
(test (gc:deref 2) #f)
|
||||
(test (gc:deref 3) #t)
|
||||
|
||||
(define (gc:first pr-ptr)
|
||||
(if (equal? (heap-ref pr-ptr) 'pair)
|
||||
(heap-ref (+ pr-ptr 1))
|
||||
(error 'first "non pair")))
|
||||
|
||||
(test (with-heap (mkheap 10 20 'pair 0 1)
|
||||
(gc:first 10))
|
||||
(test (with-heap (vector 'free 'flat 3 'pair 0 1)
|
||||
(gc:first 3))
|
||||
0)
|
||||
|
||||
(define (gc:rest pr-ptr)
|
||||
|
|
@ -131,39 +88,25 @@ heap-layout:
|
|||
(heap-ref (+ pr-ptr 2))
|
||||
(error 'first "non pair")))
|
||||
|
||||
(test (with-heap (mkheap 10 20 'pair 0 1)
|
||||
(gc:rest 10))
|
||||
(test (with-heap (vector 'free 'flat 3 'pair 0 1)
|
||||
(gc:rest 3))
|
||||
1)
|
||||
|
||||
(define (gc:flat? loc)
|
||||
(cond
|
||||
[(< loc (first-start)) #t]
|
||||
[(equal? (heap-ref loc) 'flat) #t]
|
||||
[else #f]))
|
||||
(define (gc:flat? loc) (equal? (heap-ref loc) 'flat))
|
||||
|
||||
(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
|
||||
(gc:flat? 12))
|
||||
(test (with-heap (vector 'free 'free 'pair 0 1 'flat 14)
|
||||
(gc:flat? 2))
|
||||
#f)
|
||||
(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
|
||||
(gc:flat? 15))
|
||||
#t)
|
||||
(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
|
||||
(test (with-heap (vector 'free 'free 'pair 0 1 'flat 14)
|
||||
(gc:flat? 5))
|
||||
#t)
|
||||
|
||||
(define (gc:cons? loc)
|
||||
(cond
|
||||
[(< loc (first-start)) #f]
|
||||
[else
|
||||
(equal? (heap-ref loc) 'pair)]))
|
||||
(define (gc:cons? loc) (equal? (heap-ref loc) 'pair))
|
||||
|
||||
(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
|
||||
(gc:cons? 12))
|
||||
(test (with-heap (vector 'free 'free 'pair 0 1 'flat 14)
|
||||
(gc:cons? 2))
|
||||
#t)
|
||||
(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
|
||||
(gc:cons? 15))
|
||||
#f)
|
||||
(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
|
||||
(test (with-heap (vector 'free 'free 'pair 0 1 'flat 14)
|
||||
(gc:cons? 5))
|
||||
#f)
|
||||
|
||||
|
|
@ -172,375 +115,160 @@ heap-layout:
|
|||
(heap-set! (+ pr-ptr 1) new)
|
||||
(error 'set-first! "non pair")))
|
||||
|
||||
(test (let ([h (mkheap 10 20 'pair 2 2)])
|
||||
(with-heap h (gc:set-first! 10 3))
|
||||
h)
|
||||
(mkheap 10 20 'pair 3 2))
|
||||
|
||||
(define (gc:set-rest! pr-ptr new)
|
||||
(if (equal? (heap-ref pr-ptr) 'pair)
|
||||
(heap-set! (+ pr-ptr 2) new)
|
||||
(error 'set-first! "non pair")))
|
||||
|
||||
(test (let ([h (mkheap 10 20 'pair 2 2)])
|
||||
(with-heap h (gc:set-rest! 10 3))
|
||||
h)
|
||||
(mkheap 10 20 'pair 2 3))
|
||||
|
||||
(define (gc:alloc-flat fv)
|
||||
(cond
|
||||
[(immediate-val? fv)
|
||||
(immediate-val->loc fv)]
|
||||
[else
|
||||
(let ([ptr (alloc 2)])
|
||||
(cond
|
||||
[ptr
|
||||
(fill-in-flat ptr fv)]
|
||||
[else
|
||||
(init-gc)
|
||||
(when (procedure? fv)
|
||||
(move-roots (procedure-roots fv)))
|
||||
(collect-garbage)
|
||||
(let ([ptr (alloc 2)])
|
||||
(unless ptr
|
||||
(error 'two-space.ss "out of memory"))
|
||||
(fill-in-flat ptr fv))]))]))
|
||||
|
||||
(define (fill-in-flat ptr fv)
|
||||
(let ([ptr (alloc 2 (λ ()
|
||||
(if (procedure? fv)
|
||||
(append (procedure-roots fv)
|
||||
(get-root-set))
|
||||
(get-root-set))))])
|
||||
(heap-set! ptr 'flat)
|
||||
(heap-set! (+ ptr 1) fv)
|
||||
ptr)
|
||||
ptr))
|
||||
|
||||
(define (gc:cons hd tl)
|
||||
(let ([ptr (alloc 3)])
|
||||
(cond
|
||||
[ptr
|
||||
(fill-in-cons ptr hd tl)]
|
||||
[else
|
||||
(init-gc)
|
||||
(let ([new-hd (move-loc hd)]
|
||||
[new-tl (move-loc tl)])
|
||||
(collect-garbage)
|
||||
(let ([ptr (alloc 3)])
|
||||
(unless ptr
|
||||
(error 'two-space.ss "out of memory"))
|
||||
(fill-in-cons ptr new-hd new-tl)))])))
|
||||
|
||||
(define (fill-in-cons ptr hd tl)
|
||||
(let ([ptr (alloc 3 (λ () (get-root-set hd tl)))])
|
||||
(heap-set! ptr 'pair)
|
||||
(heap-set! (+ ptr 1) hd)
|
||||
(heap-set! (+ ptr 2) tl)
|
||||
ptr)
|
||||
ptr))
|
||||
|
||||
;; alloc : number -> boolean
|
||||
;; returns #f if nothing can be allocated
|
||||
(define (alloc n)
|
||||
(let ([next (heap-ref 0)])
|
||||
(define (alloc n get-roots)
|
||||
(let ([next (find-free-space 0 n)])
|
||||
(cond
|
||||
[(<= (+ next n) (heap-ref 1))
|
||||
(heap-set! 0 (+ next n))
|
||||
[next
|
||||
next]
|
||||
[else
|
||||
#f])))
|
||||
(collect-garbage get-roots)
|
||||
(let ([next (find-free-space 0 n)])
|
||||
(unless next
|
||||
(error 'alloc "out of space"))
|
||||
next)])))
|
||||
|
||||
(test (let ([h (mkheap 16 16
|
||||
'fwd 17 'flat 112 'pair 10 10
|
||||
'free 'free 'free 'free 'free 'free 'free)])
|
||||
(with-heap h (alloc 3)))
|
||||
#f)
|
||||
(define (collect-garbage get-roots)
|
||||
(let ([roots (map read-root (get-roots))])
|
||||
(collect-garbage-help roots
|
||||
(remove* roots (get-all-records 0)))))
|
||||
|
||||
(test (let ([h (mkheap 10 16
|
||||
'free 'free 'free 'free 'free 'free 'free
|
||||
'free 'free 'free 'free 'free 'free 'free)])
|
||||
(with-heap h (alloc 3))
|
||||
h)
|
||||
(mkheap 13 16
|
||||
'free 'free 'free 'free 'free 'free 'free
|
||||
'free 'free 'free 'free 'free 'free 'free))
|
||||
|
||||
(define (init-gc)
|
||||
(define (collect-garbage-help gray white)
|
||||
(cond
|
||||
[(< (heap-ref 0) (second-start))
|
||||
(heap-set! 0 (second-start))]
|
||||
[(null? gray) (free! white)]
|
||||
[else
|
||||
(heap-set! 0 (first-start))])
|
||||
(heap-set! 1 (heap-ref 0)))
|
||||
|
||||
(test (let ([h (mkheap 16 16
|
||||
'fwd 17 'flat 112 'pair 10 10
|
||||
'free 'free 'free 'free 'free 'free 'free)])
|
||||
(with-heap h (init-gc))
|
||||
h)
|
||||
(mkheap 17 17
|
||||
'fwd 17 'flat 112 'pair 10 10
|
||||
'free 'free 'free 'free 'free 'free 'free))
|
||||
|
||||
(test (let ([h (mkheap 15 16
|
||||
'fwd 17 'flat 112 'pair 10 10
|
||||
'free 'free 'free 'free 'free 'free 'free)])
|
||||
(with-heap h (init-gc))
|
||||
h)
|
||||
(mkheap 17 17
|
||||
'fwd 17 'flat 112 'pair 10 10
|
||||
'free 'free 'free 'free 'free 'free 'free))
|
||||
|
||||
(define (finalize-gc)
|
||||
(heap-set! 0 (heap-ref 1))
|
||||
(cond
|
||||
[(< (heap-ref 0) (second-start))
|
||||
(heap-set! 1 (second-start))
|
||||
(for ([i (in-range (second-start) (heap-size))])
|
||||
(heap-set! i 'bad))]
|
||||
[else
|
||||
(heap-set! 1 (heap-size))
|
||||
(for ([i (in-range (first-start) (second-start))])
|
||||
(heap-set! i 'bad))])
|
||||
(for ([i (in-range (heap-ref 0) (heap-ref 1))])
|
||||
(heap-set! i 'free)))
|
||||
|
||||
(test (let ([h (mkheap 20 20
|
||||
'flat 17 'flat 12 'free 'free 'free
|
||||
'pair 12 10 'free 'free 'free 'free)])
|
||||
(with-heap h (finalize-gc))
|
||||
h)
|
||||
(mkheap 20 24
|
||||
'bad 'bad 'bad 'bad 'bad 'bad 'bad
|
||||
'pair 12 10 'free 'free 'free 'free))
|
||||
|
||||
(test (let ([h (mkheap 14 14
|
||||
'flat 17 'flat 12 'free 'free 'free
|
||||
'pair 12 10 'free 'free 'free 'free)])
|
||||
(with-heap h (finalize-gc))
|
||||
h)
|
||||
(mkheap 14 17
|
||||
'flat 17 'flat 12 'free 'free 'free
|
||||
'bad 'bad 'bad 'bad 'bad 'bad 'bad))
|
||||
|
||||
(define (collect-garbage)
|
||||
(move-roots (get-root-set))
|
||||
(copy-data)
|
||||
(finalize-gc))
|
||||
|
||||
;; move-roots : (listof roots) -> void
|
||||
(define (move-roots roots)
|
||||
(cond
|
||||
[(null? roots) (void)]
|
||||
[else
|
||||
(set-root! (car roots) (move-loc (read-root (car roots))))
|
||||
(move-roots (cdr roots))]))
|
||||
|
||||
;; move-loc : loc[from-space] -> loc[to-space]
|
||||
(define (move-loc loc)
|
||||
(cond
|
||||
[(immediate-loc? loc)
|
||||
loc]
|
||||
[else
|
||||
(case (heap-ref loc)
|
||||
[(fwd) (heap-ref (+ loc 1))]
|
||||
[(pair)
|
||||
(let ([dest (heap-ref 1)])
|
||||
(heap-set! dest 'pair)
|
||||
(heap-set! (+ dest 1) (heap-ref (+ loc 1)))
|
||||
(heap-set! (+ dest 2) (heap-ref (+ loc 2)))
|
||||
(heap-set! 1 (+ dest 3))
|
||||
(heap-set! loc 'fwd)
|
||||
(heap-set! (+ loc 1) dest)
|
||||
(heap-set! (+ loc 2) 'junk)
|
||||
dest)]
|
||||
(case (heap-ref (car gray))
|
||||
[(flat)
|
||||
(let ([dest (heap-ref 1)])
|
||||
(heap-set! dest 'flat)
|
||||
(heap-set! (+ dest 1) (heap-ref (+ loc 1)))
|
||||
(heap-set! 1 (+ dest 2))
|
||||
(heap-set! loc 'fwd)
|
||||
(heap-set! (+ loc 1) dest)
|
||||
dest)]
|
||||
[else
|
||||
(error 'move-loc "found a non-tag at location ~a" loc)])]))
|
||||
|
||||
(test (move-loc 4) 4)
|
||||
|
||||
(test (let ([v (mkheap 15 15
|
||||
'fwd 17 'free 'free 'free
|
||||
'free 'free 'free 'free 'free)])
|
||||
(list (with-heap v (move-loc 10))
|
||||
v))
|
||||
(list 17
|
||||
(mkheap 15 15
|
||||
'fwd 17 'free 'free 'free
|
||||
'free 'free 'free 'free 'free)))
|
||||
|
||||
(test (let ([v (mkheap 15 15
|
||||
'flat 13 'free 'free 'free
|
||||
'free 'free 'free 'free 'free)])
|
||||
(list (with-heap v (move-loc 10))
|
||||
v))
|
||||
(list 15
|
||||
(mkheap 15 17
|
||||
'fwd 15 'free 'free 'free
|
||||
'flat 13 'free 'free 'free)))
|
||||
|
||||
(test (let ([v (mkheap 15 15
|
||||
'pair 10 10 'free 'free
|
||||
'free 'free 'free 'free 'free)])
|
||||
(list (with-heap v (move-loc 10))
|
||||
v))
|
||||
(list 15
|
||||
(mkheap 15 18
|
||||
'fwd 15 'junk 'free 'free
|
||||
'pair 10 10 'free 'free)))
|
||||
|
||||
(define (copy-data)
|
||||
(let ([left (heap-ref 0)]
|
||||
[right (heap-ref 1)])
|
||||
(when (< left right)
|
||||
(case (heap-ref left)
|
||||
(let ([proc (heap-ref (+ (car gray) 1))])
|
||||
(if (procedure? proc)
|
||||
(let ([new-locs (map read-root (procedure-roots proc))])
|
||||
(collect-garbage-help
|
||||
(add-in new-locs (cdr gray) white)
|
||||
(remove* new-locs white)))
|
||||
(collect-garbage-help (cdr gray) white)))]
|
||||
[(pair)
|
||||
(maybe-move/loc left 1)
|
||||
(maybe-move/loc left 2)
|
||||
(heap-set! 0 (+ left 3))]
|
||||
(let ([hd (heap-ref (+ (car gray) 1))]
|
||||
[tl (heap-ref (+ (car gray) 2))])
|
||||
(collect-garbage-help
|
||||
(add-in (list hd tl) (cdr gray) white)
|
||||
(remove tl (remove hd white))))]
|
||||
[else
|
||||
(error 'collect-garbage "unknown tag ~s, loc ~s" (heap-ref (car gray)) (car gray))])]))
|
||||
|
||||
(define (free! whites)
|
||||
(cond
|
||||
[(null? whites) (void)]
|
||||
[else
|
||||
(let ([white (car whites)])
|
||||
(case (heap-ref white)
|
||||
[(pair)
|
||||
(heap-set! white 'free)
|
||||
(heap-set! (+ white 1) 'free)
|
||||
(heap-set! (+ white 2) 'free)]
|
||||
[(flat)
|
||||
(heap-set! 0 (+ left 2))]
|
||||
[(proc)
|
||||
(maybe-move/roots left (procedure-roots (heap-ref (+ left 1))))
|
||||
(heap-set! 0 (+ left 2))]
|
||||
(heap-set! white 'free)
|
||||
(heap-set! (+ white 1) 'free)]
|
||||
[else
|
||||
(error 'copy-data "unknown tag ~s" (heap-ref left))])
|
||||
(copy-data))))
|
||||
(error 'free! "unknown tag ~s\n" (heap-ref white))])
|
||||
(free! (cdr whites)))]))
|
||||
|
||||
;; maybe-move/loc : loc[to-space] offset -> void
|
||||
;; moves the pointer at record+offset if it is in a different
|
||||
;; semispace from record.
|
||||
(define (maybe-move/loc record delta)
|
||||
(let ([pointer (heap-ref (+ record delta))])
|
||||
(unless (different-halves? record pointer)
|
||||
(error 'maybe-move/loc "tried to move a pointer that was in the from space already ~s ~s" record pointer))
|
||||
;; now we know pointer is in the from-space
|
||||
(heap-set! (+ record delta) (move-loc pointer))))
|
||||
(test (let ([v (vector #f #t '() 0 1 2 3 4 5 6 'pair 0 1 'flat 14 'pair 0 1 'flat 12)])
|
||||
(with-heap v (free! (list 10 18)))
|
||||
v)
|
||||
(vector #f #t '() 0 1 2 3 4 5 6 'free 'free 'free 'flat 14 'pair 0 1 'free 'free))
|
||||
|
||||
;; maybe-move/roots : loc[to-space] (listof root) -> void
|
||||
(define (maybe-move/roots record roots)
|
||||
;; add-in : (listof location) (listof location) (listof location) -> (listof location)
|
||||
;; computes a new set of gray addresses by addding all white elements of locs to gray
|
||||
(define (add-in locs gray white)
|
||||
(cond
|
||||
[(null? roots) (void)]
|
||||
[(null? locs) gray]
|
||||
[else
|
||||
(maybe-move/root record (car roots))
|
||||
(maybe-move/roots record (cdr roots))]))
|
||||
(let* ([loc (car locs)]
|
||||
[white? (member loc white)])
|
||||
(add-in (cdr locs)
|
||||
(if white? (cons loc gray) gray)
|
||||
white))]))
|
||||
|
||||
;; maybe-move/root : loc[to-space] root -> void
|
||||
;; moves the pointer in the root if it is in a different
|
||||
;; semispace from record.
|
||||
(define (maybe-move/root record root)
|
||||
(let ([pointer (read-root root)])
|
||||
(unless (different-halves? record pointer)
|
||||
(error 'maybe-move/root "tried to move a pointer that was in the from space already"))
|
||||
;; now we know pointer is in the from-space
|
||||
(set-root! root (move-loc pointer))))
|
||||
(test (add-in '(13 14) '(100 102) '(13 14 104 105))
|
||||
'(14 13 100 102))
|
||||
|
||||
;; different-halves? : loc loc -> boolean
|
||||
;; returns #t if n and m are in different halves of the heap.
|
||||
(define (different-halves? n m)
|
||||
(test (add-in '(13 14) '(100 102) '(13 104 105))
|
||||
'(13 100 102))
|
||||
|
||||
(define (get-all-records i)
|
||||
(cond
|
||||
[(or (immediate-loc? n)
|
||||
(immediate-loc? m))
|
||||
#f]
|
||||
[else
|
||||
(not (equal? (< n (second-start))
|
||||
(< m (second-start))))]))
|
||||
[(< i (heap-size))
|
||||
(case (heap-ref i)
|
||||
[(pair) (cons i (get-all-records (+ i 3)))]
|
||||
[(flat) (cons i (get-all-records (+ i 2)))]
|
||||
[(free) (get-all-records (+ i 1))]
|
||||
[else (get-all-records (+ i 1))])]
|
||||
[else null]))
|
||||
|
||||
(test (different-halves? 2 3) #f)
|
||||
(test (with-heap (vector #f #t '() 0 1 2 3 4 5 6 'pair 0 1 'flat 14 'pair 0 1 'flat 12)
|
||||
(get-all-records 0))
|
||||
(list 10 13 15 18))
|
||||
|
||||
(test (with-heap (mkheap 10 15
|
||||
'free 'free 'free 'free 'free
|
||||
'free 'free 'free 'free 'free)
|
||||
(different-halves? 12 13))
|
||||
#f)
|
||||
(test (with-heap (mkheap 10 15
|
||||
'free 'free 'free 'free 'free
|
||||
'free 'free 'free 'free 'free)
|
||||
(different-halves? 12 17))
|
||||
#t)
|
||||
(test (with-heap (mkheap 10 15
|
||||
'free 'free 'free 'free 'free
|
||||
'free 'free 'free 'free 'free)
|
||||
(different-halves? 16 17))
|
||||
#f)
|
||||
(test (with-heap (mkheap 10 15
|
||||
'free 'free 'free 'free 'free
|
||||
'free 'free 'free 'free 'free)
|
||||
(different-halves? 17 12))
|
||||
#t)
|
||||
(test (with-heap (make-vector 10 'free) (gc:alloc-flat #f))
|
||||
0)
|
||||
|
||||
(test (with-heap (mkheap 17 20
|
||||
'fwd 17 'junk 'free 'free 'free 'free
|
||||
'pair 11 11 'free 'free 'free 'free)
|
||||
(different-halves? 17 11))
|
||||
#t)
|
||||
(test (with-heap (make-vector 10 'free) (gc:alloc-flat #t) (gc:alloc-flat #f))
|
||||
2)
|
||||
|
||||
(test (let ([h (mkheap 17 22
|
||||
'fwd 17 'free 'free 'free 'free 'free
|
||||
'flat 11 'pair 17 10 'free 'free)])
|
||||
(with-heap h (maybe-move/loc 19 2))
|
||||
h)
|
||||
(mkheap 17 22
|
||||
'fwd 17 'free 'free 'free 'free 'free
|
||||
'flat 11 'pair 17 17 'free 'free))
|
||||
(test (let ([v (vector 'flat 0 'flat 1)])
|
||||
(with-heap v (collect-garbage-help (list)
|
||||
(get-all-records 0)))
|
||||
v)
|
||||
(vector 'free 'free 'free 'free))
|
||||
|
||||
(test (let ([h (mkheap 17 22
|
||||
'flat 12 'free 'free 'free 'free 'free
|
||||
'flat 11 'pair 17 10 'free 'free)])
|
||||
(with-heap h (maybe-move/loc 19 2))
|
||||
h)
|
||||
(mkheap 17 24
|
||||
'fwd 22 'free 'free 'free 'free 'free
|
||||
'flat 11 'pair 17 22 'flat '12))
|
||||
(test (let ([v (vector 'flat 0 'flat 1)])
|
||||
(with-heap v (collect-garbage-help (list 0)
|
||||
(remove 0 (get-all-records 0))))
|
||||
v)
|
||||
(vector 'flat 0 'free 'free))
|
||||
|
||||
(test (let ([h (mkheap 17 19
|
||||
'free 'free 'free 'free 'free 'free 'free
|
||||
'flat 11 'free 'free 'free 'free 'free)])
|
||||
(with-heap h (copy-data))
|
||||
h)
|
||||
(mkheap 19 19
|
||||
'free 'free 'free 'free 'free 'free 'free
|
||||
'flat 11 'free 'free 'free 'free 'free))
|
||||
(test (let ([v (vector 'flat 0 'flat 1)])
|
||||
(with-heap v (collect-garbage-help (list 2)
|
||||
(remove 2 (get-all-records 0))))
|
||||
v)
|
||||
(vector 'free 'free 'flat 1))
|
||||
|
||||
(test (let ([h (mkheap 17 20
|
||||
'fwd 17 'junk 'free 'free 'free 'free
|
||||
'pair 10 10 'free 'free 'free 'free)])
|
||||
(with-heap h (copy-data))
|
||||
h)
|
||||
(mkheap 20 20
|
||||
'fwd 17 'junk 'free 'free 'free 'free
|
||||
'pair 17 17 'free 'free 'free 'free))
|
||||
(test (let ([v (vector 'flat 0 'flat 1 'pair 0 2)])
|
||||
(with-heap v (collect-garbage-help (list 4)
|
||||
(remove 4 (get-all-records 0))))
|
||||
v)
|
||||
(vector 'flat 0 'flat 1 'pair 0 2))
|
||||
|
||||
(test (let ([h (mkheap 17 20
|
||||
'fwd 17 'flat 112 'free 'free 'free
|
||||
'pair 12 10 'free 'free 'free 'free)])
|
||||
(with-heap h (copy-data))
|
||||
h)
|
||||
(mkheap 22 22
|
||||
'fwd 17 'fwd 20 'free 'free 'free
|
||||
'pair 20 17 'flat 112 'free 'free))
|
||||
(test (let ([v (vector 'flat 0 'flat 1 'pair 0 0)])
|
||||
(with-heap v (collect-garbage-help (list 4)
|
||||
(remove 4 (get-all-records 0))))
|
||||
v)
|
||||
(vector 'flat 0 'free 'free 'pair 0 0))
|
||||
|
||||
(test (gc:alloc-flat 1)
|
||||
6)
|
||||
|
||||
|
||||
(test (let ([h (mkheap 15 17
|
||||
'flat 17 'pair 10 10 'free 'free
|
||||
'pair 12 10 'free 'free 'free 'free)])
|
||||
(list (with-heap h (gc:alloc-flat 111))
|
||||
h))
|
||||
(list 15
|
||||
(mkheap 17 17
|
||||
'flat 17 'pair 10 10 'flat 111
|
||||
'pair 12 10 'free 'free 'free 'free)))
|
||||
|
||||
(test (let ([h (mkheap 14 17
|
||||
'flat 17 'flat 12 'free 'free 'free
|
||||
'pair 12 10 'free 'free 'free 'free)])
|
||||
(list (with-heap h (gc:cons 10 10))
|
||||
h))
|
||||
(list 14
|
||||
(mkheap 17 17
|
||||
'flat 17 'flat 12 'pair 10 10
|
||||
'pair 12 10 'free 'free 'free 'free)))
|
||||
(test (let ([v (vector 'flat 0 'flat 1 'pair 4 4)])
|
||||
(with-heap v (collect-garbage-help (list 4)
|
||||
(remove 4 (get-all-records 0))))
|
||||
v)
|
||||
(vector 'free 'free 'free 'free 'pair 4 4))
|
||||
|
|
|
|||
|
|
@ -1,274 +0,0 @@
|
|||
#lang plai/collector
|
||||
|
||||
#|
|
||||
|
||||
A collector for use in testing the random mutator generator.
|
||||
|
||||
|#
|
||||
|
||||
(print-only-errors #t)
|
||||
|
||||
(define (find-free-space start size)
|
||||
(cond
|
||||
[(= start (heap-size))
|
||||
#f]
|
||||
[(n-free-blocks? start size)
|
||||
start]
|
||||
[else
|
||||
(find-free-space (+ start 1) size)]))
|
||||
|
||||
(define (n-free-blocks? start size)
|
||||
(cond
|
||||
[(= size 0) #t]
|
||||
[(= start (heap-size)) #f]
|
||||
[else
|
||||
(and (eq? 'free (heap-ref start))
|
||||
(n-free-blocks? (+ start 1) (- size 1)))]))
|
||||
|
||||
(test (with-heap #(free free free)
|
||||
(n-free-blocks? 0 2))
|
||||
#t)
|
||||
(test (with-heap #(free free free)
|
||||
(n-free-blocks? 0 3))
|
||||
#t)
|
||||
(test (with-heap #(free free free)
|
||||
(n-free-blocks? 0 4))
|
||||
#f)
|
||||
(test (with-heap #(free free free)
|
||||
(n-free-blocks? 2 1))
|
||||
#t)
|
||||
(test (with-heap #(free free free)
|
||||
(n-free-blocks? 2 2))
|
||||
#f)
|
||||
|
||||
(test (with-heap #(free free free)
|
||||
(find-free-space 0 1))
|
||||
0)
|
||||
(test (with-heap #(pair free free)
|
||||
(find-free-space 0 1))
|
||||
1)
|
||||
(test (with-heap #(pair free free)
|
||||
(find-free-space 0 2))
|
||||
1)
|
||||
(test (with-heap #(pair free free)
|
||||
(find-free-space 0 3))
|
||||
#f)
|
||||
|
||||
(define (init-allocator)
|
||||
(for ([i (in-range 0 (heap-size))])
|
||||
(heap-set! i 'free)))
|
||||
|
||||
(test (let ([v (make-vector 12 'x)])
|
||||
(with-heap v (init-allocator))
|
||||
v)
|
||||
(make-vector 12 'free))
|
||||
|
||||
(define (gc:deref loc)
|
||||
(cond
|
||||
[(equal? (heap-ref loc) 'flat)
|
||||
(heap-ref (+ loc 1))]
|
||||
[else
|
||||
(error 'gc:deref "attempted to deref a non flat value, loc ~s" loc)]))
|
||||
|
||||
(test (with-heap (vector 'free 'free 'free 'flat 14 'free 'free)
|
||||
(gc:deref 3))
|
||||
14)
|
||||
|
||||
(define (gc:first pr-ptr)
|
||||
(if (equal? (heap-ref pr-ptr) 'pair)
|
||||
(heap-ref (+ pr-ptr 1))
|
||||
(error 'first "non pair")))
|
||||
|
||||
(test (with-heap (vector 'free 'flat 3 'pair 0 1)
|
||||
(gc:first 3))
|
||||
0)
|
||||
|
||||
(define (gc:rest pr-ptr)
|
||||
(if (equal? (heap-ref pr-ptr) 'pair)
|
||||
(heap-ref (+ pr-ptr 2))
|
||||
(error 'first "non pair")))
|
||||
|
||||
(test (with-heap (vector 'free 'flat 3 'pair 0 1)
|
||||
(gc:rest 3))
|
||||
1)
|
||||
|
||||
(define (gc:flat? loc) (equal? (heap-ref loc) 'flat))
|
||||
|
||||
(test (with-heap (vector 'free 'free 'pair 0 1 'flat 14)
|
||||
(gc:flat? 2))
|
||||
#f)
|
||||
(test (with-heap (vector 'free 'free 'pair 0 1 'flat 14)
|
||||
(gc:flat? 5))
|
||||
#t)
|
||||
|
||||
(define (gc:cons? loc) (equal? (heap-ref loc) 'pair))
|
||||
|
||||
(test (with-heap (vector 'free 'free 'pair 0 1 'flat 14)
|
||||
(gc:cons? 2))
|
||||
#t)
|
||||
(test (with-heap (vector 'free 'free 'pair 0 1 'flat 14)
|
||||
(gc:cons? 5))
|
||||
#f)
|
||||
|
||||
(define (gc:set-first! pr-ptr new)
|
||||
(if (equal? (heap-ref pr-ptr) 'pair)
|
||||
(heap-set! (+ pr-ptr 1) new)
|
||||
(error 'set-first! "non pair")))
|
||||
|
||||
(define (gc:set-rest! pr-ptr new)
|
||||
(if (equal? (heap-ref pr-ptr) 'pair)
|
||||
(heap-set! (+ pr-ptr 2) new)
|
||||
(error 'set-first! "non pair")))
|
||||
|
||||
|
||||
(define (gc:alloc-flat fv)
|
||||
(let ([ptr (alloc 2 (λ ()
|
||||
(if (procedure? fv)
|
||||
(append (procedure-roots fv)
|
||||
(get-root-set))
|
||||
(get-root-set))))])
|
||||
(heap-set! ptr 'flat)
|
||||
(heap-set! (+ ptr 1) fv)
|
||||
ptr))
|
||||
|
||||
(define (gc:cons hd tl)
|
||||
(let ([ptr (alloc 3 (λ () (get-root-set hd tl)))])
|
||||
(heap-set! ptr 'pair)
|
||||
(heap-set! (+ ptr 1) hd)
|
||||
(heap-set! (+ ptr 2) tl)
|
||||
ptr))
|
||||
|
||||
(define (alloc n get-roots)
|
||||
(let ([next (find-free-space 0 n)])
|
||||
(cond
|
||||
[next
|
||||
next]
|
||||
[else
|
||||
(collect-garbage get-roots)
|
||||
(let ([next (find-free-space 0 n)])
|
||||
(unless next
|
||||
(error 'alloc "out of space"))
|
||||
next)])))
|
||||
|
||||
(define (collect-garbage get-roots)
|
||||
(let ([roots (map read-root (get-roots))])
|
||||
(collect-garbage-help roots
|
||||
(remove* roots (get-all-records 0)))))
|
||||
|
||||
(define (collect-garbage-help gray white)
|
||||
(cond
|
||||
[(null? gray) (free! white)]
|
||||
[else
|
||||
(case (heap-ref (car gray))
|
||||
[(flat)
|
||||
(let ([proc (heap-ref (+ (car gray) 1))])
|
||||
(if (procedure? proc)
|
||||
(let ([new-locs (map read-root (procedure-roots proc))])
|
||||
(collect-garbage-help
|
||||
(add-in new-locs (cdr gray) white)
|
||||
(remove* new-locs white)))
|
||||
(collect-garbage-help (cdr gray) white)))]
|
||||
[(pair)
|
||||
(let ([hd (heap-ref (+ (car gray) 1))]
|
||||
[tl (heap-ref (+ (car gray) 2))])
|
||||
(collect-garbage-help
|
||||
(add-in (list hd tl) (cdr gray) white)
|
||||
(remove tl (remove hd white))))]
|
||||
[else
|
||||
(error 'collect-garbage "unknown tag ~s, loc ~s" (heap-ref (car gray)) (car gray))])]))
|
||||
|
||||
(define (free! whites)
|
||||
(cond
|
||||
[(null? whites) (void)]
|
||||
[else
|
||||
(let ([white (car whites)])
|
||||
(case (heap-ref white)
|
||||
[(pair)
|
||||
(heap-set! white 'free)
|
||||
(heap-set! (+ white 1) 'free)
|
||||
(heap-set! (+ white 2) 'free)]
|
||||
[(flat)
|
||||
(heap-set! white 'free)
|
||||
(heap-set! (+ white 1) 'free)]
|
||||
[else
|
||||
(error 'free! "unknown tag ~s\n" (heap-ref white))])
|
||||
(free! (cdr whites)))]))
|
||||
|
||||
(test (let ([v (vector #f #t '() 0 1 2 3 4 5 6 'pair 0 1 'flat 14 'pair 0 1 'flat 12)])
|
||||
(with-heap v (free! (list 10 18)))
|
||||
v)
|
||||
(vector #f #t '() 0 1 2 3 4 5 6 'free 'free 'free 'flat 14 'pair 0 1 'free 'free))
|
||||
|
||||
;; add-in : (listof location) (listof location) (listof location) -> (listof location)
|
||||
;; computes a new set of gray addresses by addding all white elements of locs to gray
|
||||
(define (add-in locs gray white)
|
||||
(cond
|
||||
[(null? locs) gray]
|
||||
[else
|
||||
(let* ([loc (car locs)]
|
||||
[white? (member loc white)])
|
||||
(add-in (cdr locs)
|
||||
(if white? (cons loc gray) gray)
|
||||
white))]))
|
||||
|
||||
(test (add-in '(13 14) '(100 102) '(13 14 104 105))
|
||||
'(14 13 100 102))
|
||||
|
||||
(test (add-in '(13 14) '(100 102) '(13 104 105))
|
||||
'(13 100 102))
|
||||
|
||||
(define (get-all-records i)
|
||||
(cond
|
||||
[(< i (heap-size))
|
||||
(case (heap-ref i)
|
||||
[(pair) (cons i (get-all-records (+ i 3)))]
|
||||
[(flat) (cons i (get-all-records (+ i 2)))]
|
||||
[(free) (get-all-records (+ i 1))]
|
||||
[else (get-all-records (+ i 1))])]
|
||||
[else null]))
|
||||
|
||||
(test (with-heap (vector #f #t '() 0 1 2 3 4 5 6 'pair 0 1 'flat 14 'pair 0 1 'flat 12)
|
||||
(get-all-records 0))
|
||||
(list 10 13 15 18))
|
||||
|
||||
(test (with-heap (make-vector 10 'free) (gc:alloc-flat #f))
|
||||
0)
|
||||
|
||||
(test (with-heap (make-vector 10 'free) (gc:alloc-flat #t) (gc:alloc-flat #f))
|
||||
2)
|
||||
|
||||
(test (let ([v (vector 'flat 0 'flat 1)])
|
||||
(with-heap v (collect-garbage-help (list)
|
||||
(get-all-records 0)))
|
||||
v)
|
||||
(vector 'free 'free 'free 'free))
|
||||
|
||||
(test (let ([v (vector 'flat 0 'flat 1)])
|
||||
(with-heap v (collect-garbage-help (list 0)
|
||||
(remove 0 (get-all-records 0))))
|
||||
v)
|
||||
(vector 'flat 0 'free 'free))
|
||||
|
||||
(test (let ([v (vector 'flat 0 'flat 1)])
|
||||
(with-heap v (collect-garbage-help (list 2)
|
||||
(remove 2 (get-all-records 0))))
|
||||
v)
|
||||
(vector 'free 'free 'flat 1))
|
||||
|
||||
(test (let ([v (vector 'flat 0 'flat 1 'pair 0 2)])
|
||||
(with-heap v (collect-garbage-help (list 4)
|
||||
(remove 4 (get-all-records 0))))
|
||||
v)
|
||||
(vector 'flat 0 'flat 1 'pair 0 2))
|
||||
|
||||
(test (let ([v (vector 'flat 0 'flat 1 'pair 0 0)])
|
||||
(with-heap v (collect-garbage-help (list 4)
|
||||
(remove 4 (get-all-records 0))))
|
||||
v)
|
||||
(vector 'flat 0 'free 'free 'pair 0 0))
|
||||
|
||||
(test (let ([v (vector 'flat 0 'flat 1 'pair 4 4)])
|
||||
(with-heap v (collect-garbage-help (list 4)
|
||||
(remove 4 (get-all-records 0))))
|
||||
v)
|
||||
(vector 'free 'free 'free 'free 'pair 4 4))
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
#lang plai/mutator
|
||||
; This is `classic' in that caught many bugs in copying collectors that students wrote for CS173, Fall 2007.
|
||||
(allocator-setup "../good-collectors/good-collector.ss" 38)
|
||||
; This is `classic' in that it caught many bugs in copying collectors that students wrote for CS173, Fall 2007.
|
||||
(allocator-setup "../good-collectors/good-collector.ss" 28)
|
||||
|
||||
'trash
|
||||
'junk
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
#lang plai/mutator
|
||||
(allocator-setup "../good-collectors/good-collector.ss" 58)
|
||||
(allocator-setup "../good-collectors/good-collector.ss" 40)
|
||||
|
||||
|
||||
(define make-conser
|
||||
|
|
|
|||
|
|
@ -1,3 +1,3 @@
|
|||
#lang plai/mutator
|
||||
(allocator-setup "../good-collectors/good-collector.ss" 400)
|
||||
(allocator-setup "../good-collectors/good-collector.ss" 10)
|
||||
(let ([f (λ (x) x)]) f)
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
; Demonstrates garbage collection while a closure is on the stack. A correct collector must ensure that the roots
|
||||
; reachable from (make-adder 90) and (make-adder 200) -- that is, the values 90 and 200 that k is bound to -- do
|
||||
; not get discarded.
|
||||
(allocator-setup "../good-collectors/good-collector.ss" 68)
|
||||
(allocator-setup "../good-collectors/good-collector.ss" 58)
|
||||
|
||||
(define (make-adder k)
|
||||
(lambda (n) (+ n k)))
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@
|
|||
; Finally it runs the sample tests distributed with the assignment
|
||||
|
||||
|
||||
(allocator-setup "../good-collectors/good-collector.ss" 1000)
|
||||
(allocator-setup "../good-collectors/good-collector.ss" 80)
|
||||
|
||||
; Helper to generate long lists
|
||||
(define (gen-list x)
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@
|
|||
;; random mutator generation tests
|
||||
;;
|
||||
|
||||
(define-runtime-path no-compact-cheat-path "gc/good-collectors/no-compact-cheat.ss")
|
||||
(define-runtime-path collector-path "gc/good-collectors/good-collector.ss")
|
||||
|
||||
(define-runtime-path here ".")
|
||||
|
||||
|
|
@ -27,7 +27,7 @@
|
|||
(find-relative-path
|
||||
(normalize-path (simple-form-path tmpfile))
|
||||
(normalize-path
|
||||
(simple-form-path no-compact-cheat-path))))
|
||||
(simple-form-path collector-path))))
|
||||
100))
|
||||
(for-each (λ (exp) (pretty-print exp port)) exps))
|
||||
#:exists 'truncate)
|
||||
|
|
@ -36,9 +36,9 @@
|
|||
(printf "simple-form tmpfile ~s\n" (simple-form-path tmpfile))
|
||||
(printf "normalized tmpfile ~s\n" (normalize-path (simple-form-path tmpfile)))
|
||||
(newline)
|
||||
(printf "collector ~s\n" no-compact-cheat-path)
|
||||
(printf "simple-form collector: ~s\n" (simple-form-path no-compact-cheat-path))
|
||||
(printf "normalized simple-form collector: ~s\n" (normalize-path (simple-form-path no-compact-cheat-path)))
|
||||
(printf "collector ~s\n" collector-path)
|
||||
(printf "simple-form collector: ~s\n" (simple-form-path collector-path))
|
||||
(printf "normalized simple-form collector: ~s\n" (normalize-path (simple-form-path collector-path)))
|
||||
(newline)
|
||||
(printf "here ~s\n" here)
|
||||
(printf "simple-form here: ~s\n" (simple-form-path here))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user