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

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

Work in progress.

File size: 6.8 KB
Line 
1;;; top-level.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: top-level.lisp,v 1.3 2003-10-04 10:53:26 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 "EXTENSIONS")
23
24(export '(*saved-backtrace*))
25
26(defvar *saved-backtrace* nil)
27
28(in-package "TOP-LEVEL")
29
30(defvar *break-level* 0)
31
32(defparameter *command-char* #\:)
33
34(defvar *cmd-number* 1
35  "Number of the next command")
36
37(defun prompt-package-name ()
38  (car (sort (append
39              (package-nicknames cl:*package*)
40              (list (package-name cl:*package*)))
41             (lambda (a b) (< (length a) (length b))))))
42
43(defun repl-prompt-fun (stream)
44  (fresh-line stream)
45  (when (> *break-level* 0)
46    (format stream "[~D] " *break-level*))
47  (write-string (prompt-package-name) stream)
48  (write-string "(" stream)
49  (princ *cmd-number* stream)
50  (write-string "): " stream))
51
52(defparameter *repl-prompt-fun* #'repl-prompt-fun)
53
54(defvar *last-files-loaded* nil)
55
56(defun peek-char-non-whitespace (stream)
57  (loop
58    (let ((c (read-char stream nil)))
59      (unless (eql c #\Space)
60        (unread-char c stream)
61        (return c)))))
62
63(defun read-cmd (stream)
64  (let ((c (peek-char-non-whitespace stream)))
65    (if (eql c *command-char*)
66        (read-line stream)
67        (read stream nil))))
68
69(defun tokenize (string)
70  (do* ((res nil)
71        (string (string-left-trim " " string)
72                (string-left-trim " " (subseq string end)))
73        (end (position #\Space string) (position #\Space string)))
74       ((zerop (length string)) (nreverse res))
75    (unless end
76      (setf end (length string)))
77    (push (subseq string 0 end) res)))
78
79(defun backtrace-command (&optional count)
80  (let ((count (if (fixnump count) count 7))
81        (n 0))
82    (dolist (frame *saved-backtrace*)
83      (format t "  ~D: ~A~%" n frame)
84      (incf n)
85      (when (>= n count)
86        (return))))
87  (values))
88
89(defun continue-command ()
90  (if (> *break-level* 0)
91      (throw 'continue-catcher nil)))
92
93(defun reset-command ()
94  (throw 'top-level-catcher nil))
95
96(defun process-cmd (form)
97  (when (and (stringp form) (> (length form) 1) (eql (char form 0) *command-char*))
98    (let* ((pos (position #\Space form))
99           (cmd (subseq form 1 pos))
100           (args (if pos (subseq form (1+ pos)) nil)))
101      (when args
102        (setf args (string-trim " " args))
103        (when (zerop (length args))
104          (setf args nil)))
105      (cond ((string-equal cmd "ld")
106             (let ((files (if args (tokenize args) *last-files-loaded*)))
107               (setf *last-files-loaded* files)
108               (dolist (file files)
109                 (load file)))
110             )
111            ((string-equal cmd "de")
112             (let ((obj (eval (read-from-string args))))
113               (describe obj)))
114            ((string-equal cmd "ap")
115             (apropos args))
116            ((string-equal cmd "pwd")
117             (format t "~A~%" *default-pathname-defaults*))
118            ((string-equal cmd "cd")
119             (cond ((or (null args) (string= args "~"))
120                    (setf args (namestring (user-homedir-pathname))))
121                   ((and (> (length args) 1) (string= (subseq args 0 2) "~/")
122                    (setf args (concatenate 'string
123                                            (namestring (user-homedir-pathname))
124                                            (subseq args 2))))))
125             (let ((dir (probe-directory args)))
126               (if dir
127                   (progn
128                     (setf *default-pathname-defaults* dir)
129                     (format *standard-output* "~A" (namestring *default-pathname-defaults*)))
130                   (format *standard-output* "Error: no such directory (~S).~%" args))))
131            ((string-equal cmd "bt")
132             (let ((count (or (and args (ignore-errors (parse-integer args))) most-positive-fixnum)))
133               (backtrace-command count)))
134            ((string-equal cmd "pa")
135             (cond ((null args)
136                    (format *standard-output* "The ~A package is current.~%"
137                            (package-name *package*)))
138                   (t
139                    (when (and (plusp (length args)) (eql (char args 0) #\:))
140                      (setf args (subseq args 1)))
141                    (setf args (nstring-upcase args))
142                    (let ((pkg (find-package args)))
143                      (if pkg
144                          (setf *package* pkg)
145                          (format *standard-output* "Unknown package ~A.~%" args))))))
146            ((or (string-equal cmd "cont") (string-equal cmd "continue"))
147             (continue-command))
148            ((or (string-equal cmd "res") (string-equal cmd "reset"))
149             (reset-command))
150            ((string-equal cmd "ex")
151             (format t "Bye!~%")
152             (exit))
153            (t
154             (format *standard-output* "Unknown top-level command ~S.~%" cmd)
155             )))
156    (return-from process-cmd t))
157  nil)
158
159(defun repl-read-form-fun (in out)
160  (loop
161    (let ((form (read-cmd in)))
162      (setf (charpos out) 0)
163      (incf *cmd-number*)
164      (cond ((process-cmd form)
165             (funcall *repl-prompt-fun* *standard-output*)
166             (finish-output *standard-output*))
167            (t
168             (return form))))))
169
170(defparameter *repl-read-form-fun* #'repl-read-form-fun)
171
172(defun interactive-eval (form)
173  (setf - form)
174  (let ((results (multiple-value-list (eval form))))
175    (setf /// //
176    // /
177    / results
178    *** **
179    ** *
180    * (car results)))
181  (setf +++ ++
182  ++ +
183  + -)
184  (values-list /))
185
186(defun repl ()
187  (loop
188    (funcall *repl-prompt-fun* *standard-output*)
189    (finish-output *standard-output*)
190    (let* ((form (funcall *repl-read-form-fun*
191                          *standard-input*
192                          *standard-output*))
193           (results (multiple-value-list (interactive-eval form))))
194      (dolist (result results)
195        (fresh-line)
196        (prin1 result)))))
197
198(defun top-level-loop ()
199  (loop
200    (catch 'top-level-catcher
201      (handler-case
202          (repl)
203        (stream-error (c) (return-from top-level-loop))
204        (error (c) (format t "Error: ~S.~%" c) (break) (throw 'top-level-catcher nil))))))
Note: See TracBrowser for help on using the repository browser.