diff --git a/src/CHANGELOG b/src/CHANGELOG
index 5ffab6bda..17ab174ea 100644
--- a/src/CHANGELOG
+++ b/src/CHANGELOG
@@ -72,10 +72,12 @@ ECL 9.5:
    ecl_make_cclosure_va, ecl_def_c_function, ecl_def_c_function_va.
 
  - Compiled functions now carry information about their source file
-   (based on patches by JC Beaudoin)
+   (based on patches by Jean-Claude Beaudoin)
 
  - The compiler can now generate some Lisp constants as static C expressions
-   (based on patches by JC Beaudoin)
+   (based on patches by JCB)
+
+ - The debugger is now fit for multithreaded environments (JCB)
 
 * Bugs fixed:
 
diff --git a/src/lsp/describe.lsp b/src/lsp/describe.lsp
index a91aa2597..0116c7e3a 100644
--- a/src/lsp/describe.lsp
+++ b/src/lsp/describe.lsp
@@ -21,6 +21,10 @@
 (defvar *old-print-length* nil)
 
 
+;; Either the inspector reads and writes everything on *standard-output*,
+;; or reads and writes everything on *query-io* but not a mix of each!
+;; If this rule is not followed only severe confusion can result. JCB
+
 (defun inspect-read-line ()
   (declare (si::c-local))
   (do ((char (read-char *query-io*) (read-char *query-io*)))
@@ -67,51 +71,75 @@
 
 (defun read-inspect-command (label object allow-recursive)
   (unless *inspect-mode*
+    ;; This is "describe" mode. So we stay non-interactive.
     (inspect-indent-1)
     (if allow-recursive
         (progn (princ label) (inspect-object object))
         (format t label object))
     (return-from read-inspect-command nil))
-  (loop
-    (inspect-indent-1)
-    (if allow-recursive
-        (progn (princ label)
-               (inspect-indent)
-               (prin1 object))
-        (format t label object))
-    (write-char #\Space)
-    (force-output)
-    (case (do ((char (read-char *query-io*) (read-char *query-io*)))
-              ((and (char/= char #\Space) (char/= #\Tab)) char))
-      ((#\Newline #\Return)
-       (when allow-recursive (inspect-object object))
-       (return nil))
-      ((#\n #\N)
-       (inspect-read-line)
-       (when allow-recursive (inspect-object object))
-       (return nil))
-      ((#\s #\S)
-       (inspect-read-line)
-       (return nil))
-      ((#\p #\P)
-       (inspect-read-line)
-       (select-P object))
-      ((#\a #\A)
-       (inspect-read-line)
-       (throw 'ABORT-INSPECT nil))
-      ((#\u #\U)
-       (return (values t (select-U))))
-      ((#\e #\E)
-       (select-E))
-      ((#\q #\Q)
-       (inspect-read-line)
-       (throw 'QUIT-INSPECT nil))
-      ((#\?)
-	(inspect-read-line)
-	(select-?))
-      (t
-        (inspect-read-line))
-      )))
+  (let* ((*quit-tags* (cons *quit-tag* *quit-tag*)) ;; as seen in top.lsp
+	 (*quit-tag* *quit-tags*))
+    (declare (special *quit-tags* *quit-tags*))
+    (loop
+       (when
+	   (catch *quit-tag* ;; as seen in top.lsp
+	     (with-simple-restart (inspect "Go back to inspector.")
+	       (inspect-indent-1)
+	       (if allow-recursive
+		   (progn (princ label)
+			  (inspect-indent)
+			  (prin1 object))
+		   (format t label object))
+	       (write-char #\Space) ;; Inspector prompt!?
+	       (princ " >> ")	    ;; This one is more suggestive.
+	       ;;(force-output) ;; not quite enough.
+	       (finish-output) ;; this one is stronger.
+	       (case (do ((char (read-char *query-io*) (read-char *query-io*)))
+			 ((and (char/= char #\Space) (char/= char #\Tab)) 
+			  (cond
+			    ((char= char #\Newline) char)
+			    ((char= char #\Return) char)
+			    ((alphanumericp (peek-char)) #\!) ;; Invalid command on purpose.
+			    (t char))
+			  ))
+		 ((#\Newline #\Return)
+		  (when allow-recursive (inspect-object object))
+		  (return nil))
+		 ((#\n #\N)
+		  (inspect-read-line)
+		  (when allow-recursive (inspect-object object))
+		  (return nil))
+		 ((#\s #\S)
+		  (inspect-read-line)
+		  (return nil))
+		 ((#\p #\P)
+		  (inspect-read-line)
+		  (select-P object))
+		 ((#\a #\A)
+		  (inspect-read-line)
+		  (throw 'ABORT-INSPECT nil))
+		 ((#\u #\U)
+		  (return (values t (select-U))))
+		 ((#\e #\E)
+		  (select-E))
+		 ((#\q #\Q)
+		  (inspect-read-line)
+		  (throw 'QUIT-INSPECT nil))
+		 ((#\?)
+		  (inspect-read-line)
+		  (select-?))
+		 (t
+		  (inspect-read-line)
+		  (inspect-indent)
+		  (format t "Unknown inspector command. ~
+                       Type ? followed by #\\Newline for help."))
+		 )
+	       )
+	     nil
+	     )
+	 (format t "~&Back to Inspection mode: ~
+                      Type ? followed by #\\Newline for help.~%")
+	 ))))
 
 #+ecl-min
 (defmacro inspect-recursively (label object &optional place)
@@ -162,14 +190,19 @@
                      (eq f :external))
                    (package-name p)))))
 
-  (when (boundp symbol)
+  (when (print-doc symbol t)
+        (format t "~&-----------------------------------------------------------------------------~%~%"))
+  
+  (if (or (eq t symbol) (eq nil symbol) (keywordp symbol))
+      (progn (inspect-indent-1) (format t "value: ~S" (symbol-value symbol)))
+      (when (boundp symbol)
         (if *inspect-mode*
             (inspect-recursively "value:"
                                  (symbol-value symbol)
                                  (symbol-value symbol))
             (inspect-print "value:~%   ~S"
                            (symbol-value symbol)
-                           (symbol-value symbol))))
+                           (symbol-value symbol)))))
 
   (do ((pl (symbol-plist symbol) (cddr pl)))
       ((endp pl))
@@ -184,8 +217,6 @@
                          (cadr pl)
                          (get symbol (car pl))))))
 
-  (when (print-doc symbol t)
-        (format t "~&-----------------------------------------------------------------------------~%"))
   )
 
 (defun inspect-package (package)
@@ -237,8 +268,12 @@
         (do ((i 0 (1+ i))
              (l cons (cdr l)))
             ((atom l)
-             (inspect-recursively (format nil "nthcdr ~D:" i)
-                                  l (cdr (nthcdr (1- i) cons))))
+             (case l
+	       ((t nil) ;; no point in inspecting recursively t nor nil.
+		(inspect-print (format nil "nthcdr ~D: ~~S" i) l))
+	       (t
+		(inspect-recursively (format nil "nthcdr ~D:" i)
+				     l (cdr (nthcdr (1- i) cons))))))
           (inspect-recursively (format nil "nth ~D:" i)
                                (car l) (nth i cons)))))
 
@@ -326,7 +361,7 @@
   (terpri)
   (format t
 	  "Inspect commands for hash tables:~%~
-n (or N or Newline):  inspects the keys/values of the hashtable (recursively).~%~
+n (or N or #\\Newline):  inspects the keys/values of the hashtable (recursively).~%~
 s (or S):             skips the field.~%~
 p (or P):             pretty-prints the field.~%~
 a (or A):             aborts the inspection of the rest of the fields.~%~
@@ -334,7 +369,7 @@ e (or E) form:        evaluates and prints the form.~%~
 l (or L):             show the keys of the hash table.~%~
 j (or J) key:         inspect the value associated to the key requested.~%~
 q (or Q):             quits the inspection.~%~
-?:                    prints this.~%~%"
+?:                    prints this help message.~%~%"
 	  ))
 
 (defun inspect-hashtable (hashtable)
@@ -344,7 +379,8 @@ q (or Q):             quits the inspection.~%~
 	(decf *inspect-level*)
         (loop
           (format t "~S - hash table: " hashtable)
-	  (force-output)
+	  ;;(force-output) ;; not quite enough.
+	  (finish-output) ;; this one is stronger.
           (case (do ((char (read-char *query-io*) (read-char *query-io*)))
 	            ((and (char/= char #\Space) (char/= #\Tab)) char))
 	        ((#\Newline #\Return)
@@ -420,6 +456,25 @@ q (or Q):             quits the inspection.~%~
                (t (format t "~S - ~S" object (type-of object))))))
 
 
+(defun inspect (object &aux (*inspect-mode* t)
+                            (*inspect-level* 0)
+                            (*inspect-history* nil)
+                            (*old-print-level* *print-level*)
+                            (*old-print-length* *print-length*)
+                            (*print-level* 3)
+                            (*print-length* 3))
+  "Args: (object)
+Shows the information about OBJECT interactively.  See the ECL Report for the
+inspect commands, or type '?' to the inspector."
+  ;;(read-line)
+  (terpri)
+  (princ "Inspection mode: Type ? followed by #\\Newline for help.")
+  (terpri)
+  (terpri)
+  (catch 'QUIT-INSPECT (inspect-object object))
+  (terpri)
+  (values))
+
 (defun describe (object &optional (stream *standard-output*)
 			&aux (*inspect-mode* nil)
                              (*inspect-level* 0)
@@ -439,23 +494,6 @@ Prints information about OBJECT to STREAM."
   (terpri)
   (values))
 
-(defun inspect (object &aux (*inspect-mode* t)
-                            (*inspect-level* 0)
-                            (*inspect-history* nil)
-                            (*old-print-level* *print-level*)
-                            (*old-print-length* *print-length*)
-                            (*print-level* 3)
-                            (*print-length* 3))
-  "Args: (object)
-Shows the information about OBJECT interactively.  See the ECL Report for the
-inspect commands, or type '?' to the inspector."
-  (read-line)
-  (princ "Type ? and a newline for help.")
-  (terpri)
-  (catch 'QUIT-INSPECT (inspect-object object))
-  (terpri)
-  (values))
-
 (defun print-doc (symbol &optional (called-from-apropos-doc-p nil)
                          &aux (f nil) x)
   (flet ((doc1 (doc ind)
diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp
index fb184d9fa..6e7d88035 100644
--- a/src/lsp/top.lsp
+++ b/src/lsp/top.lsp
@@ -17,6 +17,7 @@
 ;;;;  Merged into new distribution Sept 1987, by Edward Wang.
 ;;;;  Reworked for Threads November 1988, by Giuseppe Attardi.
 ;;;;  Reworked for CLOS November 1988, by Giuseppe Attardi.
+;;;;  Updated May 2009, by Jean-Claude Beaudoin
 
 (in-package "SYSTEM")
 
@@ -174,10 +175,7 @@ rebinds this variable to NIL when control enters a break loop.")
 	in-line or explicitly hidden are not displayed.  Without an argument,~@
 	a concise backtrace is printed with the current function in upper~@
 	case.  With integer argument n, the n functions above and including~@
-	the current one are printed in a verbose format.  The current~@
-	function is indicated with a '@' at the beginning of the line.~@
-	With non-integer argument, all functions since the the previous break~@
-	level are printed verbosely.~@
+	the current one are printed in a verbose format.~@
 	~@
 	See also: :function, :previous, :next.~%")
       ((:f :function) tpl-print-current nil
@@ -200,6 +198,10 @@ rebinds this variable to NIL when control enters a break loop.")
  	It becomes the new current function.~@
 	~@
 	See also: :backtrace, :function, :go, :next.~%")
+      ((:d :down) tpl-previous nil
+       ":d(own)         Alias to :previous"
+       ""
+       )
       ((:n :next) tpl-next nil
        ":n(ext)		Go to next function"
        ":next &optional (n 1)				[Break command]~@
@@ -209,6 +211,10 @@ rebinds this variable to NIL when control enters a break loop.")
 	the new current function.~@
 	~@
 	See also: :backtrace, :function, :go, :previous.~%")
+      ((:u :up) tpl-next nil
+       ":u(p)           Alias to :next"
+       ""
+       )
       ((:g :go) tpl-go nil
        ":g(o)		Go to next function"
        ":go &optional (n 1)				[Break command]~@
@@ -234,10 +240,10 @@ rebinds this variable to NIL when control enters a break loop.")
 	The match is case insensitive.~@
 	~@
 	See also: :backtrace, :function, :previous.~%")
-      ((:d :disassemble) tpl-disassemble-command nil
-       ":d(isassemble)	Disassemble current function"
+      ((:disassemble) tpl-disassemble-command nil
+       ":disassemble	Disassemble current function"
        ":disassemble					[Break command]~@
-	:d						[Abbreviation]~@
+	:disassemble					[Abbreviation]~@
 	~@
 	Disassemble the current function. Currently, only interpreted functions~@
 	can be disassembled.~%")
@@ -328,6 +334,10 @@ rebinds this variable to NIL when control enters a break loop.")
 	Without an argument, show the entire binding stack since the previous~@
 	break level.  With a variable name, print nothing, but return the~@
 	value of the given variable on the binding stack.~%")
+      ((:frs :frame-stack) tpl-frs-command nil
+       ":frs            Show frame stack"
+       ""
+       )
       ((:m :message) tpl-print-message nil
        ":m(essage)      Show error message"
        ":message					[Break command]~@
@@ -340,6 +350,32 @@ rebinds this variable to NIL when control enters a break loop.")
 	:hs						[Abbrevation]~@
 	~@
 	Lists the functions to access the LISP system stacks.~%")
+      ((:i :inspect) tpl-inspect-command nil
+       ":i(nspect)      Inspect value of local variable"
+       ":inspect var-name                               [Break command]~@
+        :i var-name                                     [Abbreviation]~@
+        ~@
+        Inspect value of local variable named by var-name. Argument~@
+        var-name can be a string or a symbol whose name string will~@
+        then be used regardless of of the symbol's package.~@
+        ~@
+        See also: :variables.~%")
+      #+threads
+      ((:s :switch) tpl-switch-command nil
+       ":s(witch)       Switch to next process to debug"
+       ":switch debuggee                                [Break command]~@
+        :s debuggee                                     [Abbreviation]~@
+        ~@
+        Switch to next process in need to debugger attention. Argument~@
+        debuggee, when provided, must be an integer indicating the rank~@
+        of the process in the debugger waiting list.~%")
+      #+threads
+      ((:w :waiting) tpl-waiting-command nil
+       ":w(aiting)      Display debugger's waiting list"
+       ":waiting                                        [Break command]~@
+        :w                                              [Abbreviation]~@
+        ~@
+        Display debugger's waiting list.~%")
       )
   )
 
@@ -372,6 +408,9 @@ under certain conditions; see file 'Copyright' for details.")
 	    (*tpl-level* -1))
 	(tpl)))))
 
+(defvar *allow-recursive-debug* nil)
+(defvar *debug-status* nil)
+
 (defun terminal-interrupt (correctablep)
   (let ((*break-enable* t))
     (if correctablep
@@ -390,23 +429,61 @@ under certain conditions; see file 'Copyright' for details.")
 	 (*quit-tags* (cons *quit-tag* *quit-tags*))
 	 (*quit-tag* *quit-tags*)	; any unique new value
 	 (*tpl-level* (1+ *tpl-level*))
+	 (break-level *break-level*)
 	 values)
     (set-break-env)
     (set-current-ihs)
     (unless quiet
       (break-where))
-    (loop
-     (setq +++ ++ ++ + + -)
-     (when (catch *quit-tag*
-	     (tpl-prompt)
-	     (setq - (locally (declare (notinline tpl-read)) (tpl-read)))
-	     (setq values
-		   (multiple-value-list
-		    (eval-with-env - *break-env*)))
-	     (setq /// // // / / values *** ** ** * * (car /))
-	     (tpl-print values)
-	     nil)
-	   (break-where)))))
+    (flet ((rep ()
+		(handler-bind 
+		 ((condition
+		   (lambda (condition)
+		     (cond ((subtypep (type-of condition) 'warning)
+			    ;; We let warnings pass by this way "warn" does the work.
+			    )
+			   ((< break-level 1)
+			    ;; Toplevel should enter the debugger on any condition.
+			    )
+			   (*allow-recursive-debug*
+			    ;; We are told to let the debugger handle this.
+			    )
+			   (t
+			    (format t "~&Debugger received error: ~A~%~
+                                         Error flushed.~%" condition)
+			    (clear-input)
+			    (return-from rep t) ;; go back into the debugger loop.
+			    )
+			   )
+		     )))
+
+		 (tpl-prompt)
+		 (setq - (locally (declare (notinline tpl-read)) (tpl-read)))
+		 (setq values
+		       (multiple-value-list
+			(eval-with-env - *break-env*)))
+		 (setq /// // // / / values *** ** ** * * (car /))
+		 (tpl-print values)
+		 )
+		)
+	   )
+	  (loop
+	   (setq +++ ++ ++ + + -)
+	   (when
+	       (catch *quit-tag*
+		 (if (zerop break-level)
+		     (with-simple-restart 
+		      (restart-toplevel "Go back to Top-Level REPL.")
+		      (rep)
+		      )
+		   (with-simple-restart
+		    (restart-debugger "Go back to debugger level ~D." break-level)
+		    (rep)
+		    )
+		   )
+		 nil
+		 )
+	     (break-where))))))
 
 (defun tpl-prompt ()
   (typecase *tpl-prompt-hook*
@@ -454,6 +531,25 @@ under certain conditions; see file 'Copyright' for details.")
       (t
        (return (read))))))
 
+(defvar *debug-tpl-commands* nil)
+
+(defun harden-command (cmd-form)
+  `(block 
+    tpl-command
+    (handler-bind 
+     ((error (lambda (condition)
+	       (unless *debug-tpl-commands*
+		 (format t "~&Command aborted.~%Received condition: ~A" condition)
+		 (clear-input)
+		 (return-from tpl-command nil)
+		 )
+	       )
+	     ))
+     ,cmd-form
+     )
+    )
+  )
+
 (defun tpl-make-command (name line &aux (c nil))
   (dolist (commands *tpl-commands*)
     (when (setq c (assoc name (cdr commands) :test #'member))
@@ -463,15 +559,17 @@ under certain conditions; see file 'Copyright' for details.")
 	     nil
 	     `(tpl-unknown-command ',name)))
 	((eq (third c) :restart)
-	 `(invoke-restart-interactively ,(second c))) 
+	 `(progn
+	    ;;(format t "~&About to invoke restart: ~A.~%" ,(second c))
+	    (invoke-restart-interactively ,(second c))))
 	((eq (third c) :eval)
 	 `(,(second c) . ,(tpl-parse-forms line)))
 	((eq (third c) :string)
-	 `(,(second c) . ,(tpl-parse-strings line)))
+	 (harden-command `(,(second c) . ,(tpl-parse-strings line))))
 	((eq (third c) :constant)
-	 (second c))
+	 (harden-command (second c)))
 	(t
-	 `(,(second c) . ,(tpl-parse-forms line t)))))
+	 (harden-command `(,(second c) . ,(tpl-parse-forms line t))))))
 
 (defun tpl-parse-forms (line &optional quote)
   (with-input-from-string (stream line)
@@ -562,10 +660,10 @@ under certain conditions; see file 'Copyright' for details.")
     (values)))
 
 (defun tpl-lambda-expression-command (&optional no-values)
-  (let*((*print-level* 2)
-	(*print-length* 4)
-	(*print-pretty* t)
-	(*print-readably* nil)
+  (let*(;;(*print-level* 2)
+	;;(*print-length* 4)
+	;;(*print-pretty* t)
+	;;(*print-readably* nil)
 	(function (ihs-fun *ihs-current*))
 	(le (function-lambda-expression function)))
     (if le
@@ -642,7 +740,9 @@ under certain conditions; see file 'Copyright' for details.")
 	     (push (compiled-function-name record) functions))
 	    ((progn
 	       (setf record0 (car record) record1 (cdr record))
-	       (symbolp record0))
+	       (or (symbolp record0) (stringp record0)))
+	     (cond ((locativep record1) (setq record1 (deref record1)))
+		   ((unbound-value-p record1) (setq record1 "<unbound value>")))
 	     (setq variables (list* record0 record1 variables)))
 	    ((symbolp record1)
 	     (push record1 blocks))
@@ -650,11 +750,47 @@ under certain conditions; see file 'Copyright' for details.")
 	     )))
     (format t "~:[~;Local functions: ~:*~{~s~^, ~}.~%~]" functions)
     (format t "~:[~;Block names: ~:*~{~s~^, ~}.~%~]" blocks)
-    (format t "Local variables: ~:[~:[none~;~:*~{~s~1*~:@{, ~s~1*~}~}~]~;~
-				   ~:[none~;~:*~{~%  ~s: ~s~}~]~]~%"
-	    (not no-values) variables)
+
+    ;; This format is the what was in the orignal code.
+    ;; It simply does not work when no-values is t.
+    ;; If you care to debug this kind of conundrum then have fun!
+    ;;(format t "Local variables: ~:[~:[none~;~:*~{~a~1*~:@{, ~a~1*~}~}~]~;~
+    ;;                            ~:[none~;~:*~{~%  ~a: ~s~}~]~]~%"
+    ;;          (not no-values) variables)
+    (format t "Local variables: ")
+    (if variables
+	(if no-values
+	    (do ((vals variables (cddr vals)))
+		((endp vals))
+		(format t "~%  ~A" (car vals))
+		)
+	  (do ((vals variables (cddr vals)))
+	      ((endp vals))
+	      (format t "~%  ~A: ~S" (car vals) (cadr vals))
+	   )
+	  )
+      (format t "none")
+      )
+    (terpri)
     (values)))
 
+(defun tpl-inspect-command (var-name)
+  (when (symbolp var-name)
+    (setq var-name (symbol-name var-name)))
+  (let ((val-pair (assoc var-name *break-env* 
+			 :test #'(lambda (s1 s2)
+				   (when (symbolp s2) (setq s2 (symbol-name s2)))
+				   (if (stringp s2)
+				       (string-equal s1 s2)
+				     nil)))))
+    (when val-pair
+      (format t "~&In tpl-inspect-command: val-pair = ~S~%" val-pair)
+      (let ((val (cdr val-pair)))
+	(when (locativep val)
+	  (format 5 "In tpl-inspect-command: val is a locative!~%")
+	  (setq val (deref val)))
+	(inspect val)))))
+
 (defun tpl-bds-command (&optional var)
   (if var
     (do ((bi (1+ (frs-bds (max 0 (1- *frs-base*)))) (1+ bi))
@@ -663,7 +799,8 @@ under certain conditions; see file 'Copyright' for details.")
 	 (format t "Variable not found.~%")
 	 (values))
       (when (eq (bds-var bi) var)
-	(return (bds-val bi))))
+	(return (let ((val (bds-val bi)))
+		  (if (unbound-value-p val) "<unbound value>" val)))))
     (do ((bi (1+ (frs-bds (max 0 (1- *frs-base*)))) (1+ bi))
 	 (last (frs-bds (1+ *frs-top*)))
 	 (fi *frs-base*)
@@ -676,31 +813,74 @@ under certain conditions; see file 'Copyright' for details.")
 	(print-frs fi)
 	(incf fi))
       (format t "BDS[~d]: ~s = ~s~%"
-	      bi (bds-var bi) (bds-val bi)))))
+	      bi (bds-var bi)
+	      (let ((val (bds-val bi)))
+		(if (unbound-value-p val) "<unbound value>" val))))))
 
 (defun tpl-backtrace (&optional n)
-  (if (null n)
-      (let ((*print-pretty* nil))	; because CLOS allows (setf foo)
-					; as function names
-	(princ "Backtrace:")
-	(do ((i *ihs-top* (si::ihs-prev i))
-	     (b nil t))
-	    ((< i *ihs-base*))
-	  (when (ihs-visible i)
-	    (let ((*print-case* (if (= i *ihs-current*) :UPCASE :DOWNCASE)))
-	      (format t "~:[~; >~] ~S" b (ihs-fname i)))))
-	(terpri))
-      (do ((i *ihs-top* (si::ihs-prev i))
-	   (k (if (integerp n) n nil) (and k (1- k))))
-	  ((= k 0) (values))
-	(let*((j (or (sch-frs-base *frs-base* i) (1+ *frs-top*)))
-	      (*print-level* 2)
-	      (*print-length* 4)
-	      (*print-pretty* t))
-	  (do () ((or (> j *frs-top*) (> (frs-ihs j) i)))
+  (let ((*print-pretty* nil)	 ;; because CLOS allows (setf foo) as function names
+	(base *ihs-base*)
+	(top *ihs-top*))
+    (format t "~&Backtrace:~%")
+    (if (null n)
+	(do ((i top (si::ihs-prev i))
+	     ;;(b nil t)
+	     )
+	    ((< i base))
+	    (when (ihs-visible i)
+	      (let ((*print-case* (if (= i *ihs-current*) :UPCASE :DOWNCASE))
+		    (func-name (ihs-fname i)))
+		;;(format t "~:[~; >~] ~S" b (ihs-fname i)) ;; JCB
+		(format t "  > ~S" func-name)
+		(when (eq func-name 'si::bytecodes)
+		  (format t " [Evaluation of: ~S]"
+                          (function-lambda-expression (ihs-fun i))))
+		(terpri)
+		)))
+      (progn
+	(if (eq t n)
+	    (setq base 0)
+	  (progn
+	    (unless (integerp n)
+	      (error "Argument to command :backtrace must be an integer or t."))
+	    (setq top *ihs-current*)
+	    )
+	  )
+	(do ((i top (si::ihs-prev i))
+	     ;;(b nil t)
+	     (j 0 (1+ j))
+	     (max (if (eq t n) *ihs-top* n))
+	     )
+	    ((or (< i base) (>= j max))
+	     (when (zerop i) (format t "  > ---end-of-stack---~%"))
+	     )
+	    (when (or (ihs-visible i) (eq t n))
+	      (let ((*print-case* (if (= i *ihs-current*) :UPCASE :DOWNCASE))
+		    (func-name (ihs-fname i)))
+		;;(format t "~:[~; >~] ~S" b (ihs-fname i)) ;; JCB
+		(format t "  > ~S" (ihs-fname i))
+		(when (eq func-name 'si::bytecodes)
+		  (format t " [Evaluation of: ~S]" (function-lambda-expression (ihs-fun i))))
+		(terpri)
+		))))
+      )
+    (terpri))
+  (values))
+
+(defun tpl-frs-command (&optional n)
+  (unless n (setq n *ihs-top*))
+  (unless (integerp n)
+    (error "Argument to command :frs must be an integer."))
+  (do ((i *ihs-top* (si::ihs-prev i))
+       (k n (1- k)))
+      ((= k 0) (values))
+      (let*((j (or (sch-frs-base *frs-base* i) (1+ *frs-top*)))
+	    (*print-level* 2)
+	    (*print-length* 4)
+	    (*print-pretty* t))
+	(do () ((or (> j *frs-top*) (> (frs-ihs j) i)))
 	    (print-frs j)
 	    (incf j)))))
-  (values))
 
 (defun print-frs (i)
   (format *debug-io* "    FRS[~d]: ---> IHS[~d],BDS[~d]~%"
@@ -708,19 +888,25 @@ under certain conditions; see file 'Copyright' for details.")
 
 (defun break-where ()
   (if (<= *tpl-level* 0)
-    (format t "Top level.~%")
+      #-threads (format t "~&Top level.~%")
+      #+threads (format t "~&Top level in: ~S.~%" mp:*current-process*)
     (tpl-print-current)))
 
 (defun tpl-print-current ()
   (let ((name (ihs-fname *ihs-current*)))
-    (format t "Broken at ~:@(~S~)." name))
+    (format t "~&Broken at ~:@(~S~)." name)
+    (when (eq name 'si::bytecodes)
+      (format t " [Evaluation of: ~S]"
+              (function-lambda-expression (ihs-fun *ihs-current*)))))
+  #-threads (terpri)
+  #+threads (format t " In: ~S.~%" mp:*current-process*)
   (let ((fun (ihs-fun *ihs-current*)))
     (when (and (symbolp fun) (fboundp fun))
       (setf fun (fdefinition fun)))
     (multiple-value-bind (file position)
-	(si::bc-file fun)
+	(ext:compiled-function-file fun)
       (when file
-	(format t " File: ~S (Form #~D)" file position))))
+	(format t " File: ~S (Form #~D)~%" file position))))
   (values))
 
 (defun tpl-hide (fname)
@@ -876,14 +1062,16 @@ Use the following functions to directly access ECL stacks.
 
 Invocation History Stack:
 (sys:IHS-TOP)	Returns the index of the TOP of the IHS.
-(SYS:IHS-VS i)	Returns the VS index of the i-th entity in IHS.
 (SYS:IHS-FUN i)	Returns the function of the i-th entity in IHS.
+(SYS:IHS-ENV i)
+(SYS:IHS-PREV i)
+(SYS:IHS-NEXT i)
 
 Frame (catch, block) Stack:
 (sys:FRS-TOP)	Returns the index of the TOP of the FRS.
-(SYS:FRS-VS i)	Returns the VS index of the i-th entity in FRS.
 (SYS:FRS-BDS i)	Returns the BDS index of the i-th entity in FRS.
 (SYS:FRS-IHS i)	Returns the IHS index of the i-th entity in FRS.
+(SYS:FRS-TAG i)
 
 Binding Stack:
 (sys:BDS-TOP)	Returns the index of the TOP of the BDS.
@@ -894,52 +1082,207 @@ Note that these functions are named by external symbols in the SYSTEM
 package."
 ))
 
+(defun compute-restart-commands (condition &key display)
+  (let ((restarts (compute-restarts condition))
+	(restart-commands (list "Restart commands")))
+    (when display
+      (format display (if restarts
+			  "~&Available restarts:~2%" 
+			  "~&No restarts available.~%")))
+    (loop for restart in restarts
+       and i from 1
+       do (let ((user-command (format nil "r~D" i))
+		(name (format nil "~@[(~A)~]" (restart-name restart)))
+		(helpstring (princ-to-string restart)))
+	    (push (list
+		   (list (intern (string-upcase user-command) :keyword))
+		   restart :restart
+		   (format nil ":~A~16T~A~24T~A" user-command helpstring name)
+		   (format nil ":~A~48T~A~& ~&~A~A" (string-downcase user-command)
+                           "[Restart command]" name helpstring))
+		  restart-commands)
+	    (when display
+	      (format display "~D. ~A ~A~%" i name restart))))
+    (when display (terpri display))
+    (nreverse restart-commands)))
+
+(defun update-debug-commands (restart-commands)
+  (let ((commands (copy-list *tpl-commands*)))
+    (unless (member break-commands commands)
+      (setq commands (nconc commands (list break-commands)))
+      )
+    (delete-if
+     #'(lambda (x) (string= "Restart commands" (car x)))
+     commands)
+    (nconc commands (list restart-commands))))
+
+(defvar *default-debugger-maximum-depth* 16)
+
+(defun check-default-debugger-runaway ()
+  (when (< *default-debugger-maximum-depth* *break-level*)
+    #+threads 
+    (progn
+      (format *error-output*
+	      "~&Excessive debugger depth! Probable infinite recursion!~%~
+             Quitting process: ~S.~%" mp:*current-process*)
+      (when (< (+ *default-debugger-maximum-depth* 3) *break-level*)
+	;; we tried to be polite but it does not seem to work.
+	(quit -1))
+      (exit-process))
+    #-threads 
+    (progn
+      (format *error-output*
+	    "~&Excessive debugger depth! Probable infinite recursion!~%~
+             Quitting.~%")
+        (quit -1))))
+
+#+threads
+(progn
+  (defvar *debugger-waiting-list-lock* (mp:make-lock :name 'debugger-waiting-list))
+  (defvar *debugger-waiting-list* nil)
+  (defvar *debugger-lock* (mp:make-lock :name 'debugger))
+  (defvar *debuggee-elect* nil)
+  (defvar *debuggee* nil)
+  )
+
+#+threads
+(defun tpl-switch-command (&optional rank)
+  (when (integerp rank)
+    (let ((max (list-length *debugger-waiting-list*)))
+      (unless (and (< 0 rank) (<= rank max))
+	(error "Debugger switch command: Invalid argument value.")))
+    (let ((elect (car (last *debugger-waiting-list* rank))))
+      (when elect
+	(setq *debuggee-elect* elect))))
+  (invoke-restart 'suspend-debug)
+  (values))
+
+#+threads
+(defun tpl-waiting-command ()
+  (labels ((display-waitee (waiting-list)
+	     (unless waiting-list
+	       (return-from display-waitee 0))
+	     (let ((rank (1+ (display-waitee (cdr waiting-list)))))
+	       (format t "    ~D: ~s~%" rank (car waiting-list))
+	       rank)))
+    (format t "~&~%Debugger's waiting list:~2%")
+    (display-waitee *debugger-waiting-list*)
+    (terpri))
+  (values))
+
+#+threads
+(defun register-on-debugger-waiting-list (process)
+  (mp:with-lock
+   (*debugger-waiting-list-lock*)
+   (unless (find process *debugger-waiting-list*)
+     (push process *debugger-waiting-list*)
+     (format *error-output* "~&~2%Debugger called in: ~S.~2%" process)
+     (finish-output))))
+
+#+threads
+(defun remove-from-debugger-waiting-list (process)
+  (mp:with-lock
+   (*debugger-waiting-list-lock*)
+   (setq *debugger-waiting-list* (delete process *debugger-waiting-list*))))
+
+#+threads
+(defmacro with-debugger-lock (&body body)
+  `(mp:with-lock (*debugger-lock*)
+		 ,@body))
+
+#-threads
+(defmacro with-debugger-lock (&body body)
+  `(progn ,@body))
+
 (defun default-debugger (condition)
   (unless *break-enable*
     (throw *quit-tag* nil))
   (let*((*standard-input* *debug-io*)
 	(*standard-output* *debug-io*)
+	;;(*tpl-prompt-hook* "[dbg] ")
 	(*print-pretty* nil)
 	(*print-circle* t)
 	(*readtable* (or *break-readtable* *readtable*))
 	(*break-message* (format nil "~&~A~%" condition))
 	(*break-level* (1+ *break-level*))
+	(break-level *break-level*)
 	(*break-env* nil))
-    (when (listen *debug-io*)
-      (clear-input *debug-io*))
-    ;; Like in SBCL, the error message is output through *error-output*
-    ;; The rest of the interaction is performed through *debug-io*
-    (princ *break-message* *error-output*)
-    (tpl-print-current)
-    ;; Here we show a list of restarts and invoke the toplevel with
-    ;; an extended set of commands which includes invoking the associated
-    ;; restarts.
-    (let* ((restarts (compute-restarts condition))
-	   (restart-commands (list "Restart commands")))
-      (format t (if restarts "Available restarts:~%" "No restarts available.~%"))
-      (loop for restart in restarts
-	 and i from 1
-	 do (let ((user-command (format nil "r~D" i))
-		  (name (format nil "~@[(~A) ~]" (restart-name restart)))
-		  (helpstring (princ-to-string restart)))
-	      (push (list
-		     (list (intern (string-upcase user-command) :keyword))
-		     restart :restart
-		     (format nil ":~A~16T~A~24T~A" user-command helpstring name)
-		     (format nil ":~A~48T~A~& ~&~A~A" (string-downcase user-command) "[Restart command]" name helpstring))
-		    restart-commands)
-	      (format t "~D. ~A~A~%" i name restart)))
-      (tpl :commands
-	   (adjoin (nreverse restart-commands)
-		   (adjoin break-commands *tpl-commands*))))))
+    (check-default-debugger-runaway)
+    (tagbody
+     ;;debug
+     waiting-room
+     #+threads (register-on-debugger-waiting-list mp:*current-process*)
+     (with-debugger-lock
+      #+threads 
+      (progn
+	(when *debuggee-elect*
+	  (unless (eq *debuggee-elect* mp:*current-process*)
+	    (when (find *debuggee-elect* *debugger-waiting-list*)
+	      (when (mp:process-active-p *debuggee-elect*)
+		;; if *debuggee-elect* is dead we just pick-up the first comer.
+		(go waiting-room))))
+	  )
+	(setq *debuggee* mp:*current-process* *debuggee-elect* nil)
+	(remove-from-debugger-waiting-list mp:*current-process*))
+      (when (listen *debug-io*)
+	(clear-input *debug-io*))
+      ;; Like in SBCL, the error message is output through *error-output*
+      ;; The rest of the interaction is performed through *debug-io*
+      (finish-output)
+      (fresh-line *error-output*)
+      (terpri *error-output*)
+      (princ *break-message* *error-output*)
+      ;; Here we show a list of restarts and invoke the toplevel with
+      ;; an extended set of commands which includes invoking the associated
+      ;; restarts.
+      (restart-case
+       (let* ((restart-commands (compute-restart-commands condition :display t))
+	      (debug-commands 
+	       ;;(adjoin restart-commands (adjoin break-commands *tpl-commands*))
+	       (update-debug-commands restart-commands)
+	       ))
+	 (tpl :commands debug-commands)
+	 )
+       #+threads
+       (suspend-debug ()
+	 :report (lambda (s)
+		   (format s "Put this process back on debugger's waiting list."))
+	 (go waiting-room))
+       (quit-debugger ()
+	 :report (lambda (s)
+		   (format s "Quit debugger level ~D." break-level))
+	 (go quit)))
+      ) ; with-debugger-lock
+     quit
+     ;; (format *debug-io* "~&Leaving debugger level ~D.~%" break-level)
+     ;; As of ECL 9.4.1 making a normal function return from the debugger
+     ;; seems to be a very bad idea! Basically, it dumps core...
+     (throw *quit-tag* t)
+     ) ; tagbody
+    ))
 
 (defun invoke-debugger (condition)
   (when *debugger-hook*
     (let* ((old-hook *debugger-hook*)
 	   (*debugger-hook* nil))
       (funcall old-hook condition old-hook)))
-  (locally (declare (notinline default-debugger))
-    (default-debugger condition)))
+  (locally 
+    (declare (notinline default-debugger))
+    (if (<= 0 *tpl-level*) ;; Do we have a top-level REPL above us?
+        (default-debugger condition)
+        (let* (;; We do not have a si::top-level invocation above us
+               ;; so we have to provide the environment for interactive use.
+               (*break-enable* *break-enable*)
+               (*debugger-hook* *debugger-hook*)
+               (*quit-tags* (cons *quit-tag* *quit-tags*))
+               (*quit-tag* *quit-tags*)	; any unique new value
+               (*ihs-top* 0) ;; Or should it be 1?
+               (*tpl-level* (1+ *tpl-level*)) ;; Or should we simply say 0.
+               (*tpl-commands* *tpl-commands*)
+               + ++ +++ - * ** *** / // ///)
+          (catch *quit-tag*
+            (default-debugger condition)))))
+  (finish-output))
 
 (defun safe-eval (form env err-value)
   (catch 'si::protect-tag