Removing need for .tag-list
svn: r6659
This commit is contained in:
Jay McCarthy
parent
285a854725
commit
c4ccd0e29a
|
|
@ -1,95 +1,18 @@
|
|||
(module labels mzscheme
|
||||
(require (lib "md5.ss")
|
||||
(lib "list.ss")
|
||||
(lib "etc.ss"))
|
||||
(provide make-labeling
|
||||
delete-tag-list!)
|
||||
(require (lib "md5.ss"))
|
||||
(provide make-labeling)
|
||||
|
||||
;; REQUIREMENT: The label code must be non-numeric.
|
||||
;; REQUIREMENT: The first numeric character following the label code
|
||||
;; indicates the start of the unique suffix identifying
|
||||
;; the closure struct type.
|
||||
|
||||
;; add1/string: string -> string
|
||||
;; a successor function on strings
|
||||
(define (add1/string str)
|
||||
(cond
|
||||
[(regexp-match "$^" str)
|
||||
=> (lambda (x) "b")]
|
||||
[(regexp-match "z(.*)" str)
|
||||
=> (lambda (m) (string-append "A" (cadr m)))]
|
||||
[(regexp-match "Z(.*)" str)
|
||||
=> (lambda (m) (string-append "a" (add1/string (cadr m))))]
|
||||
[else
|
||||
(format "~a~a"
|
||||
(integer->char (add1 (char->integer (string-ref str 0))))
|
||||
(substring str 1))]))
|
||||
|
||||
(define default-file-name (build-path (this-expression-source-directory) ".tag-list"))
|
||||
(define file-system-mutex (make-semaphore 1))
|
||||
|
||||
;; read-tag-list: string -> (listof (list bytes string))
|
||||
;; read the tag list from the file system
|
||||
(define (read-tag-list filename)
|
||||
(if (file-exists? filename)
|
||||
(let ([v (call-with-input-file filename
|
||||
read)])
|
||||
(if (eof-object? v)
|
||||
empty
|
||||
v))
|
||||
empty))
|
||||
|
||||
;; save-tag-list!: (listof (list bytes string)) string -> (listof (list bytes string))
|
||||
;; save the tag list in the file system
|
||||
(define (save-tag-list! new-list filename)
|
||||
(call-with-output-file filename
|
||||
(lambda (o-port)
|
||||
(write new-list o-port))
|
||||
'replace))
|
||||
|
||||
;; delete-tag-list!: [filename] -> void
|
||||
;; delete a file containing a tag-list
|
||||
(define delete-tag-list!
|
||||
(case-lambda
|
||||
[(filename)
|
||||
(when (file-exists? filename)
|
||||
(delete-file filename))]
|
||||
[() (delete-tag-list! default-file-name)]))
|
||||
|
||||
;; lookup-tag: bytes string -> string
|
||||
;; lookup a tag in the-tag-table
|
||||
(define (lookup-tag pgm filename)
|
||||
(let* ([the-tag-list (read-tag-list filename)]
|
||||
[hash-code (md5 pgm)]
|
||||
[new-tag
|
||||
(if (null? the-tag-list) "a"
|
||||
(add1/string (cadar the-tag-list)))])
|
||||
(let loop ([l the-tag-list])
|
||||
(cond
|
||||
[(null? l)
|
||||
(save-tag-list!
|
||||
(cons (list hash-code new-tag)
|
||||
the-tag-list)
|
||||
filename)
|
||||
new-tag]
|
||||
[(bytes=? hash-code (caar l))
|
||||
(cadar l)]
|
||||
[else (loop (cdr l))]))))
|
||||
|
||||
;; make-labeling: bytes -> (-> symbol)
|
||||
;; produce the labeling function for a particular program
|
||||
(define make-labeling
|
||||
(case-lambda
|
||||
[(pgm) (make-labeling pgm default-file-name)]
|
||||
[(pgm filename)
|
||||
(dynamic-wind
|
||||
(lambda () (semaphore-wait file-system-mutex))
|
||||
(lambda ()
|
||||
(let ([tag (lookup-tag pgm filename)]
|
||||
[count 0])
|
||||
(lambda ()
|
||||
(begin0
|
||||
(string->symbol (format "~a~a" tag count))
|
||||
(set! count (add1 count))))))
|
||||
(lambda () (semaphore-post file-system-mutex)))]))
|
||||
)
|
||||
(define (make-labeling pgm)
|
||||
(define count (box 0))
|
||||
(define tag (md5 pgm))
|
||||
(lambda ()
|
||||
(begin0
|
||||
(string->symbol (format "~a~a" tag (unbox count)))
|
||||
(set-box! count (add1 (unbox count)))))))
|
||||
|
|
@ -1,97 +1,17 @@
|
|||
(module labels-test mzscheme
|
||||
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
|
||||
(planet "util.ss" ("schematics" "schemeunit.plt" 2))
|
||||
(lib "etc.ss")
|
||||
(lib "file.ss")
|
||||
(lib "labels.ss" "web-server" "lang"))
|
||||
(provide labels-tests)
|
||||
|
||||
(require/expose (lib "labels.ss" "web-server" "lang") (add1/string))
|
||||
|
||||
(define THE-TEST-FILENAME (make-temporary-file))
|
||||
(define l1 (make-labeling #"foo" THE-TEST-FILENAME))
|
||||
(define l2 (make-labeling #"foo" THE-TEST-FILENAME))
|
||||
(define l3 (make-labeling #"bar" THE-TEST-FILENAME))
|
||||
(define l4 (make-labeling #"baz" THE-TEST-FILENAME))
|
||||
|
||||
(define race-test-file (make-temporary-file))
|
||||
|
||||
(define (genbytes)
|
||||
(string->bytes/utf-8
|
||||
(symbol->string (gensym))))
|
||||
|
||||
(define-struct cell (sema ival new-val))
|
||||
|
||||
(define (create-cell ival)
|
||||
(make-cell (make-semaphore) ival #f))
|
||||
|
||||
;; race?: (listof alpha) (alpha -> beta) ((listof beta) -> boolean)) -> boolean
|
||||
;; compute a list of values in parallel and determine if the result indicates a
|
||||
;; race condition.
|
||||
(define (race? initial-vals make-new-val check-new-vals)
|
||||
(let ([cells (map create-cell initial-vals)])
|
||||
(for-each
|
||||
(lambda (cell)
|
||||
(thread
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda () (set-cell-new-val! cell (make-new-val (cell-ival cell))))
|
||||
(lambda () (semaphore-post (cell-sema cell)))))))
|
||||
cells)
|
||||
(for-each
|
||||
(lambda (cell)
|
||||
(semaphore-wait (cell-sema cell)))
|
||||
cells)
|
||||
(with-handlers ([void
|
||||
(lambda (the-exn) #t)])
|
||||
(check-new-vals (map cell-new-val cells)))))
|
||||
|
||||
(define (make-labeling-race? n)
|
||||
(delete-tag-list! race-test-file)
|
||||
(race? (build-list n (lambda (i) (genbytes)))
|
||||
(lambda (some-bytes)
|
||||
(make-labeling some-bytes race-test-file))
|
||||
(lambda (labelings)
|
||||
(let loop ([label 0]
|
||||
[labelings labelings])
|
||||
(if (null? labelings)
|
||||
#f
|
||||
(let ([new-label ((car labelings))])
|
||||
(or (eqv? new-label label)
|
||||
(loop new-label (cdr labelings)))))))))
|
||||
|
||||
(define (delete-tag-list!-race? n)
|
||||
(race? (build-list n (lambda (i) #"foo"))
|
||||
(lambda (some-bytes)
|
||||
(delete-tag-list! race-test-file)
|
||||
(make-labeling some-bytes race-test-file))
|
||||
(lambda (labelings)
|
||||
(let* ([syms (map (lambda (l) (l)) labelings)]
|
||||
[sym0 (car syms)])
|
||||
(not
|
||||
(andmap
|
||||
(lambda (sym)
|
||||
(eqv? sym0 sym))
|
||||
syms))))))
|
||||
(define l1 (make-labeling #"foo"))
|
||||
(define l2 (make-labeling #"foo"))
|
||||
(define l3 (make-labeling #"bar"))
|
||||
(define l4 (make-labeling #"baz"))
|
||||
|
||||
(define labels-tests
|
||||
(test-suite
|
||||
"Module Labeling"
|
||||
|
||||
(test-case
|
||||
"Test the tag incrementing scheme"
|
||||
(check string=? "b" (add1/string ""))
|
||||
(check string=? "A" (add1/string "z"))
|
||||
(check string=? "B" (add1/string "A"))
|
||||
(check string=? "b" (add1/string "a"))
|
||||
(check string=? "ab" (add1/string "Z"))
|
||||
(check string=? "aab" (add1/string "ZZ"))
|
||||
(check string=? "Azz" (add1/string "zzz"))
|
||||
(check string=? "aaaab" (add1/string "ZZZZ"))
|
||||
(check string=? "baaab" (add1/string "aaaab")))
|
||||
|
||||
|
||||
(test-case
|
||||
"The same program produces the same labeling"
|
||||
(check-eqv? (l1) (l2))
|
||||
|
|
@ -99,12 +19,4 @@
|
|||
|
||||
(test-case
|
||||
"Different programs produce different labelings"
|
||||
(check-false (eqv? (l3) (l4))))
|
||||
|
||||
(test-case
|
||||
"Check for race condition on make-labeling"
|
||||
(check-false (make-labeling-race? 256)))
|
||||
|
||||
(test-case
|
||||
"Check for race condition on delete-tag-list!"
|
||||
(check-false (delete-tag-list!-race? 256))))))
|
||||
(check-false (eqv? (l3) (l4)))))))
|
||||
Loading…
Reference in New Issue
Block a user