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

Last change on this file since 11391 was 11391, checked in by vvoutilainen, 13 years ago

ABCL license is GPL + Classpath exception. This was intended
by Peter Graves, the original author. For reference, see
http://sourceforge.net/mailarchive/forum.php?thread_name=20040721115302.839%40prufrock&forum_name=armedbear-j-announce

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