diff --git a/code/debug.lisp b/code/debug.lisp
index 1026f15720e4b97157b2ef1efc1347739400ff3a..7e4f265909477883a36cd113932de96a2f08f376 100644
--- a/code/debug.lisp
+++ b/code/debug.lisp
@@ -7,14 +7,13 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.16 1991/03/07 17:48:06 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.17 1991/05/27 11:45:45 chiles Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.16 1991/03/07 17:48:06 wlott Exp $
-;;;
-;;; CMU Common Lisp Debugger.  This is a very basic command-line oriented
-;;; debugger.
+;;; CMU Common Lisp Debugger.  This includes a basic command-line oriented
+;;; debugger interface as well as support for Hemlock to deliver debugger
+;;; commands to a slave Lisp.
 ;;;
 ;;; Written by Bill Chiles.
 ;;;
@@ -23,9 +22,12 @@
 
 (export '(internal-debug *in-the-debugger* backtrace *flush-debug-errors*
 	  *debug-print-level* *debug-print-length* *debug-prompt*
-	  
-	  *auto-eval-in-frame* var arg))
+	  *help-line-scroll-count*
+
+	  *auto-eval-in-frame* var arg
+	  *only-block-start-locations* *print-location-kind*
 
+	  do-debug-command))
 
 (in-package "LISP")
 (export '(invoke-debugger *debugger-hook*))
@@ -316,11 +318,29 @@
 	    (let ((level *debug-command-level*))
       (clear-input *debug-io*)
       (format *debug-io* "~2&Debug  (type H for help)~2%"))
-		(let* ((exp (read))
-		       (cmd-fun (debug-command-p exp)))
-		  (if cmd-fun
-		      (funcall cmd-fun)
-		      (debug-eval-print exp)))))))))))
+    (debug-loop)))
+
+
+					 (stream-command-name input))))
+			   (cond ((not cmd-fun)
+				  (error "Unknown stream-command -- ~S." input))
+				 ((consp cmd-fun)
+				  (error "Ambiguous debugger command: ~S."
+					 cmd-fun))
+				 (t
+				  (apply cmd-fun (stream-command-args input))))))
+	 (*real-stack-top* (di:top-frame))
+	 (*stack-top* (or *stack-top-hint* *real-stack-top*))
+				(cmd-fun (debug-command-p exp)))
+	 (*current-frame* *stack-top*))
+    (handler-bind ((di:debug-condition #'(lambda (condition)
+					   (princ condition *debug-io*)
+					   (throw 'debug-loop-catcher nil))))
+      (fresh-line)
+      (print-frame-call *current-frame* :verbosity 2)
+      (loop
+	(catch 'debug-loop-catcher
+	  (handler-bind ((error #'(lambda (condition)
 				    (when *flush-debug-errors*
 				      (clear-input *debug-io*)
 				      (princ condition)
@@ -355,7 +375,85 @@
 				  (dolist (ele cmd-fun)
 				    (format t "   ~A~%" ele)))
 				 (t
+				  (funcall cmd-fun)))))))))))))))
+
+(defvar *auto-eval-in-frame* t
+  "When set (the default), evaluations in the debugger's command loop occur
+   relative to the current frame's environment without the need of debugger
+   forms that explicitly control this kind of evaluation.")
+
+(defun debug-eval-print (exp)
+  (setq +++ ++ ++ + + - - exp)
+  (let* ((values (multiple-value-list
+		  (if (and (fboundp 'eval:internal-eval) *auto-eval-in-frame*)
+		      (di:eval-in-frame *current-frame* -)
+		      (eval -))))
+	 (*standard-output* *debug-io*))
+    (fresh-line)
+    (if values (prin1 (car values)))
+    (dolist (x (cdr values))
+      (fresh-line)
+      (prin1 x))
+    (setq /// // // / / values)
+    (setq *** ** ** * * (car values))
+    ;; Make sure nobody passes back an unbound marker.
+    (unless (boundp '*)
+      (setq * nil)
+      (fresh-line)
+      (princ "Setting * to NIL -- was unbound marker."))))
+
 
+
+;;;; Debug loop functions.
+
+;;; These commands are function, not really commands, so users can get their
+;;; hands on the values returned.
+;;;
+
+(eval-when (eval compile)
+
+(defmacro define-var-operation (ref-or-set &optional value-var)
+  `(let* ((temp (etypecase name
+		  (symbol (di:debug-function-symbol-variables
+			   (di:frame-debug-function *current-frame*)
+			   name))
+		  (simple-string (di:ambiguous-debug-variables
+				  (di:frame-debug-function *current-frame*)
+				  name))))
+	  (location (di:frame-code-location *current-frame*))
+	  ;; Let's only deal with valid variables.
+	  (vars (remove-if-not #'(lambda (v)
+				   (eq (di:debug-variable-validity v location)
+				       :valid))
+			       temp)))
+     (declare (list vars))
+     (cond ((null vars)
+	    (error "No known valid variables match ~S." name))
+	   ((= (length vars) 1)
+	    ,(ecase ref-or-set
+	       (:ref
+		'(di:debug-variable-value (car vars) *current-frame*))
+	       (:set
+		`(setf (di:debug-variable-value (car vars) *current-frame*)
+		       ,value-var))))
+	   (t
+	    ;; Since we have more than one, first see if we have any
+	    ;; variables that exactly match the specification.
+	    (let* ((name (etypecase name
+			   (symbol (symbol-name name))
+			   (simple-string name)))
+		   (exact (remove-if-not #'(lambda (v)
+					     (string= (di:debug-variable-name v)
+						      name))
+					 vars))
+		   (vars (or exact vars)))
+	      (declare (simple-string name)
+		       (list exact vars))
+	      (cond
+	       ;; Check now for only having one variable.
+	       ((= (length vars) 1)
+		,(ecase ref-or-set
+		   (:ref
 		    '(di:debug-variable-value (car vars) *current-frame*))
 		   (:set
 		    `(setf (di:debug-variable-value (car vars) *current-frame*)
@@ -373,66 +471,14 @@
 			       (delete-duplicates
 				vars :test #'string=
 				:key #'di:debug-variable-name))))
-   information."
-  (let* ((temp (etypecase name
-		 (symbol (di:debug-function-symbol-variables
-			  (di:frame-debug-function *current-frame*)
-			  name))
-		 (simple-string (di:ambiguous-debug-variables
-				 (di:frame-debug-function *current-frame*)
-				 name))))
-	 (location (di:frame-code-location *current-frame*))
-	 ;; Let's only deal with valid variables.
-	 (vars (remove-if-not #'(lambda (v)
-				  (eq (di:debug-variable-validity v location)
-				      :valid))
-			      temp)))
-    (declare (list vars))
-    (cond ((null vars)
-	   (error "No known valid variables match ~S." name))
-	  ((= (length vars) 1)
-	   (di:debug-variable-value (car vars) *current-frame*))
-	  (t
-	   ;; Since we have more than one, first see if we have any variables
-	   ;; that exactly match the specification.
-	   (let* ((name (etypecase name
-			  (symbol (symbol-name name))
-			  (simple-string name)))
-		  (exact (remove-if-not #'(lambda (v)
-					    (string= (di:debug-variable-name v)
-						     name))
-					vars))
-		  (vars (or exact vars)))
-	     (declare (simple-string name)
-		      (list exact vars))
-	     (cond
-	      ;; Check now for only having one variable.
-	      ((= (length vars) 1)
-	       (di:debug-variable-value (car vars) *current-frame*))
-	      ;; If there weren't any exact matches, flame about ambiguity
-	      ;; unless all the variables have the same name.
-	      ((and (not exact)
-		    (find-if-not
-		     #'(lambda (v)
-			 (string= (di:debug-variable-name v)
-				  (di:debug-variable-name (car vars))))
-		     (cdr vars)))
-	       (error "Specification ambiguous:~%~{   ~A~%~}"
-		      (mapcar #'di:debug-variable-name
-			      (delete-duplicates
-			       vars :test #'string=
-			       :key #'di:debug-variable-name))))
-	      ;; All names are the same, so see if the user ID'ed one of them.
-	      (id-supplied
-	       (let ((v (find id vars :key #'di:debug-variable-id)))
-		 (unless v
-		   (error "Invalid variable ID, ~D, should have been one of ~S."
-			  id (mapcar #'di:debug-variable-id vars)))
-		 (di:debug-variable-value v *current-frame*)))
-	      (t
-	       (error "Specify variable ID to disambiguate ~S.  Use one of ~S."
-		      name (mapcar #'di:debug-variable-id vars)))))))))
+	       ;; All names are the same, so see if the user ID'ed one of them.
+	       (id-supplied
+		(let ((v (find id vars :key #'di:debug-variable-id)))
+		  (unless v
+		    (error "Invalid variable ID, ~D, should have been one of ~S."
 			   id (mapcar #'di:debug-variable-id vars)))
+		  ,(ecase ref-or-set
+		     (:ref
 		      '(di:debug-variable-value v *current-frame*))
 		     (:set
 		      `(setf (di:debug-variable-value v *current-frame*)
@@ -490,52 +536,106 @@
 ;;; NTH-ARG -- Internal.
 ;;;
 ;;; This returns the n'th arg as the user sees it from args, the result of
-;;; Interface to *debug-commands*.
-;;; 
-(defmacro def-debug-command (name &rest body)
+;;; DI:DEBUG-FUNCTION-LAMBDA-LIST.  If this returns a potential debug-variable
+;;; from the lambda-list, then the second value is t.  If this returns a
+;;; keyword symbol or a value from a rest arg, then the second value is nil.
+;;;
+(defun nth-arg (count args)
+  (let ((n count))
     (dolist (ele args (error "Argument specification out of range -- ~S." n))
       (lambda-list-element-dispatch ele
-      (defun ,fun-name () ,@body)
-      (push (cons ,name #',fun-name) *debug-commands*)
+	:required ((if (zerop n) (return (values ele t))))
+	 (warn "Redefining ~S debugger command." ,name))
+			((zerop (decf n))
+			 (return (values (third ele) t)))))
+	:deleted ((if (zerop n) (return (values ele t))))
+	:rest ((let ((var (second ele)))
+		 (lambda-var-dispatch var
 				      (di:frame-code-location *current-frame*)
 		   (error "Unused rest-arg before n'th argument.")
+		   (dolist (value
+			    (di:debug-variable-value var *current-frame*)
+			    (error "Argument specification out of range -- ~S."
+				   n))
+		     (if (zerop n)
+			 (return-from nth-arg (values value nil))
+			 (decf n)))
+		   (error "Invalid rest-arg before n'th argument.")))))
+      (decf n))))
+
+
+
+;;;; Debug loop command definition:
+
+(defvar *debug-commands* nil)
+
+;;; DEF-DEBUG-COMMAND -- Internal.
 (defun debug-command-p (form)
-  (and (symbolp form)
-       (cdr (assoc (symbol-name form) *debug-commands* :test #'string=))))
+  (if (symbolp form)
+      (let* ((name (symbol-name form))
+    `(progn
+       (when (assoc ,name *debug-commands* :test #'string=)
+	 (warn "Redefining ~S debugger command." ,name)
+	 (setf *debug-commands*
+	       (remove ,name *debug-commands* :key #'car :test #'string=)))
+       (defun ,fun-name ,args
+	 (unless *in-the-debugger*
+	(dolist (ele *debug-commands*)
+	  (let* ((str (car ele))
+		 (str-len (length str)))
+	    (declare (simple-string str)
+		     (fixnum str-len))
+	    (cond ((< str-len len))
+		  ((= str-len len)
+		   (when (string= name str :end1 len :end2 len)
+		     (return-from debug-command-p (cdr ele))))
+		  ((string= name str :end1 len :end2 len)
+		   (push ele res)))))
+;;; DEBUG-COMMAND-P -- Internal.
+;;;
+;;; This takes a symbol and uses its name to find a debugger command, using
+;;; initial substring matching.  It returns the command function if form
+;;; identifies only one command, but if form is ambiguous, this returns a list
+;;; of the command names.  If there are no matches, this returns nil.  Whenever
+;;; the loop that looks for a set of possibilities encounters an exact name
+;;; match, we return that command function immediately.
+;;;
 (defun debug-command-p (form &optional other-commands)
       (let* ((name
 	  (mapc #'match-command other-commands))
 	;;
 	;; Return the right value.
-(def-debug-command "U"
+	(cond ((not res) nil)
 	      ((= (length res) 1)
     (if next
 	(print-frame-call (setf *current-frame* next))
-	(princ "Top of stack."))))
+	(format t "~&Top of stack."))))
 
-(def-debug-command "D"
+;;;
 ;;; Returns a list of debug commands (in the same format as *debug-commands*)
     (if next
 	(print-frame-call (setf *current-frame* next))
-	(princ "Bottom of stack."))))
+	(format t "~&Bottom of stack."))))
 (defun make-restart-commands (&optional (restarts *debug-restarts*))
-(def-debug-command "T"
+    (dolist (restart restarts)
   (print-frame-call
    (setf *current-frame*
 	 (do ((prev *current-frame* lead)
 	      (lead (di:frame-up *current-frame*) (di:frame-up lead)))
 	     ((null lead) prev)))))
 	    (push (cons (format nil "~d" num) restart-fun) commands))))
-(def-debug-command "B"
+      (incf num))
   (print-frame-call
    (setf *current-frame*
 	 (do ((prev *current-frame* lead)
 	      (lead (di:frame-down *current-frame*) (di:frame-down lead)))
 	     ((null lead) prev)))))
 
-(def-debug-command "F"
-  (let ((n (read-prompting-maybe "Frame number: "))
-	(current (di:frame-number *current-frame*)))
+  (let ((next (di:frame-up *current-frame*)))
+    (cond (next
+	   (setf *current-frame* next)
+	   (print-frame-call next))
+	  (t
   
 (def-debug-command "DOWN" ()
   (let ((next (di:frame-down *current-frame*)))
@@ -562,21 +662,23 @@
        (print-frame-call prev))))
 
 
+(def-debug-command-alias "B" "BOTTOM")
+
 (def-debug-command "FRAME" (&optional
 			    (n (read-prompting-maybe "Frame number: ")))
   (let ((current (di:frame-number *current-frame*)))
-(def-debug-command "Q"
+    (cond ((= n current)
 	   (princ "You are here."))
 	  ((> n current)
-(def-debug-command "GO"
+	   (print-frame-call
 	    (setf *current-frame*
 		  (do ((prev *current-frame* lead)
 
-(def-debug-command "ABORT"
+(def-debug-command "ABORT" ()
   ;; There's always at least one abort restart due to the top-level one.
   (invoke-restart *debug-abort*))
 		       (lead (di:frame-down *current-frame*)
-(def-debug-command "RESTART"
+			     (di:frame-down lead)))
 		      ((null lead)
 		       (princ "Bottom of stack encountered.")
 		       prev)
@@ -589,9 +691,11 @@
 ;;;
 
 (def-debug-command "QUIT" ()
-(defvar *help-line-scroll-count* 20)
+  (throw 'lisp::top-level-catcher nil))
+
+(def-debug-command "GO" ()
   (continue)
-(def-debug-command "H"
+  (error "No restart named continue."))
 
 (def-debug-command "RESTART" ()
   (let ((num (read-if-available :prompt)))
@@ -608,26 +712,32 @@
 			    :test #'(lambda (sym1 sym2)
 				      (string= (symbol-name sym1)
 					       (symbol-name sym2)))))
-      (format t "~%Q for quit: ")
+		     (t
 		      (format t "~S is invalid as a restart name.~%" num)
 		      (return-from restart-debug-command nil)))))
       (if restart
 	  (invoke-restart-interactively restart)
 	  (princ "No such restart.")))))
-(def-debug-command "ERROR"
+
+
+;;;
 ;;; Information commands.
 ;;;
  
-(def-debug-command "BACKTRACE"
+(defvar *help-line-scroll-count* 20
   "This controls how many lines the debugger's help command prints before
    printing a prompting line to continue with output.")
-(def-debug-command "P"
+
 (def-debug-command "HELP" ()
   (let* ((end -1)
-(def-debug-command "PP"
+	 (len (length debug-help-string))
+	 (len-1 (1- len)))
+    (loop
   (print-frame-call *current-frame* nil nil))
 	    (count *help-line-scroll-count*))
-(def-debug-command "L"
+	(loop
+	  (setf end (position #\newline debug-help-string :start (1+ end)))
+	  (cond ((or (not end) (= end len-1))
 		 (setf end len)
 		 (return))
 		((or (zerop (decf count)) (= end len))
@@ -655,15 +765,15 @@
 
 (def-debug-command-alias "P" "PRINT")
 
-	    (format t "All variables ~@[starting with ~A~ ]currently ~
+(def-debug-command "VPRINT" ()
   (print-frame-call *current-frame* :print-level nil :print-length nil
 		    :verbosity (read-if-available 2)))
 
 (def-debug-command-alias "PP" "VPRINT")
-(def-debug-command "SOURCE"
+
   (print-frame-source-form *current-frame* (read-if-available 0)))
 	      (*print-length* (or *debug-print-length* *print-level*))
-(def-debug-command "VSOURCE"
+	      (*standard-output* *debug-io*)
   (print-frame-source-form *current-frame* (read-if-available 0) t))
 			d-fun
 
@@ -716,10 +826,12 @@
 (pushnew #'(lambda ()
 	 (let* ((tlf-offset (di:code-location-top-level-form-offset
 			     location))
+	 ext:*before-save-initializations*)
+
 		(char-offset (aref (or (di:debug-source-start-positions
 					d-source)
 ;;; We also cache the last top-level form that we printed a source for so that
-				   tlf-offset)))
+;;; we don't have to do repeated reads and calls to FORM-NUMBER-TRANSLATIONS.
 ;;;
 (defvar *cached-top-level-form-offset* nil)
 (declaim (type (or kernel:index null) *cached-top-level-form-offset*))
@@ -729,7 +841,7 @@
 
 ;;; GET-TOP-LEVEL-FORM  --  Internal
 ;;;
-	       (dotimes (i tlf-offset)
+	       (dotimes (i local-tlf-offset)
 		 (read f))))
 ;;;
 (defun get-top-level-form (location)
@@ -738,8 +850,7 @@
 	     (eql (di:code-location-top-level-form-offset location)
 		  *cached-top-level-form-offset*))
 	(values *cached-form-number-translations* *cached-top-level-form*)
-  (let ((translations (di:form-number-translations
-		       tlf tlf-offset))
+  (let ((translations (di:form-number-translations tlf tlf-offset))
 	(*print-level* (if verbose
 	       (res
 		(ecase (di:debug-source-from d-source)
@@ -756,10 +867,11 @@
 			 *default-breakpoint-debug-function*))))))
 	   (setup-function-start ()
 	     (let ((code-loc (di:debug-function-start-location place)))
-(def-debug-command "FLUSH"
+	       (setf bp (di:make-breakpoint #'main-hook-function place
 					    :kind :function-start))
 	       (setf break (di:preprocess-for-eval break code-loc))
-      (write-line "Errors now not flushed.")))
+	       (setf condition (di:preprocess-for-eval condition code-loc))
+	     (old-bp-info (location-in-list new-bp-info *breakpoints*)))
 	(when old-bp-info
 	  (di:deactivate-breakpoint (breakpoint-info-breakpoint old-bp-info))
 	  (setf *breakpoints* (remove old-bp-info *breakpoints*))