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

Last change on this file since 4198 was 4198, checked in by piso, 19 years ago

Work in progress.

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