source: trunk/abcl/src/org/armedbear/lisp/top-level.lisp @ 12105

Last change on this file since 12105 was 12105, checked in by Mark Evenson, 12 years ago

Split StackFrame? abstraction into Java and Lisp stack frames.

From the original patch/idea from Tobias Rittweiler this introduces
more information of primary interest to ABCL implemnters such as when
a form like (make-thread #'(lambda ())) is evaluated

All users of EXT:BACKTRACE-AS-LIST should now use SYS:BACKTRACE, the
results of which is a list of the new builtin classes JAVA_STACK_FRAME
or LISP_STACK_FRAME. The methods SYS:FRAME-TO-STRING and
SYS:FRAME-TO-LIST are defined to break these new objects into
inspectable parts. As a convenience, there is a SYS:BACKTRACE-AS-LIST
which calls SYS:FRAME-TO-LIST to each element of the computed
backtrace.

Refactorings have occurred on the Java side: the misnamed
LispThread?.backtrace() is now LispThread?.printBacktrace().
LispThread?.backtraceAsList() is now LispThread?.backtrace() as it is
a shorter name, and more to the point.

Java stack frames only appear after a call through Lisp.error(), which
has only the top level as a restart as an option.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 14.5 KB
Line 
1;;; top-level.lisp
2;;;
3;;; Copyright (C) 2003-2006 Peter Graves
4;;; $Id: top-level.lisp 12105 2009-08-19 14:51:56Z mevenson $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32;;; Adapted from SB-ACLREPL (originally written by Kevin Rosenberg).
33
34(in-package #:system)
35
36(defvar *inspect-break* nil)
37
38(defvar *inspected-object-stack* nil)
39
40(defvar *inspected-object* nil)
41
42(in-package #:top-level)
43
44(import '(sys::%format sys::list-traced-functions sys::trace-1 sys::untrace-1 sys::untrace-all))
45
46(defvar *null-cmd* (gensym))
47
48(defvar *command-char* #\:)
49
50(defvar *cmd-number* 1
51  "Number of the next command")
52
53(defun prompt-package-name ()
54  (let ((result (package-name *package*)))
55    (dolist (nickname (package-nicknames *package*))
56      (when (< (length nickname) (length result))
57        (setf result nickname)))
58    result))
59
60(defun repl-prompt-fun (stream)
61  (fresh-line stream)
62  (when (> *debug-level* 0)
63    (%format stream "[~D~A] "
64             *debug-level*
65             (if sys::*inspect-break* "i" "")))
66  (%format stream "~A(~D): " (prompt-package-name) *cmd-number*))
67
68(defparameter *repl-prompt-fun* #'repl-prompt-fun)
69
70(defun peek-char-non-whitespace (stream)
71  (loop
72    (let ((c (read-char stream nil)))
73      (when (null c) ; control d
74        (quit))
75      (unless (eql c #\space)
76        (unread-char c stream)
77        (return c)))))
78
79(defun apropos-command (args)
80  (when args (apropos args)))
81
82(defun continue-command (args)
83  (when args
84    (let ((n (read-from-string args)))
85      (let ((restarts (compute-restarts)))
86        (when (< -1 n (length restarts))
87          (invoke-restart-interactively (nth n restarts)))))))
88
89(defun describe-command (args)
90  (let ((obj (eval (read-from-string args))))
91    (describe obj)))
92
93(defun error-command (ignored)
94  (declare (ignore ignored))
95  (when *debug-condition*
96    (let* ((s (%format nil "~A" *debug-condition*))
97           (len (length s)))
98      (when (plusp len)
99        (setf (schar s 0) (char-upcase (schar s 0)))
100        (unless (eql (schar s (1- len)) #\.)
101          (setf s (concatenate 'string s "."))))
102      (%format *debug-io* "~A~%" s))
103    (show-restarts (compute-restarts) *debug-io*)))
104
105(defun print-frame (frame stream &key prefix)
106  (when prefix
107    (write-string prefix stream))
108  (etypecase frame
109    (sys::lisp-stack-frame
110     (pprint-logical-block (stream nil :prefix "(" :suffix ")")
111       (setq frame (sys:frame-to-list frame))
112       (ignore-errors
113         (prin1 (car frame) stream)
114         (let ((args (cdr frame)))
115           (if (listp args)
116               (format stream "~{ ~_~S~}" args)
117               (format stream " ~S" args))))))
118    (sys::java-stack-frame
119     (write-string (sys:frame-to-string frame) stream))))
120
121
122(defun backtrace-command (args)
123  (let ((count (or (and args (ignore-errors (parse-integer args)))
124                   8))
125        (n 0))
126    (with-standard-io-syntax
127      (let ((*print-pretty* t)
128            (*print-readably* nil)
129            (*print-structure* nil)
130            (*print-array* nil))
131        (dolist (frame *saved-backtrace*)
132          (fresh-line *debug-io*)
133          (print-frame frame *debug-io* :prefix (format nil "~3D: " n))
134          (incf n)
135          (when (>= n count)
136            (return))))))
137  (values))
138
139(defun frame-command (args)
140  (let* ((n (or (and args (ignore-errors (parse-integer args)))
141                0))
142         (frame (nth n *saved-backtrace*)))
143    (when frame
144      (with-standard-io-syntax
145        (let ((*print-pretty* t)
146              (*print-readably* nil)
147              (*print-structure* nil))
148          (fresh-line *debug-io*)
149    (print-frame frame *debug-io*)))
150      (setf *** **
151            ** *
152            * frame)))
153  (values))
154
155(defun inspect-command (args)
156  (let ((obj (eval (read-from-string args))))
157    (inspect obj)))
158
159(defun istep-command (args)
160  (sys::istep args))
161
162(defun macroexpand-command (args)
163  (let ((s (with-output-to-string (stream)
164             (pprint (macroexpand (read-from-string args)) stream))))
165    (write-string (string-left-trim '(#\return #\linefeed) s)))
166  (values))
167
168(defvar *old-package* nil)
169
170(defun package-command (args)
171  (cond ((null args)
172         (%format *standard-output* "The ~A package is current.~%"
173                  (package-name *package*)))
174        ((and *old-package* (string= args "-") (null (find-package "-")))
175         (rotatef *old-package* *package*))
176        (t
177         (when (and (plusp (length args)) (eql (char args 0) #\:))
178           (setf args (subseq args 1)))
179         (setf args (nstring-upcase args))
180         (let ((pkg (find-package args)))
181           (if pkg
182               (setf *old-package* *package*
183                     *package* pkg)
184               (%format *standard-output* "Unknown package ~A.~%" args))))))
185
186(defun reset-command (ignored)
187  (declare (ignore ignored))
188  (invoke-restart 'top-level))
189
190(defun exit-command (ignored)
191  (declare (ignore ignored))
192  (exit))
193
194(defvar *old-pwd* nil)
195
196(defun cd-command (args)
197  (cond ((null args)
198         (setf args (if (featurep :windows)
199                        "C:\\"
200                        (namestring (user-homedir-pathname)))))
201        ((string= args "-")
202         (if *old-pwd*
203             (setf args (namestring *old-pwd*))
204             (progn
205               (%format t "No previous directory.")
206               (return-from cd-command))))
207        ((and (> (length args) 1) (string= (subseq args 0 2) "~/")
208              (setf args (concatenate 'string
209                                      (namestring (user-homedir-pathname))
210                                      (subseq args 2))))))
211  (let ((dir (probe-directory args)))
212    (if dir
213        (progn
214          (unless (equal dir *default-pathname-defaults*)
215            (setf *old-pwd* *default-pathname-defaults*
216                  *default-pathname-defaults* dir))
217          (%format t "~A" (namestring *default-pathname-defaults*)))
218        (%format t "Error: no such directory (~S).~%" args))))
219
220(defun ls-command (args)
221  (let ((args (if (stringp args) args ""))
222        (ls-program (if (featurep :windows) "dir" "ls")))
223    (run-shell-command (concatenate 'string ls-program " " args)
224                       :directory *default-pathname-defaults*))
225  (values))
226
227(defun tokenize (string)
228  (do* ((res nil)
229        (string (string-left-trim " " string)
230                (string-left-trim " " (subseq string end)))
231        (end (position #\space string) (position #\space string)))
232       ((zerop (length string)) (nreverse res))
233    (unless end
234      (setf end (length string)))
235    (push (subseq string 0 end) res)))
236
237(defvar *last-files-loaded* nil)
238
239(defun ld-command (args)
240  (let ((files (if args (tokenize args) *last-files-loaded*)))
241    (setf *last-files-loaded* files)
242    (dolist (file files)
243      (load file))))
244
245(defun cf-command (args)
246  (let ((files (tokenize args)))
247    (dolist (file files)
248      (compile-file file))))
249
250(defvar *last-files-cloaded* nil)
251
252(defun cload-command (args)
253  (let ((files (if args (tokenize args) *last-files-cloaded*)))
254    (setf *last-files-cloaded* files)
255    (dolist (file files)
256      (load (compile-file file)))))
257
258(defun rq-command (args)
259  (let ((modules (tokenize (string-upcase args))))
260    (dolist (module modules)
261      (require module))))
262
263(defun pwd-command (ignored)
264  (declare (ignore ignored))
265  (%format t "~A~%" (namestring *default-pathname-defaults*)))
266
267(defun trace-command (args)
268  (if (null args)
269    (%format t "~A~%" (list-traced-functions))
270    (dolist (f (tokenize args))
271      (trace-1 (read-from-string f)))))
272
273(defun untrace-command (args)
274  (if (null args)
275    (untrace-all)
276    (dolist (f (tokenize args))
277      (untrace-1 (read-from-string f)))))
278
279(defconstant spaces (make-string 32 :initial-element #\space))
280
281(defun pad (string width)
282  (if (< (length string) width)
283      (concatenate 'string string (subseq spaces 0 (- width (length string))))
284      string))
285
286(defun %help-command (prefix)
287  (let ((prefix-len (length prefix)))
288    (when (and (> prefix-len 0)
289               (eql (schar prefix 0) *command-char*))
290      (setf prefix (subseq prefix 1))
291      (decf prefix-len))
292    (%format t "~%  COMMAND     ABBR DESCRIPTION~%")
293    (dolist (entry *command-table*)
294      (when (or (null prefix)
295                (and (<= prefix-len (length (entry-name entry)))
296                     (string-equal prefix (subseq (entry-name entry) 0 prefix-len))))
297        (%format t "  ~A~A~A~%"
298                 (pad (entry-name entry) 12)
299                 (pad (entry-abbreviation entry) 5)
300                 (entry-help entry))))
301    (%format t "~%Commands must be prefixed by the command character, which is '~A'~A.~%~%"
302             *command-char* (if (eql *command-char* #\:) " by default" ""))))
303
304(defun help-command (&optional ignored)
305  (declare (ignore ignored))
306  (%help-command nil))
307
308(defparameter *command-table*
309  '(("apropos" "ap" apropos-command "apropos")
310    ("bt" nil backtrace-command "backtrace n stack frames (default 8)")
311    ("cd" nil cd-command "change default directory")
312    ("cf" nil cf-command "compile file(s)")
313    ("cload" "cl" cload-command "compile and load file(s)")
314    ("continue" "cont" continue-command "invoke restart n")
315    ("describe" "de" describe-command "describe an object")
316    ("error" "err" error-command "print the current error message")
317    ("exit" "ex" exit-command "exit lisp")
318    ("frame" "fr" frame-command "set the value of cl:* to be frame n (default 0)")
319    ("help" "he" help-command "print this help")
320    ("inspect" "in" inspect-command "inspect an object")
321    ("istep" "i" istep-command "navigate within inspection of an object")
322    ("ld" nil ld-command "load a file")
323    ("ls" nil ls-command "list directory")
324    ("macroexpand" "ma" macroexpand-command "macroexpand an expression")
325    ("package" "pa" package-command "change *PACKAGE*")
326    ("pwd" "pw" pwd-command "print current directory")
327    ("reset" "res" reset-command "return to top level")
328    ("rq" nil rq-command "require a module")
329    ("trace" "tr" trace-command "trace function(s)")
330    ("untrace" "untr" untrace-command "untrace function(s)")))
331
332(defun entry-name (entry)
333  (first entry))
334
335(defun entry-abbreviation (entry)
336  (second entry))
337
338(defun entry-command (entry)
339  (third entry))
340
341(defun entry-help (entry)
342  (fourth entry))
343
344(defun find-command (string)
345  (let ((len (length string)))
346    (when (and (> len 0)
347               (eql (schar string 0) *command-char*))
348      (setf string (subseq string 1)
349            len (1- len)))
350    (dolist (entry *command-table*)
351      (when (or (string= string (entry-abbreviation entry))
352                (string= string (entry-name entry)))
353        (return (entry-command entry))))))
354
355(defun process-cmd (form)
356  (when (eq form *null-cmd*)
357    (return-from process-cmd t))
358  (when (and (stringp form)
359             (> (length form) 1)
360             (eql (char form 0) *command-char*))
361    (let* ((pos (or (position #\space form)
362                    (position #\return form)))
363           (command-string (subseq form 0 pos))
364           (args (if pos (subseq form (1+ pos)) nil)))
365      (let ((command (find-command command-string)))
366        (cond ((null command)
367               (%format t "Unknown top-level command \"~A\".~%" command-string)
368               (%format t "Type \"~Ahelp\" for a list of available commands." *command-char*))
369              (t
370               (when args
371                 (setf args (string-trim (list #\space #\return) args))
372                 (when (zerop (length args))
373                   (setf args nil)))
374               (funcall command args)))))
375      t))
376
377(defun read-cmd (stream)
378  (let ((c (peek-char-non-whitespace stream)))
379    (cond ((eql c *command-char*)
380           (read-line stream))
381          ((eql c #\newline)
382           (read-line stream)
383           *null-cmd*)
384          (t
385           (read stream nil)))))
386
387(defun repl-read-form-fun (in out)
388  (loop
389    (funcall *repl-prompt-fun* out)
390    (finish-output out)
391    (let ((form (read-cmd in)))
392      (setf (charpos out) 0)
393      (unless (eq form *null-cmd*)
394        (incf *cmd-number*))
395      (cond ((process-cmd form))
396            ((and (> *debug-level* 0)
397                  (fixnump form))
398             (let ((n form)
399                   (restarts (compute-restarts)))
400               (if (< -1 n (length restarts))
401                   (invoke-restart-interactively (nth n restarts))
402                   (return form))))
403            (t
404             (return form))))))
405
406(defparameter *repl-read-form-fun* #'repl-read-form-fun)
407
408(defun repl (&optional (in *standard-input*) (out *standard-output*))
409  (let* ((*print-length* 10))
410    (loop
411       (let* ((form (funcall *repl-read-form-fun* in out))
412              (results (multiple-value-list (sys:interactive-eval form))))
413         (dolist (result results)
414           (fresh-line out)
415           (prin1 result out))))))
416
417(defun top-level-loop ()
418  (fresh-line)
419  (unless sys:*noinform*
420    (%format t "Type \"~Ahelp\" for a list of available commands.~%" *command-char*))
421  (loop
422    (setf *inspected-object* nil
423          *inspected-object-stack* nil
424          *inspect-break* nil)
425    (with-simple-restart (top-level
426                          "Return to top level.")
427      (if (featurep :j)
428          (handler-case
429              (repl)
430            (stream-error (c) (declare (ignore c)) (return-from top-level-loop)))
431          (repl)))))
Note: See TracBrowser for help on using the repository browser.