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

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

Work in progress.

File size: 9.0 KB
Line 
1;;; top-level.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: top-level.lisp,v 1.22 2003-12-19 03:23:38 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 "TOP-LEVEL")
23
24(import 'sys::%format)
25
26(defparameter *command-char* #\:)
27
28(defvar *cmd-number* 1
29  "Number of the next command")
30
31(defun prompt-package-name ()
32  (let ((result (package-name *package*)))
33    (dolist (nickname (package-nicknames *package*))
34      (when (< (length nickname) (length result))
35        (setf result nickname)))
36    result))
37
38(defun repl-prompt-fun (stream)
39  (fresh-line stream)
40  (when (> *debug-level* 0)
41    (%format stream "[~D] " *debug-level*))
42  (%format stream "~A(~D): " (prompt-package-name) *cmd-number*))
43
44(defparameter *repl-prompt-fun* #'repl-prompt-fun)
45
46(defun peek-char-non-whitespace (stream)
47  (loop
48    (let ((c (read-char stream nil)))
49      (unless (eql c #\space)
50        (unread-char c stream)
51        (return c)))))
52
53(defun apropos-command (args)
54  (when args (apropos args)))
55
56(defun backtrace-command (args)
57  (let ((count (or (and args (ignore-errors (parse-integer args)))
58                   most-positive-fixnum))
59        (n 0))
60    (dolist (frame *saved-backtrace*)
61      (%format t "  ~D: ~S~%" n frame)
62      (incf n)
63      (when (>= n count)
64        (return))))
65  (values))
66
67(defun continue-command (args)
68  (when args
69    (let ((n (read-from-string args)))
70      (let ((restarts (compute-restarts)))
71        (when (< -1 n (length restarts))
72          (invoke-restart (nth n restarts)))))))
73
74(defun describe-command (args)
75  (let ((obj (eval (read-from-string args))))
76    (describe obj)))
77
78(defun error-command (args)
79  (when *debug-condition*
80    (let* ((s (%format nil "~A" *debug-condition*))
81           (len (length s)))
82      (when (plusp len)
83        (setf (schar s 0) (char-upcase (schar s 0)))
84        (unless (eql (schar s (1- len)) #\.)
85          (setf s (concatenate 'string s "."))))
86      (format *debug-io* "~A~%" s))
87    (show-restarts (compute-restarts) *debug-io*)))
88
89(defun inspect-command (args)
90  (let ((obj (eval (read-from-string args))))
91    (inspect obj)))
92
93(defun macroexpand-command (args)
94  (format t "~S~%" (macroexpand (read-from-string args)))
95  (values))
96
97(defvar *old-package* nil)
98
99(defun package-command (args)
100  (cond ((null args)
101         (format *standard-output* "The ~A package is current.~%"
102                 (package-name *package*)))
103        ((and *old-package* (string= args "-") (null (find-package "-")))
104         (rotatef *old-package* *package*))
105        (t
106         (when (and (plusp (length args)) (eql (char args 0) #\:))
107           (setf args (subseq args 1)))
108         (setf args (nstring-upcase args))
109         (let ((pkg (find-package args)))
110           (if pkg
111               (setf *old-package* *package*
112                     *package* pkg)
113               (format *standard-output* "Unknown package ~A.~%" args))))))
114
115(defun reset-command (ignored)
116  (invoke-restart 'top-level))
117
118(defun exit-command (ignored)
119  (exit))
120
121(defun cd-command (args)
122  (cond ((or (null args) (string= args "~"))
123         (setf args (namestring (user-homedir-pathname))))
124        ((and (> (length args) 1) (string= (subseq args 0 2) "~/")
125              (setf args (concatenate 'string
126                                      (namestring (user-homedir-pathname))
127                                      (subseq args 2))))))
128  (let ((dir (probe-directory args)))
129    (if dir
130        (progn
131          (setf *default-pathname-defaults* dir)
132          (format t "~A" (namestring *default-pathname-defaults*)))
133        (format t "Error: no such directory (~S).~%" args))))
134
135(defvar *last-files-loaded* nil)
136
137(defun tokenize (string)
138  (do* ((res nil)
139        (string (string-left-trim " " string)
140                (string-left-trim " " (subseq string end)))
141        (end (position #\Space string) (position #\Space string)))
142       ((zerop (length string)) (nreverse res))
143    (unless end
144      (setf end (length string)))
145    (push (subseq string 0 end) res)))
146
147(defun ld-command (args)
148  (let ((files (if args (tokenize args) *last-files-loaded*)))
149    (setf *last-files-loaded* files)
150    (dolist (file files)
151      (load file))))
152
153(defun pwd-command (ignored)
154  (format t "~A~%" *default-pathname-defaults*))
155
156(defconstant spaces (make-string 32 :initial-element #\space))
157
158(defun pad (string width)
159  (if (< (length string) width)
160      (concatenate 'string string (subseq spaces 0 (- width (length string))))
161      string))
162
163(defun help-command (ignored)
164  (format t "~%  COMMAND     ABBR DESCRIPTION~%")
165  (dolist (entry *command-table*)
166    (format t "  ~A~A~A~%"
167            (pad (entry-name entry) 12)
168            (pad (entry-abbr entry) 5)
169            (entry-help entry)
170            ))
171  (format t "~%Commands must be prefixed by the command character, which is '~A' by default.~%~%"
172          *command-char*))
173
174(defparameter *command-table*
175  '(("apropos" 2 apropos-command "show apropos")
176    ("bt" 2 backtrace-command "backtrace n stack frames (default all)")
177    ("cd" 2 cd-command "change default directory")
178    ("continue" 4 continue-command "invoke restart n")
179    ("describe" 2 describe-command "describe an object")
180    ("error" 3 error-command "print the current error message")
181    ("exit" 2 exit-command "exit lisp")
182    ("help" 2 help-command "print this help")
183    ("inspect" 2 inspect-command "inspect an object")
184    ("ld" 2 ld-command "load a file")
185    ("macroexpand" 2 macroexpand-command "macroexpand an expression")
186    ("package" 2 package-command "change current package")
187    ("pwd" 3 pwd-command "print current directory")
188    ("reset" 3 reset-command "return to top level")
189    ))
190
191(defun entry-name (entry)
192  (first entry))
193
194(defun entry-min-len (entry)
195  (second entry))
196
197(defun entry-abbr (entry)
198  (if (< (entry-min-len entry) (length (entry-name entry)))
199      (subseq (entry-name entry) 0 (entry-min-len entry))
200      ""))
201
202(defun entry-command (entry)
203  (third entry))
204
205(defun entry-help (entry)
206  (fourth entry))
207
208(defun find-command (string)
209  (let ((len (length string)))
210    (dolist (entry *command-table*)
211      (let ((min-len (entry-min-len entry)))
212        (when (and (>= len min-len)
213                   (string-equal (entry-name entry) string :end1 len))
214          (return (entry-command entry)))))))
215
216(defun process-cmd (form)
217  (when (and (stringp form)
218             (> (length form) 1)
219             (eql (char form 0) *command-char*))
220    (let* ((pos (position #\space form))
221           (cmd (subseq form 1 pos))
222           (args (if pos (subseq form (1+ pos)) nil)))
223      (when args
224        (setf args (string-trim " " args))
225        (when (zerop (length args))
226          (setf args nil)))
227      (let ((fun (find-command cmd)))
228        (if fun
229            (funcall fun args)
230            (%format t "Unknown top-level command ~S.~%" cmd)))
231      (return-from process-cmd t)))
232  nil)
233
234(defun read-cmd (stream)
235  (let ((c (peek-char-non-whitespace stream)))
236    (if (eql c *command-char*)
237        (read-line stream)
238        (read stream nil))))
239
240(defun repl-read-form-fun (in out)
241  (loop
242    (let ((form (read-cmd in)))
243      (setf (charpos out) 0)
244      (incf *cmd-number*)
245      (cond ((process-cmd form)
246             (funcall *repl-prompt-fun* *standard-output*)
247             (finish-output *standard-output*))
248            ((and (> *debug-level* 0)
249                  (fixnump form))
250             (let ((n form)
251                   (restarts (compute-restarts)))
252               (if (< -1 n (length restarts))
253                   (invoke-restart (nth n restarts))
254                   (return form))))
255            (t
256             (return form))))))
257
258(defparameter *repl-read-form-fun* #'repl-read-form-fun)
259
260(defun repl ()
261  (loop
262    (funcall *repl-prompt-fun* *standard-output*)
263    (finish-output *standard-output*)
264    (let* ((form (funcall *repl-read-form-fun*
265                          *standard-input*
266                          *standard-output*))
267           (results (multiple-value-list (sys::interactive-eval form))))
268      (dolist (result results)
269        (fresh-line)
270        (prin1 result)))))
271
272(defun top-level-loop ()
273  (fresh-line)
274  (%format t "Type :HELP for a list of available commands.~%")
275  (loop
276      (with-simple-restart (top-level
277                            "Return to top level.")
278        #+j
279        (handler-case
280            (repl)
281          (stream-error (c) (return-from top-level-loop)))
282        #-j
283        (repl))))
Note: See TracBrowser for help on using the repository browser.