Changeset 4190 for trunk/j/src/org/armedbear/lisp/top-level.lisp

Timestamp:

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

Author:

piso

Message:

Work in progress.

File:

• trunk/j/src/org/armedbear/lisp/top-level.lisp (modified) (10 diffs)

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))))))