1;;; trace.ss
2;;; Copyright 1984-2017 Cisco Systems, Inc.
3;;;
4;;; Licensed under the Apache License, Version 2.0 (the "License");
5;;; you may not use this file except in compliance with the License.
6;;; You may obtain a copy of the License at
7;;;
8;;; http://www.apache.org/licenses/LICENSE-2.0
9;;;
10;;; Unless required by applicable law or agreed to in writing, software
11;;; distributed under the License is distributed on an "AS IS" BASIS,
12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13;;; See the License for the specific language governing permissions and
14;;; limitations under the License.
15
16(let ()
17
18(define tracer-list '())
19(define-threaded trace-level 0)
20(define-threaded trace-continuation #f)
21
22(define-record-type tracer
23  (fields (mutable id) (mutable old) (mutable new))
24  (nongenerative)
25  (sealed #t))
26
27(define bars
28   (lambda (i p)
29      (letrec ([bars1
30                (lambda (i p)
31                   (unless (fx<= i 0)
32                      (write-char #\space p)
33                      (bars2 (fx- i 1) p)))]
34               [bars2
35                (lambda (i p)
36                   (unless (fx<= i 0)
37                      (write-char #\| p)
38                      (bars1 (fx- i 1) p)))])
39         (bars2 i p))))
40
41(define trace-display
42 (let ([last-trace-level 0])
43   (lambda (print x)
44      (let ([p (trace-output-port)])
45         (if (> trace-level 10)
46             (let ([s (number->string (- trace-level 1))])
47                (bars (fx- 9 (string-length s)) p)
48                (write-char #\[ p)
49                (display s p)
50                (write-char #\] p))
51             (bars trace-level p))
52         (set! last-trace-level trace-level)
53         (parameterize ([pretty-initial-indent (fxmin trace-level 11)]
54                        [pretty-line-length 80]
55                        [pretty-one-line-limit 80])
56            (print x p))))))
57
58(define pretty-print-multiple
59  (lambda (ls p)
60    (let ([indent (pretty-initial-indent)])
61      (let f ([x (car ls)] [ls (cdr ls)])
62        ((trace-print) x p)
63        (unless (null? ls)
64          (let f ([n indent])
65            (write-char #\space p)
66            (unless (fx= n 1) (f (fx- n 1))))
67          (f (car ls) (cdr ls)))))))
68
69(define prune-tracer-list
70   (lambda ()
71      (set! tracer-list
72         (let prune ([ls tracer-list])
73            (if (null? ls)
74                '()
75                (let ((t (car ls)))
76                  (if (and (top-level-bound? (tracer-id t))
77                           (eq? (tracer-new t)
78                                (top-level-value (tracer-id t))))
79                      (cons t (prune (cdr ls)))
80                      (prune (cdr ls)))))))))
81
82(set! $trace
83   (lambda ids
84      (prune-tracer-list)
85      (for-each (lambda (id)
86                   (unless (symbol? id)
87                      ($oops 'trace "~s is not a symbol" id))
88                   (unless (top-level-bound? id)
89                      ($oops 'trace "~:s is not bound" id))
90                   (unless (procedure? (top-level-value id))
91                      ($oops 'trace
92                             "the top-level value of ~s is not a procedure"
93                             id)))
94                ids)
95      (if (null? ids)
96          (map tracer-id tracer-list)
97          (map (lambda (id)
98                  (unless (memq id (map tracer-id tracer-list))
99                     (let ([old (top-level-value id)])
100                        (let ([new ($trace-closure id old)])
101                           (if (top-level-mutable? id)
102                               (set-top-level-value! id new)
103                               (begin
104                                 (define-top-level-value id new)
105                                 (warningf 'trace "redefining ~s; existing references will not be traced" id)))
106                           (set! tracer-list
107                                 (cons (make-tracer id old new)
108                                       tracer-list)))))
109                  id)
110               ids))))
111
112(set! $untrace
113   (lambda ids
114      (prune-tracer-list)
115      (let f ([ls tracer-list] [gone '()] [keep '()])
116         (if (null? ls)
117             (begin (set! tracer-list keep)
118                    gone)
119             (let* ([x (car ls)] [id (tracer-id x)])
120                (if (or (null? ids) (memq id ids))
121                    (begin (set-top-level-value! id (tracer-old x))
122                           (f (cdr ls) (cons id gone) keep))
123                    (f (cdr ls) gone (cons x keep))))))))
124
125(set! $trace-closure
126   (lambda (name closure)
127      (unless (procedure? closure)
128         ($oops 'trace "~s is not a procedure" closure))
129      (lambda args
130         (call/1cc
131            (lambda (k)
132               (if (eq? k trace-continuation)
133                   (begin (trace-display (trace-print) (cons name args))
134                          (apply closure args))
135                   (fluid-let ([trace-level (+ 1 trace-level)]
136                               [trace-continuation trace-continuation])
137                      (trace-display (trace-print) (cons name args))
138                      (call-with-values
139                        (lambda ()
140                          (call/1cc
141                            (lambda (k)
142                              (set! trace-continuation k)
143                              (apply closure args))))
144                        (case-lambda
145                          [(x) (trace-display (trace-print) x) x]
146                          [() (trace-display
147                                (lambda (x p) (display x p) (newline p))
148                                "*** no values ***")
149                              (values)]
150                          [args (trace-display pretty-print-multiple args)
151                                (apply values args)])))))))))
152
153) ;let
154