Removing need for .tag-list

svn: r6659

collects/web-server/lang/labels.ss

@@ -1,95 +1,18 @@
 (module labels mzscheme
-  (require (lib "md5.ss")
+  (require (lib "md5.ss"))
-           (lib "list.ss")
+  (provide make-labeling)
-           (lib "etc.ss"))
-  (provide make-labeling
-           delete-tag-list!)
   
   ;; 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
+  (define (make-labeling pgm)
-    (case-lambda
+    (define count (box 0))
-      [(pgm) (make-labeling pgm default-file-name)]
+    (define tag (md5 pgm))
-      [(pgm filename)
+    (lambda ()
-       (dynamic-wind
+      (begin0
-        (lambda () (semaphore-wait file-system-mutex))
+        (string->symbol (format "~a~a" tag (unbox count)))
-        (lambda ()
+        (set-box! count (add1 (unbox count)))))))
-          (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)))]))
-  )

collects/web-server/tests/lang/labels-test.ss

@@ -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 l1 (make-labeling #"foo"))
-  
+  (define l2 (make-labeling #"foo"))
-  (define THE-TEST-FILENAME (make-temporary-file))  
+  (define l3 (make-labeling #"bar"))
-  (define l1 (make-labeling #"foo" THE-TEST-FILENAME))
+  (define l4 (make-labeling #"baz"))
-  (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 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))))
+      (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))))))