Removing graveyard
svn: r6489
This commit is contained in:
Jay McCarthy
parent
f2aa671887
commit
de099d4eea
|
|
@ -1,86 +0,0 @@
|
|||
(module file-vector mzscheme
|
||||
(require (lib "serialize.ss"))
|
||||
(provide deserialize-info:file-vector
|
||||
struct:file-vector
|
||||
make-file-vector
|
||||
file-vector?
|
||||
file-vector-ref
|
||||
file-vector-set!)
|
||||
|
||||
(define deserialize-info:file-vector
|
||||
(make-deserialize-info
|
||||
|
||||
;; make-proc: symbol -> file-vector
|
||||
(lambda (file-tag)
|
||||
(let ([vals
|
||||
(vector->list
|
||||
(call-with-input-file (symbol->string file-tag)
|
||||
(lambda (i-port)
|
||||
(deserialize (read i-port)))))])
|
||||
(apply make-file-vector (cons file-tag vals))))
|
||||
|
||||
;; cycle-make-proc: -> (values file-vector (file-vector -> void))
|
||||
(lambda ()
|
||||
(let ([new-file-vector
|
||||
(make-file-vector #f #f)])
|
||||
(values
|
||||
new-file-vector
|
||||
(lambda (fv)
|
||||
(set-file-vector-tag! new-file-vector (file-vector-tag fv))
|
||||
(set-file-vector-vec! new-file-vector (file-vector-vec fv))))))))
|
||||
|
||||
|
||||
|
||||
(define file-vector:serialize-info
|
||||
(make-serialize-info
|
||||
|
||||
;; to-vector: file-vector -> (vectorof symbol)
|
||||
(lambda (fv)
|
||||
(call-with-output-file (symbol->string (file-vector-tag fv))
|
||||
(lambda (o-port)
|
||||
(write (serialize (file-vector-vec fv)) o-port))
|
||||
'replace)
|
||||
(make-vector 1 (file-vector-tag fv)))
|
||||
|
||||
;; The serializer id: --------------------
|
||||
(syntax deserialize-info:file-vector)
|
||||
|
||||
;; can-cycle?
|
||||
#t
|
||||
|
||||
;; Directory for last-ditch resolution --------------------
|
||||
(or (current-load-relative-directory) (current-directory))))
|
||||
|
||||
(define-values (struct:file-vector make-file-vector file-vector? file-vector-ref file-vector-set!
|
||||
file-vector-tag set-file-vector-tag!
|
||||
file-vector-vec set-file-vector-vec!)
|
||||
(let-values ([(struct:file-vector make-fv-struct file-vector? fv-struct-ref fv-struct-set!)
|
||||
(make-struct-type 'struct:file-vector ;; the tag goes here
|
||||
#f ; no super type
|
||||
2
|
||||
0 ; number of auto-fields
|
||||
#f ; auto-v
|
||||
|
||||
; prop-vals:
|
||||
(list (cons prop:serializable file-vector:serialize-info))
|
||||
|
||||
#f ; inspector
|
||||
|
||||
;; the struct apply proc:
|
||||
#f)])
|
||||
(values struct:file-vector
|
||||
(lambda (tag . vals)
|
||||
(make-fv-struct tag (list->vector vals)))
|
||||
file-vector?
|
||||
(lambda (fv n)
|
||||
(vector-ref (fv-struct-ref fv 1) n))
|
||||
(lambda (fv n val)
|
||||
(vector-set! (fv-struct-ref fv 1) n val))
|
||||
(lambda (fv)
|
||||
(fv-struct-ref fv 0))
|
||||
(lambda (fv new-tag)
|
||||
(fv-struct-set! fv 0 new-tag))
|
||||
(lambda (fv)
|
||||
(fv-struct-ref fv 1))
|
||||
(lambda (fv new-vec)
|
||||
(fv-struct-set! fv 1 new-vec))))))
|
||||
|
|
@ -1,123 +0,0 @@
|
|||
(module persistent-close mzscheme
|
||||
(require-for-template mzscheme)
|
||||
(require-for-syntax (lib "kerncase.ss" "syntax"))
|
||||
(require "file-vector.ss")
|
||||
(provide close/file)
|
||||
|
||||
(define-for-syntax (index-of id ids)
|
||||
(let loop ([idx 0] [ids ids])
|
||||
(cond
|
||||
[(null? ids) #f]
|
||||
[(bound-identifier=? id (car ids)) idx]
|
||||
[else (loop (add1 idx) (cdr ids))])))
|
||||
|
||||
;; replace/fvector-refs: id (listof id) expr -> expr
|
||||
;; replace uses of id with appropriate file-vector refs
|
||||
(define-for-syntax (replace/fvector-refs fvec-id ids expr)
|
||||
(kernel-syntax-case expr #t
|
||||
[(lambda formals body-exprs ...)
|
||||
#`(lambda formals
|
||||
#,@(map
|
||||
(lambda (body-expr)
|
||||
(replace/fvector-refs fvec-id ids body-expr))
|
||||
(syntax->list #'(body-exprs ...))))]
|
||||
[(case-lambda (formals bodiess ...) ...)
|
||||
#`(case-lambda
|
||||
#,@(map
|
||||
(lambda (formal bodies)
|
||||
(with-syntax ([(bodies ...) bodies])
|
||||
#`(formal #,@(map
|
||||
(lambda (body)
|
||||
(replace/fvector-refs fvec-id ids body))
|
||||
(syntax->list #'(bodies ...))))))
|
||||
(syntax->list #'(formals ...))
|
||||
(syntax->list #'((bodiess ...) ...))))]
|
||||
[(if tst csq)
|
||||
#`(if #,(replace/fvector-refs fvec-id ids #'tst)
|
||||
#,(replace/fvector-refs fvec-id ids #'csq))]
|
||||
[(if tst csq alt)
|
||||
#`(if #,(replace/fvector-refs fvec-id ids #'tst)
|
||||
#,(replace/fvector-refs fvec-id ids #'csq)
|
||||
#,(replace/fvector-refs fvec-id ids #'alt))]
|
||||
[(begin exprs ...)
|
||||
#`(begin #,@(map
|
||||
(lambda (expr)
|
||||
(replace/fvector-refs fvec-id ids expr))
|
||||
(syntax->list #'(exprs ...))))]
|
||||
[(begin0 expr0 exprs ...)
|
||||
#`(begin0 #,(replace/fvector-refs fvec-id ids #'expr0)
|
||||
#,@(map
|
||||
(lambda (expr)
|
||||
(replace/fvector-refs fvec-id ids expr))
|
||||
(syntax->list #'(exprs ...))))]
|
||||
[(let-values (((varss ...) rhss) ...) exprs ...)
|
||||
#`(let-values (#,(map
|
||||
(lambda (vars rhs)
|
||||
#`[#,vars #,(replace/fvector-refs fvec-id ids rhs)])
|
||||
(syntax->list #'((varss ...) ...))
|
||||
(syntax->list #'(rhss ...))))
|
||||
#,@(map
|
||||
(lambda (expr)
|
||||
(replace/fvector-refs fvec-id ids expr)
|
||||
(syntax->list #'(exprs ...)))))]
|
||||
[(letrec-values (((varss ...) rhss) ...) exprs ...)
|
||||
#`(letrec-values (#,(map
|
||||
(lambda (vars rhs)
|
||||
#`[#,vars #,(replace/fvector-refs fvec-id ids rhs)])
|
||||
(syntax->list #'((varss ...) ...))
|
||||
(syntax->list #'(rhss ...))))
|
||||
#,@(map
|
||||
(lambda (expr)
|
||||
(replace/fvector-refs fvec-id ids expr))
|
||||
(syntax->list #'(exprs ...))))]
|
||||
[(set! var rhs)
|
||||
(cond
|
||||
[(index-of #'var ids)
|
||||
=> (lambda (idx)
|
||||
#`(file-vector-set! #,fvec-id #,idx #,(replace/fvector-refs fvec-id ids #'rhs)))]
|
||||
[else
|
||||
#`(set! var (replace/fvector-refs fvec-id ids #'rhs))])]
|
||||
[(quote datum) expr]
|
||||
[(quote-syntax datum) expr]
|
||||
[(with-continuation-mark key val body)
|
||||
#`(with-continuation-mark #,(replace/fvector-refs fvec-id ids #'key)
|
||||
#,(replace/fvector-refs fvec-id ids #'val)
|
||||
#,(replace/fvector-refs fvec-id ids #'body))]
|
||||
[(#%app exprs ...)
|
||||
#`(#%app #,@(map
|
||||
(lambda (expr)
|
||||
(replace/fvector-refs fvec-id ids expr))
|
||||
(syntax->list #'(exprs ...))))]
|
||||
[(#%datum . datum) expr]
|
||||
[(#%top . variable) expr]
|
||||
[var
|
||||
(cond
|
||||
[(index-of #'var ids)
|
||||
=> (lambda (idx)
|
||||
#`(file-vector-ref #,fvec-id #,idx))]
|
||||
[else #'var])]))
|
||||
|
||||
;; (replace vector-expr (identifier ...) body-expr)
|
||||
;; body-expr should be fully expanded.
|
||||
(define-syntax (replace stx)
|
||||
(syntax-case stx ()
|
||||
[(_ fvec-expr (ids ...) body-exprs ...)
|
||||
(with-syntax ([fvec (datum->syntax-object #'_ 'fvec)])
|
||||
#`(let ([fvec fvec-expr])
|
||||
#,@(map
|
||||
(lambda (body-expr)
|
||||
(replace/fvector-refs #'fvec (syntax->list #'(ids ...)) body-expr))
|
||||
(syntax->list #'(body-exprs ...)))))]
|
||||
[_else
|
||||
(raise-syntax-error #f "replace: bad syntax" stx)]))
|
||||
|
||||
(define-syntax (close/file stx)
|
||||
(syntax-case stx ()
|
||||
[(_ file-tag (ids ...) body-exprs ...)
|
||||
(syntax-case (local-expand #'(let-values ([(ids ...) (values ids ...)]) body-exprs ...)
|
||||
'expression '()) (#%app)
|
||||
[(let-values ([(ids ...) (#%app values ref-vals ...)]) new-body-exprs ...)
|
||||
#'(replace (make-file-vector file-tag ref-vals ...) (ids ...) new-body-exprs ...)])]
|
||||
[_else
|
||||
(raise-syntax-error #f "close/file: bad syntax" stx)])))
|
||||
|
||||
|
|
@ -2,7 +2,6 @@
|
|||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
|
||||
"configuration/all-configuration-tests.ss"
|
||||
"dispatchers/all-dispatchers-tests.ss"
|
||||
"graveyard/all-graveyard-tests.ss"
|
||||
"lang/all-lang-tests.ss"
|
||||
"lang-test.ss"
|
||||
"managers/all-managers-tests.ss"
|
||||
|
|
@ -17,7 +16,6 @@
|
|||
"Web Server"
|
||||
all-configuration-tests
|
||||
all-dispatchers-tests
|
||||
all-graveyard-tests
|
||||
all-lang-tests
|
||||
lang-tests
|
||||
all-managers-tests
|
||||
|
|
|
|||
|
|
@ -1,11 +0,0 @@
|
|||
(module all-graveyard-tests mzscheme
|
||||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
|
||||
"file-vector-test.ss"
|
||||
"persistent-close-test.ss")
|
||||
(provide all-graveyard-tests)
|
||||
|
||||
(define all-graveyard-tests
|
||||
(test-suite
|
||||
"Graveyard"
|
||||
file-vector-tests
|
||||
persistent-close-tests)))
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
(module file-vector-test mzscheme
|
||||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
|
||||
(lib "serialize.ss")
|
||||
(lib "file-vector.ss" "web-server" "graveyard"))
|
||||
(provide file-vector-tests)
|
||||
|
||||
(define file-vector-tests
|
||||
(test-suite
|
||||
"File Vector"
|
||||
|
||||
(test-case
|
||||
"file-vector references"
|
||||
(let ([fv (make-file-vector '/tmp/foo 1 2 3)])
|
||||
(check = 1 (file-vector-ref fv 0))
|
||||
(check = 2 (file-vector-ref fv 1))
|
||||
(check = 3 (file-vector-ref fv 2))
|
||||
(file-vector-set! fv 0 -1)
|
||||
(file-vector-set! fv 1 -2)
|
||||
(file-vector-set! fv 2 -3)
|
||||
(check = -1 (file-vector-ref fv 0))
|
||||
(check = -2 (file-vector-ref fv 1))
|
||||
(check = -3 (file-vector-ref fv 2))))
|
||||
|
||||
(test-case
|
||||
"serializing file vectors"
|
||||
(let* ([fv (make-file-vector '/tmp/foo -1 -2 -3)]
|
||||
[fv2 (deserialize (serialize fv))])
|
||||
(check = -1 (file-vector-ref fv2 0))
|
||||
(check = -2 (file-vector-ref fv2 1))
|
||||
(check = -3 (file-vector-ref fv2 2)))))))
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
(module persistent-close-test mzscheme
|
||||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
|
||||
(lib "persistent-close.ss" "web-server" "graveyard"))
|
||||
(provide persistent-close-tests)
|
||||
|
||||
(define persistent-close-tests
|
||||
(test-suite
|
||||
"Persistent Closures"
|
||||
|
||||
(test-case
|
||||
"close/file test"
|
||||
(let ([x 7] [y 8])
|
||||
(check = 7 (close/file 'f1 (x y) x))
|
||||
(check = 15 (close/file 'f2 (x y) (+ x y))))))))
|
||||
Loading…
Reference in New Issue
Block a user