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

Last change on this file since 5123 was 5123, checked in by piso, 18 years ago

PACKAGE-COMMAND

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