;;; This module contains code for tracing and breakpointing functions using
;;; the SCHEME->C interpreter.  It also contains the code for an error
;;; handler which back traces the control stack.

;*              Copyright 1989 Digital Equipment Corporation
;*                         All Rights Reserved
;*
;* Permission to use, copy, and modify this software and its documentation is
;* hereby granted only under the following terms and conditions.  Both the
;* above copyright notice and this permission notice must appear in all copies
;* of the software, derivative works or modified versions, and any portions
;* thereof, and both notices must appear in supporting documentation.
;*
;* Users of this software agree to the terms and conditions set forth herein,
;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
;* right and license under any changes, enhancements or extensions made to the
;* core functions of the software, including but not limited to those affording
;* compatibility with other hardware or software environments, but excluding
;* applications which incorporate this software.  Users further agree to use
;* their best efforts to return to Digital any such changes, enhancements or
;* extensions that they make and inform Digital of noteworthy uses of this
;* software.  Correspondence should be provided to Digital at:
;* 
;*                       Director of Licensing
;*                       Western Research Laboratory
;*                       Digital Equipment Corporation
;*                       100 Hamilton Avenue
;*                       Palo Alto, California  94301  
;* 
;* This software may be distributed (but not offered for sale or transferred
;* for compensation) to third parties, provided such third parties agree to
;* abide by the terms and conditions of this notice.  
;* 
;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
;* SOFTWARE.

(module scdebug
    (top-level
	TRACED-PROCS BPT-PROCS *ARGS* *RESULT* DOTRACE TRACER
	DOUNTRACE DOBPT DOUNBPT BACKTRACE *DEBUG-ON-ERROR*))

(include "repdef.sc")

;;; Nesting level for traced and breakpointed functions.

(define TRACE-LEVEL 0)

;;; A-lists of traced and breakpointed functions with elements:
;;; (symbol original-procedure debugged-procedure).

(define TRACED-PROCS '())
 
(define BPT-PROCS '())

;;; Arguments at the time of a breakpoint are in *ARGS*, and the result is in
;;; *RESULT* after the function is called.  A new result may be returned by
;;; continuing from the breakpoint with (PROCEED new-value).

(define *ARGS* '())

(define *RESULT* '())

;;; Function tracing

(install-expander
    'TRACE
     (lambda (x e)
	     (if (cdr x)
		 `(map (lambda (f) (dotrace f)) (quote ,(cdr x)))
		 '(map (lambda (x) (car x)) traced-procs))))

(define (DOTRACE name)
    (if (assoc name traced-procs) (dountrace name))
    (if (assoc name bpt-procs) (dounbpt name))
    (let ((proc (top-level-value name))
	  (trace-proc #f))
	 (if (not (procedure? proc))
	     (error 'TRACE "Argument is not a PROCEDURE name"))
	 (if (assoc name traced-procs)
	     (error 'TRACE "~s is already traced" name))
	 (set! trace-proc (tracer name proc))
	 (set! traced-procs (cons (list name proc trace-proc) traced-procs))
	 (set-top-level-value! name trace-proc))
    name)

(define (TRACER name proc)
    (lambda x
	    (format stdout-port "~a~s~%"
		    (make-string (* 2 (min trace-level 15)) #\space)
		    (cons name x))
	    (set! trace-level (+ trace-level 1))
	    (let ((result (apply proc x)))
		 (set! trace-level (- trace-level 1))
		 (format stdout-port "~a~a~s~%"
			 (make-string (* 2 (min trace-level 15)) #\space)
		 	 "==> " result)
		 result)))

(install-expander
    'UNTRACE
    (lambda (x e)
	    (if (null? (cdr x))
		(set! x (map (lambda (x) (car x)) traced-procs))
		(set! x (cdr x)))
	    `(map (lambda (f) (dountrace f)) (quote ,x))))

(define (DOUNTRACE name)
    (let ((name-proc-trace (assoc name traced-procs)))
	 (if (not name-proc-trace)
	     (error 'UNTRACE "~s is not traced" name))
	 (if (eq? (top-level-value name) (caddr name-proc-trace))
	     (set-top-level-value! name (cadr name-proc-trace)))
	 (set! traced-procs (remove name-proc-trace traced-procs)))
    name)

;;; Function breakpoints

(install-expander
    'BPT
     (lambda (x e)
	     (case (length x)
		   ((1) '(map (lambda (x) (car x)) bpt-procs))
		   ((2) `(apply dobpt (quote ,(cdr x))))
		   ((3) (let ((func (e (caddr x) e)))
			     `(apply dobpt
				     (list (quote ,(cadr x)) (quote ,func)))))
		   (else (error 'BPT "Illegal arguments")))))

(define (DOBPT name . condition)
    (if (assoc name traced-procs) (dountrace name))
    (if (assoc name bpt-procs) (dounbpt name))
    (let ((proc (top-level-value name))
	  (bpt-proc #f))
	 (if (not (procedure? proc))
	     (error 'BPT "Argument is not a PROCEDURE name"))
	 (set! bpt-proc
	       (bpter name proc (if condition (eval (car condition)))))
	 (set! bpt-procs (cons (list name proc bpt-proc) bpt-procs))
	 (set-top-level-value! name bpt-proc))
    name)

(define BPTER-PROCNAME "")
	 
(define (BPTER name proc condition)
    (define (XEQ . args)
	    (let ((ftok (enable-system-file-tasks #f)))
		 (let ((result (apply read-eval-print args)))
		      (enable-system-file-tasks ftok)
		      result)))
    (lambda x
	    (set! bpter-procname (c-tscp-ref (stacktrace) 4))
	    (if (or (not condition) (apply condition x))
		(let ((prompt (format "~s- " trace-level)))
		     (set! *args* x)
		     (xeq
			 'header
			 (format "~%~s -calls  - ~s" trace-level
				 (cons name x))
			 'prompt
			 prompt
			 'env
			 (dobacktrace bpter-procname "READ-EVAL-PRINT" 20 #f))
		     (set! trace-level (+ trace-level 1))
		     (set! *result* (apply proc *args*))
		     (set! trace-level (- trace-level 1))
		     (xeq
			 'header
			 (format "~s -returns- ~s" trace-level *result*)
			 'prompt
			 prompt
			 'result
			 *result*
			 'env
			 (dobacktrace bpter-procname "READ-EVAL-PRINT" 20 #f)))
		(apply proc x))))

(install-expander
    'UNBPT
    (lambda (x e)
	    (if (null? (cdr x))
		(set! x (map (lambda (x) (car x)) bpt-procs))
		(set! x (cdr x)))
	    `(map (lambda (f) (dounbpt f)) (quote ,x))))

(define (DOUNBPT name)
    (let ((name-proc-bpt (assoc name bpt-procs)))
	 (if (not name-proc-bpt)
	     (error 'UNBPT "~s is not breakpointed" name))
	 (if (eq? (top-level-value name) (caddr name-proc-bpt))
	     (set-top-level-value! name (cadr name-proc-bpt)))
	 (set! bpt-procs (remove name-proc-bpt bpt-procs)))
    name)

;;; The following functions are used to backtrace the control stack.  The first
;;; performs an insertion sort to insert a new element into a list.

(define (INSERTION-SORT item sorted-items before?)
    (let loop ((next sorted-items) (prev #f))
	 (cond ((null? next)
		(if prev
		    (begin (set-cdr! prev (list item))
			   sorted-items)
		    (list item)))
	       ((not (before? item (car next)))
		(loop (cdr next) next))
	       (prev
		(set-cdr! prev (cons item next))
		sorted-items)
	       (else (cons item sorted-items)))))


;;; Backtracing is done by the following function.  It accepts a starting
;;; function (or #F), a termination function (or #F), a line count, and an
;;; output port.  It returns an environment for use with eval with the
;;; following definitions:  all variables defined in the innermost interpreted
;;; environments, and variables of the form env-n whose value is the
;;; environment at that interpreter level.

(define (DOBACKTRACE start stop lines port)
    (do ((stp (stacktrace) (c-unsigned-ref stp 0))
	 (procname "")
	 (envlist '())
	 (envid '(env-0 env-1 env-2 env-3 env-4 env-5 env-6 env-7 env-8
		  env-9 env-10 env-11 env-12 env-13 env-14 env-15 env-16
		  env-17 env-18 env-19))
	 (string-out (open-output-string)))
	((or (= stp 0)
	     (= lines 0)
	     (null? envid)
	     (and (not start) (equal? procname stop)))
	 (if envlist
	     (append (cdr (assq 'env-0 envlist)) envlist)
	     envlist))
	(set! procname (c-tscp-ref stp 4))
	(cond (start
	       (if (equal? start procname) (set! start #f)))
	      ((not (string? procname))
	       (when port
	             (write (c-tscp-ref stp 8) string-out)
	             (let ((expr (get-output-string string-out)))
		          (if (> (string-length expr) 65)
			         (display (string-append (substring expr 0 65)
					      " ...") port)
			         (display expr port)))
			  (display " in " port)
	       		  (display (car envid) port)
	       		  (newline port))
	       (set! envlist (cons (cons (car envid) procname) envlist))
	       (set! envid (cdr envid))
	       (set! lines (- lines 1)))
	      ((member procname
		       '("SCEVAL_INTERPRETED-PROC" "LOOP [inside EXEC]")))
	      (else
	       (when port
		     (display "(" port)
	             (display procname port)
	             (display " ...)" port)
	             (newline port))
	       (set! lines (- lines 1))))))

;;; A backtrace at a breakpoint is obtained by the following function.

(define (BACKTRACE . count)
    (dobacktrace bpter-procname "READ-EVAL-PRINT" (if count (car count) 20)
	stderr-port)
    #f)

;;; The default error handler is replaced by the following function when
;;; backtracing on error is desired.  It prints the backtrace, and then
;;; enters a read-eval-print loop when *DEBUG-ON-ERROR* is set.

(define *DEBUG-ON-ERROR* #f)

(define (BACKTRACE-ERROR-HANDLER id format-string . args)
    (display (format "***** ~a " id) stderr-port)
    (display (apply format (cons format-string args)) stderr-port)
    (newline stderr-port)
    (set! *error-handler* backtrace-error-handler)
    (when *debug-on-error*
	  (let ((env (dobacktrace "ERROR" "READ-EVAL-PRINT" 20 stderr-port))
		(ftok (enable-system-file-tasks #f)))
	       (set! *debug-on-error* #f)
	       (let loop () (when (char-ready? stdin-port)
				  (if (not (eof-object?
					       (read-char stdin-port)))
				      (loop))))
	       (read-eval-print 'prompt ">> " 'header #f 'env env)
	       (enable-system-file-tasks ftok)
	       (set! *debug-on-error* #t)))
    (reset))

;;; Keyboard interrupt signals are handled by the following function.  If
;;; the interpreter is currently reading stdin, then this results in a reset.
;;; Otherwise, a stack trace is printed and the debugger is entered.  A normal
;;; exit from the debugger results in the Scheme computation continuing.

(define (ON-INTERRUPT sig)
    (if *reading-stdin* (reset))
    (let ((ftok (enable-system-file-tasks #f))
	  (start (c-tscp-ref
		     (c-unsigned-ref (c-unsigned-ref (stacktrace) 0) 0) 4)))
	 (format stderr-port "~%***** INTERRUPT *****~%")
	 (dobacktrace start "READ-EVAL-PRINT" 20 stderr-port)
	 (read-eval-print 'header #f 'prompt ">> "
	     'env (dobacktrace start "READ-EVAL-PRINT" 20 #f))
	 (enable-system-file-tasks ftok)))