~ chicken-core (chicken-5) c41657eedc99190a644df6581a8bf9944452a97a

commit c41657eedc99190a644df6581a8bf9944452a97a
Author:     Felix <bunny351@gmail.com>
AuthorDate: Sun Oct 11 11:37:06 2009 +0200
Commit:     Felix <bunny351@gmail.com>
CommitDate: Sun Oct 11 11:37:06 2009 +0200

    remove tracing facilities from csi - this can be done better using the advice egg

diff --git a/csi.scm b/csi.scm
index c5184965..cd9921de 100644
--- a/csi.scm
+++ b/csi.scm
@@ -48,15 +48,14 @@ EOF
   parse-option-string chop-separator lookup-script-file
   report describe dump hexdump bytevector-data get-config
   deldups tty-input?
-  history-list history-count history-add history-ref
-  trace-indent trace-indent-level traced-procedure-entry traced-procedure-exit)
+  history-list history-count history-add history-ref)
 
 (declare
   (always-bound
     ##sys#windows-platform)
-  (hide parse-option-string bytevector-data member* canonicalize-args do-trace do-untrace
-	traced-procedures describer-table dirseparator? resolve-var
-	findall trace-indent command-table) )
+  (hide parse-option-string bytevector-data member* canonicalize-args 
+	describer-table dirseparator? resolve-var
+	findall command-table) )
 
 
 ;;; Parameters:
@@ -265,7 +264,6 @@ EOF
 	(integer? integer?)
 	(values values) )
     (lambda (form)
-      (set! trace-indent-level 0)
       (cond ((eof-object? form) (exit))
 	    ((and (pair? form)
 		  (eq? 'unquote (##sys#slot form 0)) )
@@ -314,11 +312,6 @@ EOF
 			   (receive rs (time (eval x))
 			     (history-add rs)
 			     (apply values rs) ) ) )
-			((tr) (do-trace (map resolve-var (string-split (read-line)))))
-			((utr) (do-untrace (map resolve-var (string-split (read-line)))))
-			((info)
-			 (when (pair? traced-procedures)
-			   (printf "Traced: ~s~%" (map car traced-procedures)) ) )
 			((exn) 
 			 (when ##sys#last-exception
 			   (history-add (list ##sys#last-exception))
@@ -337,9 +330,6 @@ EOF
  ,ln FILENAME ...  Load one or more files and print result of each top-level expression
  ,r                Show system information
  ,s TEXT ...       Execute shell-command
- ,tr NAME ...      Trace procedures
- ,utr NAME ...     Untrace procedures
- ,info             List traced procedures
  ,exn              Describe last exception
  ,t EXP            Evaluate form and print elapsed time
  ,x EXP            Pretty print expanded expression EXP\n")
@@ -363,86 +353,6 @@ EOF
   (##sys#strip-syntax (string->symbol str) (##sys#current-environment) #t))
 
 
-;;; Tracing:
-
-(define (del x lst tst)
-  (let loop ([lst lst])
-    (if (null? lst)
-	'()
-	(let ([y (car lst)])
-	  (if (tst x y)
-	      (cdr lst)
-	      (cons y (loop (cdr lst))) ) ) ) ) )
-
-(define trace-indent-level 0)
-(define traced-procedures '())
-(define broken-procedures '())
-
-(define trace-indent
-  (lambda ()
-    (write-char #\|)
-    (do ((i trace-indent-level (sub1 i)))
-	((<= i 0))
-      (write-char #\space) ) ) )
-
-(define traced-procedure-entry
-  (lambda (name args)
-    (trace-indent)
-    (set! trace-indent-level (add1 trace-indent-level))
-    (write (cons name args))
-    (##sys#write-char-0 #\newline ##sys#standard-output) 
-    (flush-output) ) )
-
-(define traced-procedure-exit
-  (lambda (name results)
-    (set! trace-indent-level (sub1 trace-indent-level))
-    (trace-indent)
-    (write name)
-    (display " -> ")
-    (for-each
-     (lambda (x)
-       (write x)
-       (write-char #\space) )
-     results)
-    (##sys#write-char-0 #\newline ##sys#standard-output) 
-    (flush-output) ) )
-
-(define do-trace
-  (lambda (names)
-    (if (null? names)
-	(for-each (lambda (a) (print (car a))) traced-procedures) 
-	(for-each
-	 (lambda (s)
-	   (let ((s (expand s)))
-	     (cond ((assq s traced-procedures)
-		    (##sys#warn "procedure already traced" s) )
-		   (else
-		    (let ((old (##sys#slot s 0)))
-		      (cond ((not (procedure? old)) (##sys#error "cannot trace non-procedure" s))
-			    (else
-			     (set! traced-procedures (cons (cons s old) traced-procedures))
-			     (##sys#setslot
-			      s 0
-			      (lambda args
-				(traced-procedure-entry s args)
-				(call-with-values (lambda () (apply old args))
-				  (lambda results
-				    (traced-procedure-exit s results) 
-				    (apply values results) ) ) ) ) ) ) ) ) ) ) )
-	 names) ) ) )
-
-(define do-untrace 
-  (lambda (names)
-    (for-each
-     (lambda (s)
-       (let* ((s (expand s))
-	      (p (assq s traced-procedures)) )
-	 (cond ((not p) (##sys#warn "procedure not traced" s))
-	       (else
-		(##sys#setslot s 0 (cdr p))
-		(set! traced-procedures (del p traced-procedures eq?) ) ) ) ) )
-     names) ) )
-
 ;;; Parse options from string:
 
 (define (parse-option-string str)
@@ -736,6 +646,15 @@ EOF
 
 ;;; Start interpreting:
 
+(define (del x lst tst)
+  (let loop ([lst lst])
+    (if (null? lst)
+	'()
+	(let ([y (car lst)])
+	  (if (tst x y)
+	      (cdr lst)
+	      (cons y (loop (cdr lst))) ) ) ) ) )
+
 (define (deldups lis . maybe-=)
   (let ((elt= (optional maybe-= equal?)))
     (let recur ((lis lis))