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

Last change on this file since 12926 was 12926, checked in by vvoutilainen, 11 years ago

This patch fixes these two issues in ABCL 0.22.0:

1) Keyword evaluation in the repl is broken. The repl assumes all
keywords are, in fact, repl commands.

2) Repl commands are case sensitive: :help :HELP mean two different things.

Patch by Mahmud Mohamed. On behalf of abcl developers, welcome aboard!

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