source: trunk/j/src/org/armedbear/lisp/top-level.lisp @ 8644

Last change on this file since 8644 was 8644, checked in by piso, 17 years ago

BACKTRACE-COMMAND: bind *PRINT-STRUCTURE* to NIL.

File size: 12.6 KB
Line 
1;;; top-level.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: top-level.lisp,v 1.41 2005-02-26 17:49:57 piso Exp $
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;;; Adapted from SB-ACLREPL (originally written by Kevin Rosenberg).
21
22(in-package #:system)
23
24(defvar *inspect-break* nil)
25
26(defvar *inspected-object-stack* nil)
27
28(defvar *inspected-object* nil)
29
30(in-package #:top-level)
31
32(import '(sys::%format sys::list-traced-functions sys::trace-1 sys::untrace-1 sys::untrace-all))
33
34(defvar *null-cmd* (gensym))
35
36(defvar *command-char* #\:)
37
38(defvar *cmd-number* 1
39  "Number of the next command")
40
41(defun prompt-package-name ()
42  (let ((result (package-name *package*)))
43    (dolist (nickname (package-nicknames *package*))
44      (when (< (length nickname) (length result))
45        (setf result nickname)))
46    result))
47
48(defun repl-prompt-fun (stream)
49  (fresh-line stream)
50  (when (> *debug-level* 0)
51    (%format stream "[~D~A] "
52             *debug-level*
53             (if sys::*inspect-break* "i" "")))
54  (%format stream "~A(~D): " (prompt-package-name) *cmd-number*))
55
56(defparameter *repl-prompt-fun* #'repl-prompt-fun)
57
58(defun peek-char-non-whitespace (stream)
59  (loop
60    (let ((c (read-char stream nil)))
61      (unless (eql c #\space)
62        (unread-char c stream)
63        (return c)))))
64
65(defun apropos-command (args)
66  (when args (apropos args)))
67
68(defun backtrace-command (args)
69  (let ((count (or (and args (ignore-errors (parse-integer args)))
70                   8))
71        (n 0))
72    (with-standard-io-syntax
73      (let ((*print-pretty* t)
74            (*print-readably* nil)
75            (*print-structure* nil))
76        (dolist (frame *saved-backtrace*)
77          (fresh-line *debug-io*)
78          (let ((prefix (format nil "~3D: (" n)))
79            (pprint-logical-block (*debug-io* nil :prefix prefix :suffix ")")
80              (prin1 (car frame) *debug-io*)
81              (let ((args (cdr frame)))
82                (if (listp args)
83                    (format *debug-io* "~{ ~_~S~}" args)
84                    (format *debug-io* " ~S" args)))))
85          (incf n)
86          (when (>= n count)
87            (return))))))
88  (values))
89
90(defun continue-command (args)
91  (when args
92    (let ((n (read-from-string args)))
93      (let ((restarts (compute-restarts)))
94        (when (< -1 n (length restarts))
95          (invoke-restart-interactively (nth n restarts)))))))
96
97(defun describe-command (args)
98  (let ((obj (eval (read-from-string args))))
99    (describe obj)))
100
101(defun error-command (args)
102  (when *debug-condition*
103    (let* ((s (%format nil "~A" *debug-condition*))
104           (len (length s)))
105      (when (plusp len)
106        (setf (schar s 0) (char-upcase (schar s 0)))
107        (unless (eql (schar s (1- len)) #\.)
108          (setf s (concatenate 'string s "."))))
109      (%format *debug-io* "~A~%" s))
110    (show-restarts (compute-restarts) *debug-io*)))
111
112(defun inspect-command (args)
113  (let ((obj (eval (read-from-string args))))
114    (inspect obj)))
115
116(defun istep-command (args)
117  (sys::istep args))
118
119(defun macroexpand-command (args)
120  (let ((s (with-output-to-string (stream)
121             (pprint (macroexpand (read-from-string args)) stream))))
122    (write-string (string-left-trim '(#\return #\linefeed) s)))
123  (values))
124
125(defvar *old-package* nil)
126
127(defun package-command (args)
128  (cond ((null args)
129         (%format *standard-output* "The ~A package is current.~%"
130                  (package-name *package*)))
131        ((and *old-package* (string= args "-") (null (find-package "-")))
132         (rotatef *old-package* *package*))
133        (t
134         (when (and (plusp (length args)) (eql (char args 0) #\:))
135           (setf args (subseq args 1)))
136         (setf args (nstring-upcase args))
137         (let ((pkg (find-package args)))
138           (if pkg
139               (setf *old-package* *package*
140                     *package* pkg)
141               (%format *standard-output* "Unknown package ~A.~%" args))))))
142
143(defun reset-command (ignored)
144  (invoke-restart 'top-level))
145
146(defun exit-command (ignored)
147  (exit))
148
149(defvar *old-pwd* nil)
150
151(defun cd-command (args)
152  (cond ((null args)
153         (setf args (if (sys::featurep :windows)
154                        "C:\\"
155                        (namestring (user-homedir-pathname)))))
156        ((string= args "-")
157         (if *old-pwd*
158             (setf args (namestring *old-pwd*))
159             (progn
160               (%format t "No previous directory.")
161               (return-from cd-command))))
162        ((and (> (length args) 1) (string= (subseq args 0 2) "~/")
163              (setf args (concatenate 'string
164                                      (namestring (user-homedir-pathname))
165                                      (subseq args 2))))))
166  (let ((dir (probe-directory args)))
167    (if dir
168        (progn
169          (unless (equal dir *default-pathname-defaults*)
170            (setf *old-pwd* *default-pathname-defaults*
171                  *default-pathname-defaults* dir))
172          (%format t "~A" (namestring *default-pathname-defaults*)))
173        (%format t "Error: no such directory (~S).~%" args))))
174
175(defun ls-command (args)
176  (let ((args (if (stringp args) args ""))
177        (ls-program (if (sys::featurep :windows) "dir" "ls")))
178    (run-shell-command (concatenate 'string ls-program " " args)
179                       :directory *default-pathname-defaults*))
180  (values))
181
182(defun tokenize (string)
183  (do* ((res nil)
184        (string (string-left-trim " " string)
185                (string-left-trim " " (subseq string end)))
186        (end (position #\space string) (position #\space string)))
187       ((zerop (length string)) (nreverse res))
188    (unless end
189      (setf end (length string)))
190    (push (subseq string 0 end) res)))
191
192(defvar *last-files-loaded* nil)
193
194(defun ld-command (args)
195  (let ((files (if args (tokenize args) *last-files-loaded*)))
196    (setf *last-files-loaded* files)
197    (dolist (file files)
198      (load file))))
199
200(defun cf-command (args)
201  (let ((files (tokenize args)))
202    (dolist (file files)
203      (compile-file file))))
204
205(defvar *last-files-cloaded* nil)
206
207(defun cload-command (args)
208  (let ((files (if args (tokenize args) *last-files-cloaded*)))
209    (setf *last-files-cloaded* files)
210    (dolist (file files)
211      (load (compile-file file)))))
212
213(defun rq-command (args)
214  (let ((modules (tokenize (string-upcase args))))
215    (dolist (module modules)
216      (require module))))
217
218(defun pwd-command (ignored)
219  (%format t "~A~%" (namestring *default-pathname-defaults*)))
220
221(defun trace-command (args)
222  (if (null args)
223    (%format t "~A~%" (list-traced-functions))
224    (dolist (f (tokenize args))
225      (trace-1 (read-from-string f)))))
226
227(defun untrace-command (args)
228  (if (null args)
229    (untrace-all)
230    (dolist (f (tokenize args))
231      (untrace-1 (read-from-string f)))))
232
233(defconstant spaces (make-string 32 :initial-element #\space))
234
235(defun pad (string width)
236  (if (< (length string) width)
237      (concatenate 'string string (subseq spaces 0 (- width (length string))))
238      string))
239
240(defun %help-command (prefix)
241  (let ((prefix-len (length prefix)))
242    (when (and (> prefix-len 0)
243               (eql (schar prefix 0) *command-char*))
244      (setf prefix (subseq prefix 1))
245      (decf prefix-len))
246    (%format t "~%  COMMAND     ABBR DESCRIPTION~%")
247    (dolist (entry *command-table*)
248      (when (or (null prefix)
249                (and (<= prefix-len (length (entry-name entry)))
250                     (string-equal prefix (subseq (entry-name entry) 0 prefix-len))))
251        (%format t "  ~A~A~A~%"
252                 (pad (entry-name entry) 12)
253                 (pad (entry-abbreviation entry) 5)
254                 (entry-help entry))))
255    (%format t "~%Commands must be prefixed by the command character, which is '~A'~A.~%~%"
256             *command-char* (if (eql *command-char* #\:) " by default" ""))))
257
258(defun help-command (&optional ignored)
259  (%help-command nil))
260
261(defparameter *command-table*
262  '(("apropos" "ap" apropos-command "apropos")
263    ("bt" nil backtrace-command "backtrace n stack frames (default all)")
264    ("cd" nil cd-command "change default directory")
265    ("cf" nil cf-command "compile file(s)")
266    ("cload" "cl" cload-command "compile and load file(s)")
267    ("continue" "cont" continue-command "invoke restart n")
268    ("describe" "de" describe-command "describe an object")
269    ("error" "err" error-command "print the current error message")
270    ("exit" "ex" exit-command "exit lisp")
271    ("help" "he" help-command "print this help")
272    ("inspect" "in" inspect-command "inspect an object")
273    ("istep" "i" istep-command "navigate within inspection of an object")
274    ("ld" nil ld-command "load a file")
275    ("ls" nil ls-command "list directory")
276    ("macroexpand" "ma" macroexpand-command "macroexpand an expression")
277    ("package" "pa" package-command "change *PACKAGE*")
278    ("pwd" "pw" pwd-command "print current directory")
279    ("reset" "res" reset-command "return to top level")
280    ("rq" nil rq-command "require a module")
281    ("trace" "tr" trace-command "trace function(s)")
282    ("untrace" "untr" untrace-command "untrace function(s)")))
283
284(defun entry-name (entry)
285  (first entry))
286
287(defun entry-abbreviation (entry)
288  (second entry))
289
290(defun entry-command (entry)
291  (third entry))
292
293(defun entry-help (entry)
294  (fourth entry))
295
296(defun find-command (string)
297  (let ((len (length string)))
298    (when (and (> len 0)
299               (eql (schar string 0) *command-char*))
300      (setf string (subseq string 1)
301            len (1- len)))
302    (dolist (entry *command-table*)
303      (when (or (string= string (entry-abbreviation entry))
304                (string= string (entry-name entry)))
305        (return (entry-command entry))))))
306
307(defun process-cmd (form)
308  (when (eq form *null-cmd*)
309    (return-from process-cmd t))
310  (when (and (stringp form)
311             (> (length form) 1)
312             (eql (char form 0) *command-char*))
313    (let* ((pos (or (position #\space form)
314                    (position #\return form)))
315           (command-string (subseq form 0 pos))
316           (args (if pos (subseq form (1+ pos)) nil)))
317      (let ((command (find-command command-string)))
318        (cond ((null command)
319               (%format t "Unknown command ~A.~%" (string-upcase command-string))
320               (%help-command command-string))
321              (t
322               (when args
323                 (setf args (string-trim (list #\space #\return) args))
324                 (when (zerop (length args))
325                   (setf args nil)))
326               (funcall command args)))))
327      t))
328
329(defun read-cmd (stream)
330  (let ((c (peek-char-non-whitespace stream)))
331    (cond ((eql c *command-char*)
332           (read-line stream))
333          ((eql c #\newline)
334           (read-line stream)
335           *null-cmd*)
336          (t
337           (read stream nil)))))
338
339(defun repl-read-form-fun (in out)
340  (loop
341    (funcall *repl-prompt-fun* out)
342    (finish-output out)
343    (let ((form (read-cmd in)))
344      (setf (charpos out) 0)
345      (unless (eq form *null-cmd*)
346        (incf *cmd-number*))
347      (cond ((process-cmd form))
348            ((and (> *debug-level* 0)
349                  (fixnump form))
350             (let ((n form)
351                   (restarts (compute-restarts)))
352               (if (< -1 n (length restarts))
353                   (invoke-restart (nth n restarts))
354                   (return form))))
355            (t
356             (return form))))))
357
358(defparameter *repl-read-form-fun* #'repl-read-form-fun)
359
360(defun repl (&optional (in *standard-input*) (out *standard-output*))
361  (loop
362    (let* ((form (funcall *repl-read-form-fun* in out))
363           (results (multiple-value-list (sys::interactive-eval form)))
364           (*print-length* 10))
365      (dolist (result results)
366        (fresh-line out)
367        (prin1 result out)))))
368
369(defun top-level-loop ()
370  (fresh-line)
371  (%format t "Type ~AHELP for a list of available commands.~%" *command-char*)
372  (loop
373    (setf *inspected-object* nil
374          *inspected-object-stack* nil
375          *inspect-break* nil)
376    (with-simple-restart (top-level
377                          "Return to top level.")
378      (if (sys::featurep :j)
379          (handler-case
380              (repl)
381            (stream-error (c) (return-from top-level-loop)))
382          (repl)))))
Note: See TracBrowser for help on using the repository browser.