Changeset 4190

Timestamp:

10/04/03 10:53:35 (19 years ago)

Author:

piso

Message:

Work in progress.

Location:

trunk/j/src/org/armedbear/lisp

Files:

• debug.lisp (modified) (3 diffs)
• top-level.lisp (modified) (10 diffs)

trunk/j/src/org/armedbear/lisp/debug.lisp

@@ -2 +2 @@
 ;;;
 ;;; Copyright (C) 2003 Peter Graves
-;;; $Id: debug.lisp,v 1.4 2003-10-01 13:59:23 piso Exp $
+;;; $Id: debug.lisp,v 1.5 2003-10-04 10:53:35 piso Exp $
 ;;;
 ;;; This program is free software; you can redistribute it and/or
@@ -20 +20 @@
 (in-package "SYSTEM")
 
-(defun debug-prompt (stream)
-  (format stream "~%> "))
+(defun debug-loop ()
+  (let ((tpl::*break-level* (1+ tpl::*break-level*)))
+  (fresh-line *debug-io*)
+  (format *debug-io* "Type :CONTINUE to return from break or :RESET to return to top level.~%")
+    (loop
+      (catch 'debug-loop-catcher
+        (handler-case
+            (tpl::repl)
+          (error (c) (format t "Error: ~S.~%" c) (break) (throw 'debug-loop-catcher nil)))))))
 
 (defun invoke-debugger (condition)
@@ -28 +35 @@
           (*debugger-hook* nil))
       (funcall hook-function condition hook-function)))
-  (catch 'continue
-    (debugger-loop)))
-
-(defun debugger-loop ()
-  (fresh-line *debug-io*)
-  (format *debug-io* "Type :continue to continue...")
-  (loop
-    (catch 'debug-loop-catcher
-      (handler-bind ((error (lambda (condition)
-                              (format *debug-io* "~%Error: ~S.~%" condition)
-                              (throw 'debug-loop-catcher nil))))
-        (debug-prompt *debug-io*)
-        (finish-output *debug-io*)
-        (let* ((exp (read *debug-io*)))
-          (when (memq exp '(:co :continue))
-            (return-from debugger-loop))
-          (let* ((values (multiple-value-list (eval exp)))
-                 (*standard-output* *debug-io*))
-            (fresh-line)
-            (if values (prin1 (car values)))
-            (dolist (x (cdr values))
-              (fresh-line)
-              (prin1 x))))))))
+  (catch 'tpl::continue-catcher
+    (debug-loop)))
 
 (defun break (&optional format-control &rest format-arguments)
   (fresh-line *debug-io*)
-  (format *debug-io* "break called~%")
+  (format *debug-io* "BREAK called.~%")
   (invoke-debugger nil))

trunk/j/src/org/armedbear/lisp/top-level.lisp

@@ -2 +2 @@
 ;;;
 ;;; Copyright (C) 2003 Peter Graves
-;;; $Id: top-level.lisp,v 1.2 2003-09-26 19:19:14 piso Exp $
+;;; $Id: top-level.lisp,v 1.3 2003-10-04 10:53:26 piso Exp $
 ;;;
 ;;; This program is free software; you can redistribute it and/or
@@ -22 +22 @@
 (in-package "EXTENSIONS")
 
-(export '(*saved-backtrace* bt))
+(export '(*saved-backtrace*))
 
 (defvar *saved-backtrace* nil)
 
-(defun bt (&optional count)
-  (let ((count (if (fixnump count) count 7))
-        (n 0))
-    (dolist (frame *saved-backtrace*)
-      (format t "  ~D: ~A~%" n frame)
-      (incf n)
-      (when (>= n count)
-        (return))))
-  (values))
-
 (in-package "TOP-LEVEL")
+
+(defvar *break-level* 0)
 
 (defparameter *command-char* #\:)
@@ -51 +43 @@
 (defun repl-prompt-fun (stream)
   (fresh-line stream)
+  (when (> *break-level* 0)
+    (format stream "[~D] " *break-level*))
   (write-string (prompt-package-name) stream)
   (write-string "(" stream)
@@ -83 +77 @@
     (push (subseq string 0 end) res)))
 
+(defun backtrace-command (&optional count)
+  (let ((count (if (fixnump count) count 7))
+        (n 0))
+    (dolist (frame *saved-backtrace*)
+      (format t "  ~D: ~A~%" n frame)
+      (incf n)
+      (when (>= n count)
+        (return))))
+  (values))
+
+(defun continue-command ()
+  (if (> *break-level* 0)
+      (throw 'continue-catcher nil)))
+
+(defun reset-command ()
+  (throw 'top-level-catcher nil))
+
 (defun process-cmd (form)
   (when (and (stringp form) (> (length form) 1) (eql (char form 0) *command-char*))
@@ -92 +103 @@
         (when (zerop (length args))
           (setf args nil)))
-      (cond ((string= cmd "ld")
+      (cond ((string-equal cmd "ld")
              (let ((files (if args (tokenize args) *last-files-loaded*)))
                (setf *last-files-loaded* files)
@@ -98 +109 @@
                  (load file)))
              )
-            ((string= cmd "de")
+            ((string-equal cmd "de")
              (let ((obj (eval (read-from-string args))))
                (describe obj)))
-            ((string= cmd "ap")
+            ((string-equal cmd "ap")
              (apropos args))
-            ((string= cmd "pwd")
+            ((string-equal cmd "pwd")
              (format t "~A~%" *default-pathname-defaults*))
-            ((string= cmd "cd")
+            ((string-equal cmd "cd")
              (cond ((or (null args) (string= args "~"))
                     (setf args (namestring (user-homedir-pathname))))
@@ -118 +129 @@
                      (format *standard-output* "~A" (namestring *default-pathname-defaults*)))
                    (format *standard-output* "Error: no such directory (~S).~%" args))))
-            ((string= cmd "bt")
-             (let ((count (or (and args (ignore-errors (parse-integer args))) 7)))
-               (bt count)))
-            ((string= cmd "pa")
+            ((string-equal cmd "bt")
+             (let ((count (or (and args (ignore-errors (parse-integer args))) most-positive-fixnum)))
+               (backtrace-command count)))
+            ((string-equal cmd "pa")
              (cond ((null args)
                     (format *standard-output* "The ~A package is current.~%"
@@ -133 +144 @@
                           (setf *package* pkg)
                           (format *standard-output* "Unknown package ~A.~%" args))))))
-            ((string= cmd "ex")
+            ((or (string-equal cmd "cont") (string-equal cmd "continue"))
+             (continue-command))
+            ((or (string-equal cmd "res") (string-equal cmd "reset"))
+             (reset-command))
+            ((string-equal cmd "ex")
              (format t "Bye!~%")
              (exit))
@@ -169 +184 @@
   (values-list /))
 
-(defun repl-fun ()
+(defun repl ()
   (loop
     (funcall *repl-prompt-fun* *standard-output*)
@@ -181 +196 @@
         (prin1 result)))))
 
-(defvar *in-top-level-loop* nil)
-
 (defun top-level-loop ()
-  (setf *in-top-level-loop* t)
-  (loop
-    (catch 'top-level
+  (loop
+    (catch 'top-level-catcher
       (handler-case
-          (repl-fun)
-        (error (c) (format t "Error: ~S.~%" c) (break) (throw 'top-level nil))))))
+          (repl)
+        (stream-error (c) (return-from top-level-loop))
+        (error (c) (format t "Error: ~S.~%" c) (break) (throw 'top-level-catcher nil))))))