/usr/share/racket/pkgs/trace/calltrace-lib.rkt is in racket-common 6.3-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | ;; Poor man's stack-trace-on-exceptions/profiler.
;; See docs for information.
(module calltrace-lib mzscheme
(require "stacktrace.rkt"
mzlib/list
mzlib/etc
mzlib/unit)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Eval handler, exception handler
(define instrumenting-enabled (make-parameter #t))
(define output-port (current-error-port))
;; (union symbol #f) syntax-object (list-of value) boolean int -> void
;; effect: prints out the context surrounding the exception
(define (print-call-trace inferred-name original? src args improper? depth)
(build-list depth (lambda (n) (fprintf output-port " ")))
(fprintf output-port "~v\n" (cons (or inferred-name src)
(if improper?
(list->improper-list args)
args))))
(define calltrace-eval-handler
(let ([orig (current-eval)]
[ns (current-namespace)])
(lambda (e)
(if (and (eq? ns (current-namespace))
(not (compiled-expression? (if (syntax? e)
(syntax-e e)
e))))
;; Loop to flatten top-level `begin's:
(let loop ([e (if (syntax? e)
e
(namespace-syntax-introduce
(datum->syntax-object #f e)))])
(let ([top-e (expand-syntax-to-top-form e)])
(syntax-case top-e (begin)
[(begin expr ...)
;; Found a `begin', so expand/eval each contained
;; expression one at a time
(foldl (lambda (e old-val)
(loop e))
(void)
(syntax->list #'(expr ...)))]
[_else
;; Not `begin', so proceed with normal expand and eval
(let* ([ex (expand-syntax top-e)]
[a (if (not (instrumenting-enabled))
ex
(annotate ex))])
(orig a))])))
(orig e)))))
(define (list->improper-list a)
(cond [(null? a) (error 'list->improper-list "list->improper-list called with null argument: ~e" a)]
[(and (cons? a) (null? (cdr a))) (car a)]
[else (cons (car a) (list->improper-list (cdr a)))]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Stacktrace instrumenter
(define calltrace-key #`(quote #,(gensym 'key)))
(define-values/invoke-unit stacktrace@
(import stacktrace-imports^) (export stacktrace^))
(provide calltrace-eval-handler
instrumenting-enabled
annotate))
|