improved performance of the teaching languages

svn: r14394

collects/deinprogramm/deinprogramm-langs.ss

@@ -1282,9 +1282,11 @@
       
       (define (test-covered key)
         (let ([ht (thread-cell-ref current-test-coverage-info)])
-          (when ht
+          (and ht
-            (let ([v (hash-ref ht key)])
+               (let ([v (hash-ref ht key)])
-              (set-mcar! v #t)))))
+                 (and v
+                      (with-syntax ([v v])
+                        #'(set-mcar! v #t)))))))
       
       (define-values/invoke-unit et:stacktrace@
         (import et:stacktrace-imports^) (export (prefix et: et:stacktrace^)))

collects/drscheme/private/debug.ss

@@ -899,9 +899,10 @@ profile todo:
   
   (define (test-covered key)
     (let ([ht (thread-cell-ref current-test-coverage-info)])
-      (when (hash? ht) ;; as in the `when' test in `initialize-test-coverage-point'
+      (and (hash? ht) ;; as in the `when' test in `initialize-test-coverage-point'
-        (let ([v (hash-ref ht key)])
+           (let ([v (hash-ref ht key #f)])
-          (set-mcar! v #t)))))
+             (and v
+                  (λ () (set-mcar! v #t)))))))
   
   (define test-coverage-interactions-text<%>
     (interface ()

collects/errortrace/scribblings/errortrace.scrbl

@@ -350,11 +350,16 @@ calls to @schemein[test-covered] are inserted into the code (and
 @schemein[initialize-test-coverage-point] is called during compilation).
 If not, no calls to test-covered are inserted.}
 
-@defproc[(test-covered (key any/c)) void?]{
+@defproc[(test-covered (key any/c)) (or/c (-> void?) syntax? #f)]{
+This is called during compilation of the program with a key value once
+ for each point with the key for that program point that was passed to
+@schemein[initialize-test-coverage-point].
 
-During execution of the program, this is called for each point with
+If the result is @scheme[#f], this program point is not
-the key for that program point that was passed to
+instrumented. If the result is syntax, it is inserted into the code,
-@schemein[initialize-test-coverage-point].}
+and if it is a thunk, the thunk is inserted into the code in an
+application. In either case, the syntax or the thunk should register
+that the relevant point was covered.}
 
 @defproc[(initialize-test-coverage-point (key any/c) (stx any/c)) void?]{
 

collects/errortrace/stacktrace.ss

@@ -83,14 +83,23 @@
       ;; test-coverage-point : syntax syntax -> syntax
       ;; sets a test coverage point for a single expression
       (define (test-coverage-point body expr phase)
-        (if (and (test-coverage-enabled) (zero? phase))
+        (if (and (test-coverage-enabled)
-            (let ([key (gensym 'test-coverage-point)])
+                 (zero? phase)
+                 (syntax-position expr))
+            (let* ([key (gensym 'test-coverage-point)])
               (initialize-test-coverage-point key expr)
-              (with-syntax ([key (datum->syntax
+              (let ([thunk (test-covered key)])
-                                  #f key (quote-syntax here))]
+                (cond
-                            [body body]
+                  [(procedure? thunk)
-                            [test-covered test-covered])
+                   (with-syntax ([body body]
-                #'(begin (#%plain-app test-covered 'key) body)))
+                                 [thunk thunk])
+                     #'(begin (#%plain-app thunk) body))]
+                  [(syntax? thunk)
+                   (with-syntax ([body body]
+                                 [thunk thunk])
+                     #'(begin thunk body))]
+                  [else
+                   body])))
             body))
 
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

collects/lang/htdp-langs.ss

@@ -1102,10 +1102,13 @@
             (hash-set! ht key (mcons #f expr)))))
       
       (define (test-covered key)
-        (let ([ht (thread-cell-ref current-test-coverage-info)])
+        (let* ([ht (thread-cell-ref current-test-coverage-info)]
-          (when ht
+               [v (and ht (hash-ref ht key #f))])
-            (let ([v (hash-ref ht key)])
+          (with-syntax ([v v])
-              (set-mcar! v #t)))))
+            #'(set-mcar! v #t))
+          #;
+          (and v
+               (λ () (set-mcar! v #t)))))
       
       (define-values/invoke-unit et:stacktrace@
         (import et:stacktrace-imports^) (export (prefix et: et:stacktrace^)))

collects/scheme/private/sandbox-coverage.ss

@@ -9,7 +9,8 @@
   (define (initialize-test-coverage-point key expr)
     (hash-table-put! test-coverage-info key (mcons expr #f)))
   (define (test-covered key)
-    (set-mcdr! (hash-table-get test-coverage-info key) #t))
+    (let ([mpair (hash-table-get test-coverage-info key)])
+      (λ () (set-mcdr! mpair #t))))
 
   (define (get-uncovered-expressions)
     (let* ([xs (hash-table-map test-coverage-info (lambda (k v)