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

Contents of /src/hemlock/main.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5