Import Debian changes 2d2-1debian/2d2-1

slib (2d2-1) unstable; urgency=low

  * New upstream version
  * Revert back to free.  Is now so.

slib (2d1-1) unstable; urgency=low

  * New upstream version.
  * Move to non-free.  FSF pointed out license doesn't allow modified
    versions to be distributed.
  * Get a complete list of copyrights that apply to the source into
    copyright file.
  * Remove setup for guile 1.3.
  * Remove postrm.  Just calling install-info (lintian)  Move install-info
    call to prerm since doc-base doesn't do install-info.

slib (2c9-3) unstable; urgency=low

  * Change info location to section "The Algorithmic Language Scheme" to
    match up with where guile puts it's files.
  * Postinst is running slibconfig now.  (Closes: #75891)

slib (2c9-2) unstable; urgency=low

  * Stop installing slibconfig (for guile).
  * In postinst if /usr/sbin/slibconnfig exists call it (Close: #75843
    #75891).

slib (2c9-1) unstable; urgency=low

  * New upstream (Closes: #74760)
  * replace string-index with strsrch:string-index in http-cgi.scm.
  * Add doc-base support (Closes: #31163)

1 files changed, 199 insertions, 55 deletions

diff --git a/trace.scm b/trace.scm
index 3476548..aa2c3d7 100644
--- a/trace.scm
+++ b/trace.scm
@@ -1,9 +1,9 @@
 ;;;; "trace.scm" Utility macros for tracing in Scheme.
-;;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Aubrey Jaffer.
+;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2000 Aubrey Jaffer
 ;
-;Permission to copy this software, to redistribute it, and to use it
-;for any purpose is granted, subject to the following restrictions and
-;understandings.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
 ;
 ;1.  Any copy made of this software must include this copyright notice
 ;in full.
@@ -18,40 +18,112 @@
 ;each case.
 
 (require 'qp)				;for the qp printer.
-(define debug:indent 0)
+(define trace:indent 0)
+(define debug:call-stack '())		;keeps track of call stack.
+(define debug:max-count 5)
 
-(define debug:tracef
-  (let ((null? null?)			;These bindings are so that
-	(not not)			;tracef will not trace parts
-	(car car) (cdr cdr)		;of itself.
+;;Formats for call-stack elements:
+;; (procedure-count name . args)	;for debug:track procedure
+;; (procedure-count name)		;for debug:stack procedure
+;;Traced functions also stack.
+
+(define print-call-stack
+  (let ((car car) (null? null?) (current-error-port current-error-port)
+	(qpn qpn) (for-each for-each))
+    (lambda cep
+      (set! cep (if (null? cep) (current-error-port) (car cep)))
+      (for-each qpn debug:call-stack))))
+
+(define (call-stack-news? name)
+  (or (null? debug:call-stack)
+      (not (eq? name (cadar debug:call-stack)))
+      (< (caar debug:call-stack) debug:max-count)))
+
+(define debug:trace-procedure
+  (let ((null? null?) (not not)		;These bindings are so that
+	(cdar cdar) (cadar cadar)	;trace will not trace parts
+	(car car) (cdr cdr) (caar caar)	;of itself.
 	(eq? eq?) (+ +) (zero? zero?) (modulo modulo)
-	(apply apply) (display display) (qpn qpn)
+	(apply apply) (display display) (qpn qpn) (list list) (cons cons)
 
 	(CALL (string->symbol "CALL"))
 	(RETN (string->symbol "RETN")))
-    (lambda (function . optname)
-      (set! debug:indent 0)
+    (lambda (how function . optname)
+      (set! trace:indent 0)
       (let ((name (if (null? optname) function (car optname))))
-	(lambda args
-	  (cond ((and (not (null? args))
-		      (eq? (car args) 'debug:untrace-object)
-		      (null? (cdr args)))
-		 function)
-		(else
-		 (do ((i debug:indent (+ -1 i))) ((zero? i)) (display #\ ))
-		 (apply qpn CALL name args)
-		 (set! debug:indent (modulo (+ 1 debug:indent) 16))
-		 (let ((ans (apply function args)))
-		   (set! debug:indent (modulo (+ -1 debug:indent) 16))
-		   (do ((i debug:indent (+ -1 i))) ((zero? i)) (display #\ ))
-		   (qpn RETN name ans)
-		   ans))))))))
-
-;;; the reason I use a symbol for debug:untrace-object is so
-;;; that functions can still be untraced if this file is read in twice.
-
-(define (debug:untracef function)
-  (set! debug:indent 0)
+	(case how
+	  ((trace)
+	   (lambda args
+	     (cond ((and (not (null? args))
+			 (eq? (car args) 'debug:untrace-object)
+			 (null? (cdr args)))
+		    function)
+		   ((call-stack-news? name)
+		    (let ((cs debug:call-stack))
+		      (set! debug:call-stack
+			    (if (and (not (null? debug:call-stack))
+				     (eq? name (cadar debug:call-stack)))
+				(cons (cons (+ 1 (caar debug:call-stack))
+					    (cdar debug:call-stack))
+				      (cdr debug:call-stack))
+				(cons (list 1 name) debug:call-stack)))
+		      (do ((i trace:indent (+ -1 i))) ((zero? i)) (display #\ ))
+		      (apply qpn CALL name args)
+		      (set! trace:indent (modulo (+ 1 trace:indent) 16))
+		      (let ((ans (apply function args)))
+			(set! trace:indent (modulo (+ -1 trace:indent) 16))
+			(do ((i trace:indent (+ -1 i))) ((zero? i)) (display #\ ))
+			(qpn RETN name ans)
+			(set! debug:call-stack cs)
+			ans)))
+		   (else (apply function args)))))
+	  ((track)
+	   (lambda args
+	     (cond ((and (not (null? args))
+			 (eq? (car args) 'debug:untrace-object)
+			 (null? (cdr args)))
+		    function)
+		   ((call-stack-news? name)
+		    (let ((cs debug:call-stack))
+		      (set! debug:call-stack
+			    (if (and (not (null? debug:call-stack))
+				     (eq? name (cadar debug:call-stack)))
+				(cons (cons (+ 1 (caar debug:call-stack))
+					    (cdar debug:call-stack))
+				      (cdr debug:call-stack))
+				(cons (cons 1 (cons name args))
+				      debug:call-stack)))
+		      (let ((ans (apply function args)))
+			(set! debug:call-stack cs)
+			ans)))
+		   (else (apply function args)))))
+	  ((stack)
+	   (lambda args
+	     (cond ((and (not (null? args))
+			 (eq? (car args) 'debug:untrace-object)
+			 (null? (cdr args)))
+		    function)
+		   ((call-stack-news? name)
+		    (let ((cs debug:call-stack))
+		      (set! debug:call-stack
+			    (if (and (not (null? debug:call-stack))
+				     (eq? name (cadar debug:call-stack)))
+				(cons (cons (+ 1 (caar debug:call-stack))
+					    (cdar debug:call-stack))
+				      (cdr debug:call-stack))
+				(cons (list 1 name) debug:call-stack)))
+		      (let ((ans (apply function args)))
+			(set! debug:call-stack cs)
+			ans)))
+		   (else (apply function args)))))
+	  (else
+	   (slib:error 'debug:trace-procedure 'unknown 'how '= how)))))))
+
+;;; The reason I use a symbol for debug:untrace-object is so that
+;;; functions can still be untraced if this file is read in twice.
+
+(define (untracef function)
+  (set! trace:indent 0)
   (function 'debug:untrace-object))
 
 ;;;;The trace: functions wrap around the debug: functions to provide
@@ -63,48 +135,120 @@
 (define trace:deler (alist-remover eq?))
 
 (define *traced-procedures* '())
-(define (trace:tracef fun sym)
+(define *tracked-procedures* '())
+(define *stacked-procedures* '())
+(define (trace:trace-procedure how fun sym)
+  (define cep (current-error-port))
   (cond ((not (procedure? fun))
-	 (display "WARNING: not a procedure " (current-error-port))
-	 (display sym (current-error-port))
-	 (newline (current-error-port))
+	 (display "WARNING: not a procedure " cep)
+	 (display sym cep)
+	 (newline cep)
 	 (set! *traced-procedures* (trace:deler *traced-procedures* sym))
+	 (set! *tracked-procedures* (trace:deler *tracked-procedures* sym))
+	 (set! *stacked-procedures* (trace:deler *stacked-procedures* sym))
 	 fun)
 	(else
-	 (let ((p (assq sym *traced-procedures*)))
+	 (let ((p (assq sym (case how
+			      ((trace) *traced-procedures*)
+			      ((track) *tracked-procedures*)
+			      ((stack) *stacked-procedures*)))))
 	   (cond ((and p (eq? (cdr p) fun))
 		  fun)
 		 (else
-		  (let ((tfun (debug:tracef fun sym)))
-		    (set! *traced-procedures*
-			  (trace:adder *traced-procedures* sym tfun))
+		  (let ((tfun (debug:trace-procedure how fun sym)))
+		    (case how
+		      ((trace)
+		       (set! *traced-procedures*
+			     (trace:adder *traced-procedures* sym tfun)))
+		      ((track)
+		       (set! *tracked-procedures*
+			     (trace:adder *tracked-procedures* sym tfun)))
+		      ((stack)
+		       (set! *stacked-procedures*
+			     (trace:adder *stacked-procedures* sym tfun))))
 		    tfun)))))))
 
-(define (trace:untracef fun sym)
-  (let ((p (assq sym *traced-procedures*)))
-    (set! *traced-procedures* (trace:deler *traced-procedures* sym))
-    (cond ((not (procedure? fun)) fun)
-	  ((not p) fun)
-	  ((eq? (cdr p) fun)
-	   (debug:untracef fun))
-	  (else fun))))
+(define (trace:untrace-procedure fun sym)
+  (define finish
+    (lambda (p)
+      (cond ((not (procedure? fun)) fun)
+	    ((eq? (cdr p) fun) (untracef fun))
+	    (else fun))))
+  (cond ((assq sym *traced-procedures*)
+	 =>
+	 (lambda (p)
+	   (set! *traced-procedures* (trace:deler *traced-procedures* sym))
+	   (finish p)))
+	((assq sym *tracked-procedures*)
+	 =>
+	 (lambda (p)
+	   (set! *tracked-procedures* (trace:deler *tracked-procedures* sym))
+	   (finish p)))
+	((assq sym *stacked-procedures*)
+	 =>
+	 (lambda (p)
+	   (set! *stacked-procedures* (trace:deler *stacked-procedures* sym))
+	   (finish p)))
+	(else fun)))
 
-(define tracef debug:tracef)
-(define untracef debug:untracef)
+(define (tracef . args) (apply debug:trace-procedure 'trace args))
+(define (trackf . args) (apply debug:trace-procedure 'track args))
+(define (stackf . args) (apply debug:trace-procedure 'stack args))
 
 ;;;; Finally, the macros trace and untrace
 
 (defmacro trace xs
   (if (null? xs)
-      `(begin (set! debug:indent 0)
-	      ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x)))
+      `(begin (set! trace:indent 0)
+	      ,@(map (lambda (x)
+		       `(set! ,x (trace:trace-procedure 'trace ,x ',x)))
 		     (map car *traced-procedures*))
 	      (map car *traced-procedures*))
-      `(begin ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x))) xs))))
+      `(begin ,@(map (lambda (x)
+		       `(set! ,x (trace:trace-procedure 'trace ,x ',x))) xs))))
+(defmacro track xs
+  (if (null? xs)
+      `(begin ,@(map (lambda (x)
+		       `(set! ,x (trace:trace-procedure 'track ,x ',x)))
+		     (map car *tracked-procedures*))
+	      (map car *tracked-procedures*))
+      `(begin ,@(map (lambda (x)
+		       `(set! ,x (trace:trace-procedure 'track ,x ',x))) xs))))
+(defmacro stack xs
+  (if (null? xs)
+      `(begin ,@(map (lambda (x)
+		       `(set! ,x (trace:trace-procedure 'stack ,x ',x)))
+		     (map car *stacked-procedures*))
+	      (map car *stacked-procedures*))
+      `(begin ,@(map (lambda (x)
+		       `(set! ,x (trace:trace-procedure 'stack ,x ',x))) xs))))
+
 (defmacro untrace xs
   (if (null? xs)
       (slib:eval
-       `(begin ,@(map (lambda (x) `(set! ,x (trace:untracef ,x ',x)))
+       `(begin ,@(map (lambda (x)
+			`(set! ,x (trace:untrace-procedure ,x ',x)))
 		      (map car *traced-procedures*))
 	       '',(map car *traced-procedures*)))
-      `(begin ,@(map (lambda (x) `(set! ,x (trace:untracef ,x ',x))) xs))))
+      `(begin ,@(map (lambda (x)
+		       `(set! ,x (trace:untrace-procedure ,x ',x))) xs))))
+
+(defmacro untrack xs
+  (if (null? xs)
+      (slib:eval
+       `(begin ,@(map (lambda (x)
+			`(set! ,x (track:untrack-procedure ,x ',x)))
+		      (map car *tracked-procedures*))
+	       '',(map car *tracked-procedures*)))
+      `(begin ,@(map (lambda (x)
+		       `(set! ,x (track:untrack-procedure ,x ',x))) xs))))
+
+(defmacro unstack xs
+  (if (null? xs)
+      (slib:eval
+       `(begin ,@(map (lambda (x)
+			`(set! ,x (stack:unstack-procedure ,x ',x)))
+		      (map car *stacked-procedures*))
+	       '',(map car *stacked-procedures*)))
+      `(begin ,@(map (lambda (x)
+		       `(set! ,x (stack:unstack-procedure ,x ',x))) xs))))