/[cmucl]/src/hemlock/main.lisp
ViewVC logotype

Contents of /src/hemlock/main.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Fri Jul 13 15:13:46 1990 UTC (23 years, 9 months ago) by ram
Branch: MAIN
Changes since 1.1: +1 -2 lines
*** empty log message ***
1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice Lisp project at
5 ;;; Carnegie-Mellon University, and has been placed in the public domain.
6 ;;; Spice Lisp is currently incomplete and under active development.
7 ;;; If you want to use this code or any part of Spice Lisp, please contact
8 ;;; Scott Fahlman (FAHLMAN@CMUC).
9 ;;; **********************************************************************
10 ;;;
11 ;;; Hemlock initialization code and random debugging stuff.
12 ;;;
13 ;;; Written by Bill Chiles and Rob MacLachlan
14 ;;;
15
16 (in-package "HEMLOCK-INTERNALS")
17
18 (export '(*global-variable-names* *mode-names* *buffer-names*
19 *character-attribute-names* *command-names* *buffer-list*
20 *window-list* *last-key-event-typed* after-editor-initializations))
21
22
23 (in-package "EXTENSIONS")
24 (export '(save-all-buffers *hemlock-version*))
25 (in-package "HEMLOCK-INTERNALS")
26
27
28
29 ;;;; Definition of *hemlock-version*.
30
31 (defvar *hemlock-version* "1.1(?)")
32
33
34
35 ;;;; %INIT-HEMLOCK.
36
37 (defun %init-hemlock ()
38 "Initialize hemlock's internal data structures."
39 ;;
40 ;; This function is defined in Buffer.Lisp. It creates fundamental mode
41 ;; and the buffer main. Until this is done it is not possible to define
42 ;; or use Hemlock variables.
43 (setup-initial-buffer)
44 ;;
45 ;; Define some of the system variables.
46 (define-some-variables)
47 ;;
48 ;; Site initializations such as window system variables.
49 (site-init)
50 ;;
51 ;; Set up syntax table data structures.
52 (%init-syntax-table)
53 ;;
54 ;; Define print representations for funny characters.
55 (%init-line-image))
56
57
58
59 ;;;; Define some globals.
60
61 ;;; These globals cannot be defined in the appropriate file due to compilation
62 ;;; or load time constraints.
63 ;;;
64
65 ;;; The following belong in other files, but those files are loaded before
66 ;;; table.lisp which defines MAKE-STRING-TABLE.
67 ;;;
68 ;;; vars.lisp
69 (defvar *global-variable-names* (make-string-table)
70 "A String Table of global variable names, the values are the symbol names.")
71 ;;;
72 ;;; buffer.lisp
73 (defvar *mode-names* (make-string-table) "A String Table of Mode names.")
74 (defvar *buffer-names* (make-string-table)
75 "A String Table of Buffer names and their corresponding objects.")
76 ;;;
77 ;;; interp.lisp
78 (defvar *command-names* (make-string-table) "String table of command names.")
79 ;;;
80 ;;; syntax.lisp
81 (defvar *character-attribute-names* (make-string-table)
82 "String Table of character attribute names and their corresponding keywords.")
83
84
85
86 ;;;; DEFINE-SOME-VARIABLES.
87
88 ;;; This is necessary to define "Default Status Line Fields" which belongs
89 ;;; beside the other modeline variables. This DEFVAR would live in
90 ;;; Morecoms.Lisp, but it is compiled and loaded after this file.
91 ;;;
92 (proclaim '(special ed::*recursive-edit-count*))
93 ;;;
94 (make-modeline-field
95 :name :edit-level :width 15
96 :function #'(lambda (buffer window)
97 (declare (ignore buffer window))
98 (if (zerop ed::*recursive-edit-count*)
99 ""
100 (format nil "Edit Level: ~2,'0D "
101 ed::*recursive-edit-count*))))
102
103 ;;; This is necessary to define "Default Status Line Fields" which belongs
104 ;;; beside the other modeline variables. This DEFVAR would live in
105 ;;; Completion.Lisp, but it is compiled and loaded after this file.
106 ;;;
107 (proclaim '(special ed::*completion-mode-possibility*))
108 ;;; Hack for now until completion mode is added.
109 (defvar ed::*completion-mode-possibility* "")
110 ;;;
111 (make-modeline-field
112 :name :completion :width 40
113 :function #'(lambda (buffer window)
114 (declare (ignore buffer window))
115 ed::*completion-mode-possibility*))
116
117
118 (defun define-some-variables ()
119 (defhvar "Default Modes"
120 "This variable contains the default list of modes for new buffers."
121 :value '("Fundamental" "Save"))
122 (defhvar "Echo Area Height"
123 "Number of lines in the echo area window."
124 :value 3)
125 (defhvar "Make Buffer Hook"
126 "This hook is called with the new buffer whenever a buffer is created.")
127 (defhvar "Delete Buffer Hook"
128 "This hook is called with the buffer whenever a buffer is deleted.")
129 (defhvar "Enter Recursive Edit Hook"
130 "This hook is called with the new buffer when a recursive edit is
131 entered.")
132 (defhvar "Exit Recursive Edit Hook"
133 "This hook is called with the value returned when a recursive edit
134 is exited.")
135 (defhvar "Abort Recursive Edit Hook"
136 "This hook is called with the editor-error args when a recursive
137 edit is aborted.")
138 (defhvar "Buffer Major Mode Hook"
139 "This hook is called with the buffer and the new mode when a buffer's
140 major mode is changed.")
141 (defhvar "Buffer Minor Mode Hook"
142 "This hook is called a minor mode is changed. The arguments are
143 the buffer, the mode affected and T or NIL depending on when the
144 mode is being turned on or off.")
145 (defhvar "Buffer Writable Hook"
146 "This hook is called whenever someone sets whether the buffer is
147 writable.")
148 (defhvar "Buffer Name Hook"
149 "This hook is called with the buffer and the new name when the name of a
150 buffer is changed.")
151 (defhvar "Buffer Pathname Hook"
152 "This hook is called with the buffer and the new Pathname when the Pathname
153 associated with the buffer is changed.")
154 (defhvar "Buffer Modified Hook"
155 "This hook is called whenever a buffer changes from unmodified to modified
156 and vice versa. It takes the buffer and the new value for modification
157 flag.")
158 (defhvar "Set Buffer Hook"
159 "This hook is called with the new buffer when the current buffer is set.")
160 (defhvar "After Set Buffer Hook"
161 "This hook is invoked with the old buffer after the current buffer has
162 been changed.")
163 (defhvar "Set Window Hook"
164 "This hook is called with the new window when the current window
165 is set.")
166 (defhvar "Make Window Hook"
167 "This hook is called with a new window when one is created.")
168 (defhvar "Delete Window Hook"
169 "This hook is called with a window before it is deleted.")
170 (defhvar "Window Buffer Hook"
171 "This hook is invoked with the window and new buffer when a window's
172 buffer is changed.")
173 (defhvar "Delete Variable Hook"
174 "This hook is called when a variable is deleted with the args to
175 delete-variable.")
176 (defhvar "Entry Hook"
177 "this hook is called when the editor is entered.")
178 (defhvar "Exit Hook"
179 "This hook is called when the editor is exited.")
180 (defhvar "Redisplay Hook"
181 "This is called on the current window from REDISPLAY after checking the
182 window display start, window image, and recentering. After calling the
183 functions in this hook, we do the above stuff and call the smart
184 redisplay method for the device."
185 :value nil)
186 (defhvar "Key Echo Delay"
187 "Wait this many seconds before echoing keys in the command loop. This
188 feature is inhibited when nil."
189 :value 1.0)
190 (defhvar "Input Hook"
191 "The functions in this variable are invoked each time a character enters
192 Hemlock."
193 :value nil)
194 (defhvar "Abort Hook"
195 "These functions are invoked when ^G is typed. No arguments are passed."
196 :value nil)
197 (defhvar "Command Abort Hook"
198 "These functions get called when commands are aborted, such as with
199 EDITOR-ERROR."
200 :value nil)
201 (defhvar "Character Attribute Hook"
202 "This hook is called with the attribute, character and new value
203 when the value of a character attribute is changed.")
204 (defhvar "Shadow Attribute Hook"
205 "This hook is called when a mode character attribute is made.")
206 (defhvar "Unshadow Attribute Hook"
207 "This hook is called when a mode character attribute is deleted.")
208 (defhvar "Default Modeline Fields"
209 "The default list of modeline-fields for MAKE-WINDOW."
210 :value *default-modeline-fields*)
211 (defhvar "Default Status Line Fields"
212 "This is the default list of modeline-fields for the echo area window's
213 modeline which is used for general information."
214 :value (list (make-modeline-field
215 :name :hemlock-banner :width 26
216 :function #'(lambda (buffer window)
217 (declare (ignore buffer window))
218 (format nil "Hemlock ~A "
219 *hemlock-version*)))
220 (modeline-field :edit-level)
221 (modeline-field :completion)))
222 (defhvar "Maximum Modeline Pathname Length"
223 "When set, this variable is the maximum length of the display of a pathname
224 in a modeline. When the pathname is too long, the :buffer-pathname
225 modeline-field function chops off leading directory specifications until
226 the pathname fits. \"...\" indicates a truncated pathname."
227 :value nil
228 :hooks (list 'maximum-modeline-pathname-length-hook)))
229
230
231
232 ;;;; ED.
233
234 (defvar *editor-has-been-entered* ()
235 "True if and only if the editor has been entered.")
236 (defvar *in-the-editor* ()
237 "True if we are inside the editor. This is used to prevent ill-advised
238 \"recursive\" edits.")
239
240 (defvar *after-editor-initializations-funs* nil
241 "A list of functions to be called after the editor has been initialized upon
242 entering the first time.")
243
244 (defmacro after-editor-initializations (&rest forms)
245 "Causes forms to be executed after the editor has been initialized.
246 Forms supplied with successive uses of this macro will be executed after
247 forms supplied with previous uses."
248 `(push #'(lambda () ,@forms)
249 *after-editor-initializations-funs*))
250
251 (defun ed (&optional x
252 &key (init t)
253 (display (cdr (assoc :display ext:*environment-list*))))
254 "Invokes the editor, Hemlock. If X is supplied and is a symbol, the
255 definition of X is put into a buffer, and that buffer is selected. If X
256 is a pathname, the file specified by X is visited in a new buffer. If X
257 is not supplied or Nil, the editor is entered in the same state as when
258 last exited. When :init is supplied as t (the default), the file
259 \"hemlock-init.fasl\" or \"hemlock-init.lisp\" is loaded from the home or
260 default directory, but the Lisp command line switch -hinit can be used to
261 specify a different name. If the argument is non-nil and not t, then it
262 should be a pathname that will be merged with the home or default directory.
263 The display argument is not currently supported."
264 (when *in-the-editor* (error "You are already in the editor, you bogon!"))
265 (let ((*in-the-editor* t)
266 (display (unless *editor-has-been-entered*
267 (maybe-load-hemlock-init init)
268 ;; Device dependent initializaiton.
269 (init-raw-io display))))
270 (catch 'editor-top-level-catcher
271 (site-wrapper-macro
272 (unless *editor-has-been-entered*
273 ;; Make an initial window, and set up redisplay's internal
274 ;; data structures.
275 (%init-redisplay display)
276 (setq *editor-has-been-entered* t)
277 ;; Pick up user initializations to be done after initialization.
278 (invoke-hook (reverse *after-editor-initializations-funs*)))
279 (catch 'hemlock-exit
280 (catch 'editor-top-level-catcher
281 (cond ((and x (symbolp x))
282 (let* ((name (nstring-capitalize
283 (concatenate 'simple-string "Edit " (string x))))
284 (buffer (or (getstring name *buffer-names*)
285 (make-buffer name)))
286 (*print-case* :downcase))
287 (delete-region (buffer-region buffer))
288 (with-output-to-mark
289 (*standard-output* (buffer-point buffer))
290 (eval `(grindef ,x)) ; hackish, I know...
291 (terpri)
292 (ed::change-to-buffer buffer)
293 (buffer-start (buffer-point buffer)))))
294 ((or (stringp x) (pathnamep x))
295 (ed::find-file-command () x))
296 (x
297 (error
298 "~S is not a symbol or pathname. I can't edit it!" x))))
299
300 (invoke-hook ed::entry-hook)
301 (unwind-protect
302 (loop
303 (catch 'editor-top-level-catcher
304 (handler-bind ((error #'(lambda (condition)
305 (lisp-error-error-handler condition
306 :internal))))
307 (invoke-hook ed::abort-hook)
308 (%command-loop))))
309 (invoke-hook ed::exit-hook)))))))
310
311 (defun maybe-load-hemlock-init (init)
312 (when init
313 (let* ((name (case init
314 ((t) (let ((switch (find "hinit" *command-line-switches*
315 :test #'string-equal
316 :key #'cmd-switch-name)))
317 (if switch
318 (or (cmd-switch-value switch)
319 (car (cmd-switch-words switch))
320 "hemlock-init")
321 "hemlock-init")))
322 (t (pathname init)))))
323 (load (merge-pathnames name (user-homedir-pathname))
324 :if-does-not-exist nil))))
325
326
327
328 ;;;; SAVE-ALL-BUFFERS.
329
330 (defun save-all-buffers (&optional (list-unmodified-buffers nil))
331 (dolist (buffer *buffer-list*)
332 (when (or list-unmodified-buffers (buffer-modified buffer))
333 (maybe-save-buffer buffer))))
334
335 (defun maybe-save-buffer (buffer)
336 (let* ((modified (buffer-modified buffer))
337 (pathname (buffer-pathname buffer))
338 (name (buffer-name buffer))
339 (string (if pathname (namestring pathname))))
340 (format t "Buffer ~S is ~:[UNmodified~;modified~], Save it? "
341 name modified)
342 (when (y-or-n-p)
343 (let ((name (read-line-default "File to write" string)))
344 (format t "Writing file ~A..." name)
345 (force-output)
346 (write-file (buffer-region buffer) name)
347 (write-line "write WON")))))
348
349 (defun read-line-default (prompt default)
350 (format t "~A:~@[ [~A]~] " prompt default)
351 (do ((result (read-line) (read-line)))
352 (())
353 (declare (simple-string result))
354 (when (plusp (length result)) (return result))
355 (when default (return default))
356 (format t "~A:~@[ [~A]~] " prompt default)))

  ViewVC Help
Powered by ViewVC 1.1.5