70 lines
2.8 KiB
Scheme
70 lines
2.8 KiB
Scheme
;; This file is is used in the context of sandboxed code, it uses the
|
|
;; stacktrace interface from errortrace to find uncovered expressions.
|
|
(module sandbox-coverage mzscheme
|
|
(require errortrace/stacktrace mzlib/unit mzlib/list)
|
|
|
|
;; Test coverage run-time support
|
|
(define test-coverage-enabled (make-parameter #t))
|
|
(define test-coverage-info (make-hash-table))
|
|
(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))
|
|
|
|
(define (get-uncovered-expressions)
|
|
(let* ([xs (hash-table-map test-coverage-info (lambda (k v)
|
|
(cons (mcar v) (mcdr v))))]
|
|
[xs (filter (lambda (x) (syntax-position (car x))) xs)]
|
|
[xs (sort xs (lambda (x1 x2)
|
|
(let ([p1 (syntax-position (car x1))]
|
|
[p2 (syntax-position (car x2))])
|
|
(or (< p1 p2) ; earlier first
|
|
(and (= p1 p2)
|
|
(> (syntax-span (car x1)) ; wider first
|
|
(syntax-span (car x2))))))))]
|
|
[xs (reverse xs)])
|
|
(if (null? xs)
|
|
xs
|
|
(let loop ([xs (cdr xs)] [r (list (car xs))])
|
|
(if (null? xs)
|
|
(map car (filter (lambda (x) (not (cdr x))) r))
|
|
(loop (cdr xs)
|
|
(cond [(not (and (= (syntax-position (caar xs))
|
|
(syntax-position (caar r)))
|
|
(= (syntax-span (caar xs))
|
|
(syntax-span (caar r)))))
|
|
(cons (car xs) r)]
|
|
[(cdar r) r]
|
|
[else (cons (car xs) (cdr r))])))))))
|
|
|
|
(provide get-uncovered-expressions)
|
|
|
|
;; no profiling
|
|
(define profile-key #f)
|
|
(define profiling-enabled (lambda () #f))
|
|
(define initialize-profile-point void)
|
|
(define register-profile-start void)
|
|
(define register-profile-done void)
|
|
;; no marks
|
|
(define (with-mark mark expr) expr)
|
|
|
|
(define-values/invoke-unit/infer stacktrace@)
|
|
|
|
(define errortrace-compile-handler
|
|
(let ([orig (current-compile)]
|
|
[ns (current-namespace)])
|
|
(lambda (e immediate-eval?)
|
|
(orig (if (and (eq? ns (current-namespace))
|
|
(not (compiled-expression?
|
|
(if (syntax? e) (syntax-e e) e))))
|
|
(annotate-top
|
|
(expand-syntax (if (syntax? e)
|
|
e
|
|
(namespace-syntax-introduce
|
|
(datum->syntax-object #f e))))
|
|
(namespace-base-phase))
|
|
e)
|
|
immediate-eval?))))
|
|
|
|
(current-compile errortrace-compile-handler))
|