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

Last change on this file since 14071 was 14071, checked in by vvoutilainen, 9 years ago

correct #195

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