DataMuseum.dk

top - download

    Length: 16605 (0x40dd)
    Types: TextFile
    Names: »debug.scm.76«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─ ⟦this⟧ »EUUGD11/gnu-31mar87/scheme/scm/debug.scm.76« 

TextFile

;;; -*-SCHEME-*-
;;;
;;;	Copyright (c) 1984 Massachusetts Institute of Technology
;;;
;;;	All rights reserved.  This software is distributed on the
;;;	condition that any improvements or modifications to it are
;;;	returned to the Scheme project at MIT.
;;;
;;;	Permission to copy all or part of this material is granted,
;;;	provided that the copies are not made or distributed for
;;;	resale, the MIT copyright notice appears, and that notice is
;;;	given that copying is by permission of Massachusetts Institute
;;;	of Technology.
;;;

;;;; Debugger

(in-package debugger-package

(declare (usual-integrations))

(define debug-package
  (make-package debug-package
		((current-continuation)
		 (previous-continuations)
		 (command-set (make-command-set 'DEBUG-COMMANDS))
		 (current-reduction-number)
		 (current-number-of-reductions)
		 (current-reduction)
		 (current-environment)
		 (reduction-wrap-around-tag 'WRAP-AROUND)
		 (print-user-friendly-name
		  (access print-user-friendly-name env-package))
		 (print-expression pp)
		 (student-walk? #!FALSE)
		 (print-return-values? #!FALSE))

(define (define-debug-command letter function help-text)
  (define-letter-command command-set letter function help-text))
\f


;;; Basic Commands

(define-debug-command '? (standard-help-command command-set)
		      "Help, list command letters")

(define-debug-command 'Q standard-exit-command "Quit (exit DEBUG)")

(define (debug . optional)
  (fluid-let ((current-continuation)
	      (previous-continuations '())
	      (current-reduction-number)
	      (current-number-of-reductions)
	      (current-reduction #!FALSE)
	      (current-environment '()))

    (debug-abstract-continuation
     (if (null? optional) (rep-continuation) (car optional)))))

(define (debug-abstract-continuation continuation)
  (set-current-continuation! continuation initial-reduction-number)
  (letter-commands command-set
		   (lambda ()
		     (print-current-expression)
		     ((standard-rep-message "Debugger")))
		   (standard-rep-prompt "Debug-->")))

(define (undefined-environment? environment)
  (disjunction (continuation-undefined-environment? environment)
	       (eq? environment system-global-environment)
	       (conjunction
		(environment? environment)
		((access system-external-environment? environment-package)
		 environment))))

(define (print-undefined-environment)
  (format "~%Undefined environment at this subproblem/reduction level"))

(define (with-rep-alternative env receiver)
  (if (undefined-environment? env)
      (sequence
       (print-undefined-environment)
       (format "~%Using the read-eval-print environment instead!")
       (receiver (rep-environment)))
      (receiver env)))

(define (if-valid-environment env receiver)
  (if (undefined-environment? env)
      (print-undefined-environment)
      (receiver env)))

(define (current-expression)
   (if current-reduction
       (reduction-expression current-reduction)
       (continuation-expression current-continuation)))
\f


;;;; Random display commands

(define (pretty-print-current-expression)
  (print-expression (current-expression)))

(define-debug-command 'L pretty-print-current-expression
  "(list expression) Pretty-print the current expression")

(define (pretty-print-reduction-function)
  (if-valid-environment (if current-reduction
			    (reduction-environment current-reduction)
			    current-environment)
			(lambda (env) (pp (environment-procedure env)))))

(define-debug-command 'P pretty-print-reduction-function
  "Pretty print current procedure")

(define (print-current-expression)
  (define (print-current-reduction)
    (format "~2xReduction Number:~x~o~%Expression:" current-reduction-number)
    (print-expression (reduction-expression current-reduction)))

  (define (print-application-information env)
    (define (do-it return?)
      (if return? (format "~%within ") (format "within "))
      (print-user-friendly-name env)
      (if return?
	  (format "~%applied to ~@68o" (environment-arguments env))
	  (format " applied to ~@68o" (environment-arguments env))))

    (let ((output (with-output-to-string (lambda () (do-it #!FALSE)))))
      (if (< (string-size output) *printer-width*)
	  (format "~%~s" output)
	  (do-it #!TRUE))))

  (if (null-continuation? current-continuation)
      (format "~%Null continuation")
      (sequence
       (format "~%Subproblem Level: ~o" (length previous-continuations))
       (if current-reduction
	   (print-current-reduction)
	   (sequence
	    (format "~%Possibly Incomplete Expression:")
	    (print-expression (continuation-expression current-continuation))))
       (if-valid-environment current-environment
			     print-application-information))))

(define-debug-command 'S print-current-expression
  "Print the current subproblem/reduction")

(define (reductions-command)
  (if (null-continuation? current-continuation)
      (format "~%Null continuation")
      (let loop ((r (continuation-reductions current-continuation)))
	(cond ((pair? r)
	       (print-expression (reduction-expression (car r)))
	       (loop (cdr r)))
	      ((wrap-around-in-reductions? r)
	       (format "~%Wrap Around in the reductions at this level."))
	      (else 'done)))))

(define-debug-command 'R reductions-command
  "Print the reductions of the current subproblem level")
\f


;;;; Short history display

(define (summarize-history-command)
  (define (print-continuations cont level)
    (define (print-reductions reductions show-all?)
      (define (print-reduction red number)
	(terse-print-expression level
				(reduction-expression red)
				(reduction-environment red)))
      
      (let loop ((reductions reductions) (number 0))
	   (if (pair? reductions)
	       (sequence
		(print-reduction (car reductions) number)
		(if show-all? (loop (cdr reductions) (1+ number)))))))

    (if (null-continuation? cont)
	*the-non-printing-object*
	(sequence
	 (let ((reductions (continuation-reductions cont)))
	   (if (not (pair? reductions))
	       (terse-print-expression level
				       (continuation-expression cont)
				       (continuation-environment cont))
	       (print-reductions reductions (= level 0))))
	 (print-continuations (continuation-next-continuation cont)
			      (1+ level)))))

  (let ((top-continuation (if (null? previous-continuations)
			      current-continuation
			      (car (last-pair previous-continuations)))))

    (if (null-continuation? top-continuation)
	(format "~%No history available")
	(sequence
	 (format "~%Sub Prb. Procedure Name    Expression~%")
	 (print-continuations top-continuation 0)))))

(define terse-print-expression
  (let ((the-non-printing-symbol (make-symbol "")))
    (named-lambda (terse-print-expression level expression environment)
      (format "~%~@3o~:20o~4x~@:52c"
	      level
	      ;; procedure name
	      (if (disjunction (undefined-environment? environment)
			       (special-name? (environment-name environment)))
		  the-non-printing-symbol
		  (environment-name environment))
	      expression))))

(define-debug-command 'H summarize-history-command
  "Prints a summary of the entire history")
\f


;;;; Motion to earlier expressions

(define (earlier-reduction)
  (define (up! message)
    (format "~%~s~%Going to the previous (earlier) continuation!" message)
    (earlier-continuation-command))
  
  (cond ((conjunction student-walk?
		      (> (length previous-continuations) 0)
		      (= current-reduction-number 0))
	 (earlier-continuation-command))
	((< current-reduction-number (-1+ current-number-of-reductions))
	 (set-current-reduction! (1+ current-reduction-number))
	 (print-current-expression))
	((wrap-around-in-reductions?
	  (continuation-reductions current-continuation))
	 (up! "Wrap around in reductions at this level!"))
	(else (up! "No more reductions at this level!"))))

(define-debug-command 'B earlier-reduction "Earlier reduction (Back in time)")

(define (earlier-subproblem)
  (let ((new (continuation-next-continuation current-continuation)))
    (set! previous-continuations
	  (cons current-continuation previous-continuations))
    (set-current-continuation! new normal-reduction-number)))

(define (earlier-continuation-command)
  (if (not (null-continuation? (continuation-next-continuation
				current-continuation)))
      (earlier-subproblem)
      (format "~%There are only ~o subproblem levels"
	      (length previous-continuations)))
  (print-current-expression))

(define-debug-command 'U earlier-continuation-command
  "Move (Up) to the previous (earlier) continuation")
\f


;;;; Motion to later expressions

(define (later-reduction)
  (cond ((> current-reduction-number 0)
	 (set-current-reduction! (-1+ current-reduction-number))
	 (print-current-expression))
	((disjunction (not student-walk?)
		      (= (length previous-continuations) 1))
	 (later-continuation-TO-LAST-REDUCTION))
	(else (later-continuation))))

(define-debug-command 'F later-reduction "Later reduction (Forward in time)")

(define (later-continuation)
  (if (null? previous-continuations)
      (format "~%Already at lowest subproblem level")
      (sequence (later-subproblem) (print-current-expression))))

(define (later-continuation-TO-LAST-REDUCTION)
  (define (later-subproblem-TO-LAST-REDUCTION)
    (set-current-continuation!
     (car (set! previous-continuations (cdr previous-continuations)))
     last-reduction-number))

  (if (null? previous-continuations)
      (format "~%Already at lowest subproblem level")
      (sequence (later-subproblem-TO-LAST-REDUCTION)
		(print-current-expression))))

(define (later-subproblem)
  (set-current-continuation!
   (car (set! previous-continuations (cdr previous-continuations)))
   normal-reduction-number))

(define (later-continuation-command)
  (if (null? previous-continuations)
      (format "~%Already at oldest continuation")
      (sequence (later-subproblem) (print-current-expression))))

(define-debug-command 'D later-continuation-command
  "Move (Down) to the next (later) continuation")
\f


;;;; General motion command

(define (goto-command)
  (define (get-reduction-number)
    (format "~%Reduction Number (0 through ~o inclusive: "
	    (-1+ current-number-of-reductions))
    (let ((red (read)))
      (cond ((not (number? red))
	     (tyo #\BELL)
	     (format "~%Reduction number must be numeric!")
	     (get-reduction-number))
	    ((not (conjunction (>= red 0)
			       (< red current-number-of-reductions)))
	     (format "~%Reduction number out of range.!")
	     (get-reduction-number))
	    (else (set-current-reduction! red)))))

  (define (choose-reduction)
    (cond ((> current-number-of-reductions 1) (get-reduction-number))
	  ((= current-number-of-reductions 1)
	   (format "~%There is only one reduction for this subproblem")
	   (set-current-reduction! 1))
	  (else (format "~%There are no reductions for this subproblem."))))
  
  (define (get-subproblem-number)
    (format "~%Subproblem number: ")
    (let ((len (length previous-continuations)) (sub (read)))
      (cond ((not (number? sub))
	     (tyo #\BELL)
	     (format "~%Subproblem level must be numeric!")
	     (get-subproblem-number))
	    ((< sub len) (repeat later-subproblem (- len sub))
			 (choose-reduction))
	    (else
	     (let loop ((len len))
	       (cond ((= sub len) (choose-reduction))
		     ((null-continuation?
		       (continuation-next-continuation current-continuation))
		      (format "~%There is no such subproblem.")
		      (format "~%Now at subproblem number: ~o"
			      (length previous-continuations))
		      (choose-reduction))
		     (else (earlier-subproblem) (loop (1+ len)))))))))

  (get-subproblem-number)
  (print-current-expression))

(define-debug-command 'G goto-command
  "Go to a particular Subproblem/Reduction level")
\f


;;;; Evaluation and frame display commands

(define (enter-read-eval-print-loop)
  (with-rep-alternative
   current-environment
   (lambda (env)
     (read-eval-print env
		      "You are now in the desired environment"
		      "Eval-in-env-->"))))

(define-debug-command 'E enter-read-eval-print-loop
  "Enter a read-eval-print loop in the current environment")

(define (eval-in-current-environment)
  (with-rep-alternative current-environment
			(lambda (env)
			  (environment-warning-hook env)
			  (format "~%Eval--> ")
			  (eval (read) env))))

(define-debug-command 'V eval-in-current-environment
  "Evaluate expression in current environment")

(define show-current-frame
  (let ((show-frame (access show-frame env-package)))
    (named-lambda (show-current-frame)
      (if-valid-environment current-environment
			    (lambda (env) (show-frame env -1))))))

(define-debug-command 'C show-current-frame
  "Show Bindings of identifiers in the current environment")

(define (enter-where-command)
  (with-rep-alternative current-environment where))

(define-debug-command 'W enter-where-command
  "Enter WHERE on the current environment")

(define (error-info-command)
  (format "~% Message: ~s~%Irritant: ~o" (error-message) (error-irritant)))

(define-debug-command 'I error-info-command "Redisplay the error message")
\f


;;;; Advanced hacking commands

(define (return-command)		;command Z
  (define (confirm)
    (format "~%Confirm: [Y or N] ")
    (let ((ans (read)))
      (cond ((eq? ans 'Y) #!TRUE)
	    ((eq? ans 'N) #!FALSE)
	    (else (confirm)))))

  (define (return-read)
    (let ((exp (read)))
      (if (eq? exp '$) (unsyntax (current-expression)) exp)))

  (define (do-it environment next)
    (environment-warning-hook environment)
    (format "~%Enter an expression to EVALUATE and CONTINUE with: ")
    (if print-return-values?
	(let ((eval-exp (eval (return-read) environment)))
	  (format "~%That evaluates to:~%~o" eval-exp)
	  (if (confirm) (next eval-exp)))
	(next (eval (return-read) environment))))

  (let ((next (continuation-next-continuation current-continuation)))
    (if (null-continuation? next)
	(sequence (tyo #\BELL) (format "~%Can't continue!!!"))
	(with-rep-alternative current-environment
			      (lambda (env) (do-it env next))))))

(define-debug-command 'Z return-command
  "Return (continue with) an expression after evaluating it")

(define user-debug-environment (make-environment))

(define (internal-command)
  (read-eval-print user-debug-environment
		   "You are now in the debugger environment"
		   "Debugger-->"))

(define-debug-command 'X internal-command
  "Create a read eval print loop in the debugger environment")
\f


;;;; Reduction and continuation motion low-level

(define reduction-expression car)
(define reduction-environment cadr)

(define (last-reduction-number)
  (-1+ current-number-of-reductions))

(define (normal-reduction-number)
  (min (-1+ current-number-of-reductions) 0))

(define (initial-reduction-number)
   (let ((environment (continuation-environment current-continuation)))
     (if (conjunction (environment? environment)
		      (let ((procedure (environment-procedure environment)))
			(disjunction (eq? procedure error-procedure)
				     (eq? procedure breakpoint-procedure))))
	 1
	 0)))

(define (set-current-continuation! continuation hook)
  (set! current-continuation continuation)
  (set! current-number-of-reductions
	(if (null-continuation? continuation)
	    0
	    (dotted-list-length
	     (continuation-reductions current-continuation))))
  (set-current-reduction! (hook)))

(define (set-current-reduction! number)
  (set! current-reduction-number number)
  (if (>= number 0)
      (set! current-reduction 
       (list-ref (continuation-reductions current-continuation) number))
      (set! current-reduction #!FALSE))
  (set! current-environment 
   (if current-reduction
       (reduction-environment current-reduction)
       (continuation-environment current-continuation))))

(define (repeat f n)
  (if (> n 0)
      (sequence
       (f)
       (repeat f (-1+ n)))))

(define (dotted-list-length l)
  (let count ((n 0) (L L))
    (if (pair? l)
	(count (1+ n) (CDR L))
	n)))

(define (wrap-around-in-reductions? reductions)
  (eq? (list-tail reductions (dotted-list-length reductions))
       reduction-wrap-around-tag))
\f


;;; end DEBUG-PACKAGE.
))
;;; end IN-PACKAGE DEBUGGER-PACKAGE.
)

(define debug
  (access debug debug-package debugger-package))

(define (special-name? symbol)
  (disjunction (eq? symbol lambda-tag:unnamed)
	       (eq? symbol (access internal-lambda-tag lambda-package))
	       (eq? symbol (access internal-lexpr-tag lambda-package))
	       (eq? symbol lambda-tag:let)
	       (eq? symbol lambda-tag:fluid-let)
	       (eq? symbol lambda-tag:make-environment)
	       (eq? symbol lambda-tag:make-package)))