From de099d4eeac77c426038af84f0a034203a04ce4e Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 5 Jun 2007 21:52:03 +0000 Subject: [PATCH] Removing graveyard svn: r6489 --- collects/web-server/graveyard/file-vector.ss | 86 ------------ .../web-server/graveyard/persistent-close.ss | 123 ------------------ .../web-server/tests/all-web-server-tests.ss | 2 - .../tests/graveyard/all-graveyard-tests.ss | 11 -- .../tests/graveyard/file-vector-test.ss | 30 ----- .../tests/graveyard/persistent-close-test.ss | 14 -- 6 files changed, 266 deletions(-) delete mode 100644 collects/web-server/graveyard/file-vector.ss delete mode 100644 collects/web-server/graveyard/persistent-close.ss delete mode 100644 collects/web-server/tests/graveyard/all-graveyard-tests.ss delete mode 100644 collects/web-server/tests/graveyard/file-vector-test.ss delete mode 100644 collects/web-server/tests/graveyard/persistent-close-test.ss diff --git a/collects/web-server/graveyard/file-vector.ss b/collects/web-server/graveyard/file-vector.ss deleted file mode 100644 index 0b1fb00f96..0000000000 --- a/collects/web-server/graveyard/file-vector.ss +++ /dev/null @@ -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)))))) \ No newline at end of file diff --git a/collects/web-server/graveyard/persistent-close.ss b/collects/web-server/graveyard/persistent-close.ss deleted file mode 100644 index e7ca108af1..0000000000 --- a/collects/web-server/graveyard/persistent-close.ss +++ /dev/null @@ -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)]))) - diff --git a/collects/web-server/tests/all-web-server-tests.ss b/collects/web-server/tests/all-web-server-tests.ss index e2f0784385..6af29437ea 100644 --- a/collects/web-server/tests/all-web-server-tests.ss +++ b/collects/web-server/tests/all-web-server-tests.ss @@ -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 diff --git a/collects/web-server/tests/graveyard/all-graveyard-tests.ss b/collects/web-server/tests/graveyard/all-graveyard-tests.ss deleted file mode 100644 index b73120eb0c..0000000000 --- a/collects/web-server/tests/graveyard/all-graveyard-tests.ss +++ /dev/null @@ -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))) \ No newline at end of file diff --git a/collects/web-server/tests/graveyard/file-vector-test.ss b/collects/web-server/tests/graveyard/file-vector-test.ss deleted file mode 100644 index 8bd4ff3feb..0000000000 --- a/collects/web-server/tests/graveyard/file-vector-test.ss +++ /dev/null @@ -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))))))) \ No newline at end of file diff --git a/collects/web-server/tests/graveyard/persistent-close-test.ss b/collects/web-server/tests/graveyard/persistent-close-test.ss deleted file mode 100644 index 5e9db5093e..0000000000 --- a/collects/web-server/tests/graveyard/persistent-close-test.ss +++ /dev/null @@ -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))))))))