attempt to do non-3d values

cover.rkt

@@ -117,8 +117,7 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
                           (or (syntax-source-file-name e)
                               (syntax-source e)
                               (syntax->datum e))))
-             (annotate-top (namespace-syntax-introduce
-                            (if (syntax? e) (expand-syntax e) (datum->syntax #f e)))
+             (annotate-top (if (syntax? e) (expand-syntax e) (datum->syntax #f e))
                            phase)]))
     (compile to-compile immediate-eval?)))
 
@@ -179,17 +178,8 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
   ;;            #f => code was not run
   ;; remove those that cannot be annotated
   (define can-annotate
-    (filter values
-            (for/list ([(stx covered?) (in-hash (get-raw-coverage))])
-              (and (syntax? stx)
-                   (let* ([orig-src (syntax-source stx)]
-                          [src (if (path? orig-src) (path->string orig-src) orig-src)]
-                          [pos (syntax-position stx)]
-                          [span (syntax-span stx)])
-                     (and pos
-                          span
-                          (list (mcar covered?)
-                                (make-srcloc src #f #f pos span))))))))
+    (hash-map (get-raw-coverage)
+              (lambda (x y) (list y x))))
 
   ;; actions-ht : (list src number number) -> (list boolean syntax)
   (define actions-ht (make-hash))
@@ -236,13 +226,14 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
      "tests/compiled/prog_rkt.zo"
      "tests/compiled/prog_rkt.dep"))
   (test-begin
-   (for-each (lambda (f) (when (file-exists? f) (delete-file f)))
-                compiled)
-   (check-false (ormap file-exists? compiled))
-   (check-not-exn
-    (lambda ()
-      (parameterize ([current-compile (make-cover-compile)]
-                     [current-namespace ns])
-        (managed-compile-zo prog.rkt))))
-   (check-true (andmap file-exists? compiled)))
-  )
+   (after
+    (for-each (lambda (f) (when (file-exists? f) (delete-file f)))
+              compiled)
+    (check-false (ormap file-exists? compiled))
+    (check-not-exn
+     (lambda ()
+       (parameterize ([current-compile (make-cover-compile)]
+                      [current-namespace ns])
+         (managed-compile-zo prog.rkt))))
+    (check-true (andmap file-exists? compiled))
+    (clear-coverage!))))

strace.rkt

@@ -1,21 +1,29 @@
 #lang racket/base
-(provide annotate-top test-coverage-enabled)
+(provide (rename-out [in:annotate-top annotate-top]))
 (require errortrace/stacktrace
          racket/function
+         racket/syntax
+         syntax/parse
          racket/unit
+         racket/runtime-path
          "coverage.rkt")
 
+(define cover-name (generate-temporary #'coverage))
+(define srcloc-name (generate-temporary #'make-srcloc))
+
 (define (with-mark src dest phase) dest)
 (define test-coverage-enabled (make-parameter #t))
 
 (define (initialize-test-coverage-point stx)
-  (hash-set! coverage stx (mcons #f #f)))
+  (define srcloc (stx->srcloc stx))
+  (when srcloc
+    (hash-set! coverage srcloc #f)))
 
 (define (test-covered stx)
-  (define v (hash-ref coverage stx #f))
-  (and v
-       (with-syntax ([v v])
-         #'(#%plain-app set-mcar! v #t))))
+  (define loc/stx (stx->srcloc/stx stx))
+  (with-syntax ([c cover-name]
+                [loc loc/stx])
+    #'(#%plain-app hash-set! c loc #t)))
 
 (define profile-key (gensym))
 
@@ -25,3 +33,43 @@
 (define register-profile-done void)
 
 (define-values/invoke-unit/infer stacktrace@)
+
+(define (make-srcloc-maker f)
+  (lambda (stx)
+    (and (syntax? stx)
+         (let* ([orig-src (syntax-source stx)]
+                [src (if (path? orig-src) (path->string orig-src) orig-src)]
+                [pos (syntax-position stx)]
+                [span (syntax-span stx)])
+           (and pos
+                span
+                (f src #f #f pos span))))))
+
+(define stx->srcloc
+  (make-srcloc-maker make-srcloc))
+
+(define stx->srcloc/stx
+  (make-srcloc-maker
+   (lambda (src a b pos span)
+     (with-syntax ([src src]
+                   [pos pos]
+                   [a a]
+                   [b b]
+                   [span span]
+                   [make-srcloc srcloc-name])
+       #'(make-srcloc src a b pos span)))))
+
+(define (in:annotate-top stx phase)
+  (define e
+    (syntax-parse stx
+      #:literal-sets (kernel-literals)
+      [((~and a module) name lang b ...)
+       (with-syntax ([cover cover-name] [srcloc srcloc-name])
+         (namespace-syntax-introduce
+          #'(a name lang
+              (#%require (rename cover/coverage cover coverage))
+              (#%require (rename racket/base srcloc make-srcloc))
+              r1 r2
+              b ...)))]
+      [_ #f]))
+  (if e (annotate-top e phase) stx))