168 lines
4.6 KiB
Scheme
168 lines
4.6 KiB
Scheme
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
|
|
;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum
|
|
;;;
|
|
;;; This program is free software: you can redistribute it and/or modify
|
|
;;; it under the terms of the GNU General Public License version 3 as
|
|
;;; published by the Free Software Foundation.
|
|
;;;
|
|
;;; This program is distributed in the hope that it will be useful, but
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;; General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
|
|
(library (ikarus trace)
|
|
(export make-traced-procedure)
|
|
(import (except (ikarus) make-traced-procedure))
|
|
|
|
(define k* '())
|
|
|
|
(define display-prefix
|
|
(lambda (ls t)
|
|
(unless (null? ls)
|
|
(display (if t "|" " "))
|
|
(display-prefix (cdr ls) (not t)))))
|
|
|
|
(define display-trace
|
|
(lambda (k* v)
|
|
(display-prefix k* #t)
|
|
(write v)
|
|
(newline)))
|
|
|
|
(define make-traced-procedure
|
|
(case-lambda
|
|
[(name proc) (make-traced-procedure name proc (lambda (x) x))]
|
|
[(name proc filter)
|
|
(lambda args
|
|
(call/cf
|
|
(lambda (f)
|
|
(cond
|
|
[(memq f k*) =>
|
|
(lambda (ls)
|
|
(display-trace ls (filter (cons name args)))
|
|
(apply proc args))]
|
|
[else
|
|
(display-trace (cons 1 k*) (filter (cons name args)))
|
|
(dynamic-wind
|
|
(lambda () (set! k* (cons f k*)))
|
|
(lambda ()
|
|
(call-with-values
|
|
(lambda ()
|
|
(call/cf
|
|
(lambda (nf)
|
|
(set! f nf)
|
|
(set-car! k* nf)
|
|
(apply proc args))))
|
|
(lambda v*
|
|
(display-prefix k* #t)
|
|
(unless (null? v*)
|
|
(let ([v* (filter v*)])
|
|
(write (car v*))
|
|
(let f ([v* (cdr v*)])
|
|
(unless (null? v*)
|
|
(write-char #\space)
|
|
(write (car v*))
|
|
(f (cdr v*))))))
|
|
(newline)
|
|
(apply values v*))))
|
|
(lambda () (set! k* (cdr k*))))]))))])))
|
|
|
|
|
|
#!eof
|
|
|
|
(define traced-symbols '())
|
|
|
|
(define untrace-symbol!
|
|
(lambda (s)
|
|
(define loop
|
|
(lambda (ls)
|
|
(cond
|
|
[(null? ls) '()]
|
|
[(eq? s (caar ls))
|
|
(let ([a (cdar ls)])
|
|
(when (eq? (cdr a) (symbol-value s))
|
|
(set-symbol-value! s (car a)))
|
|
(cdr ls))]
|
|
[else (cons (car ls) (loop (cdr ls)))])))
|
|
(set! traced-symbols (loop traced-symbols))))
|
|
|
|
(define trace-symbol!
|
|
(lambda (s)
|
|
(cond
|
|
[(assq s traced-symbols) =>
|
|
(lambda (pr)
|
|
(let ([a (cdr pr)] [v (symbol-value s)])
|
|
(unless (eq? (cdr a) v)
|
|
(unless (procedure? v)
|
|
(die 'trace
|
|
"the top-level value is not a procedure"
|
|
s v))
|
|
(let ([p (make-traced-procedure s v)])
|
|
(set-car! a v)
|
|
(set-cdr! a p)
|
|
(set-symbol-value! s p)))))]
|
|
[else
|
|
(unless (symbol-bound? s)
|
|
(die 'trace "unbound" s))
|
|
(let ([v (symbol-value s)])
|
|
(unless (procedure? v)
|
|
(die 'trace "the top-level value is not a procedure" s v))
|
|
(let ([p (make-traced-procedure s v)])
|
|
(set! traced-symbols
|
|
(cons (cons s (cons v p)) traced-symbols))
|
|
(set-symbol-value! s p)))])))
|
|
Try:
|
|
|
|
(trace-define fact
|
|
(lambda (n)
|
|
(if (zero? n)
|
|
1
|
|
(* n (fact (sub1 n))))))
|
|
(fact 5)
|
|
|
|
(trace-define (fact n m)
|
|
(cond
|
|
[(zero? n) m]
|
|
[else (fact (sub1 n) (* n m))]))
|
|
(fact 5 1)
|
|
|
|
|
|
(trace-define (fact n m k)
|
|
(cond
|
|
[(zero? n) (k m)]
|
|
[else (begin (fact (sub1 n) (* n m) k) 0)]))
|
|
|
|
|
|
(call/cc
|
|
(lambda (k)
|
|
(fact 6 1
|
|
(trace-lambda escape (v) (k v)))))
|
|
|
|
|
|
(call/cc
|
|
(lambda k*
|
|
(trace-define (fact n)
|
|
(cond
|
|
[(zero? n)
|
|
(call/cc
|
|
(lambda (k)
|
|
(set! k* (cons k k*))
|
|
1))]
|
|
[else (* n (fact (sub1 n)))]))
|
|
(fact 9)
|
|
(let ([k (car k*)])
|
|
(set! k* (cdr k*))
|
|
(k 100000))))
|
|
|
|
|
|
|
|
|
|
|
|
(trace-define (infinite-loop n)
|
|
(infinite-loop (add1 n)))
|
|
(infinite-loop 0)
|
|
|