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

Last change on this file since 4079 was 4079, checked in by piso, 20 years ago

Work in progress.

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