|
0
|
1 ;;; cmdloop.el
|
|
|
2 ;; Copyright (C) 1992, 1993 Free Software Foundation, Inc.
|
|
|
3
|
|
|
4 ;; This file is part of XEmacs.
|
|
|
5
|
|
|
6 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
7 ;; under the terms of the GNU General Public License as published by
|
|
|
8 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
9 ;; any later version.
|
|
|
10
|
|
|
11 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
12 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
14 ;; General Public License for more details.
|
|
|
15
|
|
|
16 ;; You should have received a copy of the GNU General Public License
|
|
|
17 ;; along with XEmacs; see the file COPYING. If not, write to the Free
|
|
|
18 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
19
|
|
|
20 ;;; Synched up with: Not in FSF.
|
|
|
21
|
|
|
22 ;; Written by Richard Mlynarik 8-Jul-92
|
|
|
23
|
|
|
24 ;; Putting this in lisp slows things down.
|
|
|
25
|
|
|
26 (defun recursive-edit ()
|
|
|
27 "Invoke the editor command loop recursively.
|
|
|
28 To get out of the recursive edit, a command can do `(throw 'exit nil)';
|
|
|
29 that tells this function to return.
|
|
|
30 Alternately, `(throw 'exit t)' makes this function signal an error."
|
|
|
31 (interactive)
|
|
|
32 (let ((command-loop-level (1+ command-loop-level)))
|
|
|
33 (redraw-modeline)
|
|
|
34 (let ((_buf (and (not (eq (current-buffer)
|
|
|
35 (window-buffer (selected-window))))
|
|
|
36 (current-buffer))))
|
|
|
37 (unwind-protect
|
|
|
38 ;; command_loop
|
|
|
39 (if (catch 'exit
|
|
|
40 (let ((standard-output t)
|
|
|
41 (standard-input t))
|
|
|
42 ;; command_loop_2
|
|
|
43 (while t (funcall command-loop t))))
|
|
|
44 ;; turn abort-recursive-edit into a quit
|
|
|
45 (signal 'quit '()))
|
|
|
46 (if _buf (set-buffer _buf))
|
|
|
47 (redraw-modeline)))
|
|
|
48 nil))
|
|
|
49
|
|
|
50 ;; We demand lexical scope!
|
|
|
51 (defun command-loop (_catch_errors)
|
|
|
52 "This function is the default value of the variable command-loop."
|
|
|
53 (setq prefix-arg nil)
|
|
|
54 (setq last-command 't)
|
|
|
55 (cond ((not _catch_errors)
|
|
|
56 (command-loop-1))
|
|
|
57 ((> (recursion-depth) 0)
|
|
|
58 (while (condition-case e
|
|
|
59 (command-loop-1)
|
|
|
60 (t (command-error e) t))))
|
|
|
61 (t
|
|
|
62 (if (not (null top-level))
|
|
|
63 ;; On entry to the outer level, run the startup file
|
|
|
64 (condition-case e
|
|
|
65 (catch 'top-level
|
|
|
66 (eval top-level))
|
|
|
67 (t (command-error e))))
|
|
|
68
|
|
|
69 ;; If an error occurred during startup and the initial device
|
|
|
70 ;; wasn't created, then die now (the error was already printed out
|
|
|
71 ;; on the terminal device).
|
|
|
72 (if (and (not (noninteractive))
|
|
|
73 (or (not (devicep (selected-device)))
|
|
|
74 (eq 'terminal (device-type (selected-device)))))
|
|
|
75 (kill-emacs -1))
|
|
|
76
|
|
|
77 ;; End of -batch run causes exit here.
|
|
|
78 (if (noninteractive)
|
|
|
79 (kill-emacs t))
|
|
|
80
|
|
|
81 (catch 'top-level
|
|
|
82 (while (condition-case e
|
|
|
83 (command-loop-1)
|
|
|
84 (t (command-error e) t)))))))
|
|
|
85
|
|
|
86 ;; Putting this in lisp slows things down a lot; see also comment above.
|
|
|
87 ;(defun command-loop-1 ()
|
|
|
88 ; (let ((_event (allocate-event))
|
|
|
89 ; (_old-command-loop command-loop)
|
|
|
90 ; ;; We deal with quits ourself
|
|
|
91 ; (_old-inhibit-quit inhibit-quit)
|
|
|
92 ; (inhibit-quit t))
|
|
|
93 ;
|
|
|
94 ; ;; ## cancel_echoing();
|
|
|
95 ;
|
|
|
96 ; ;; This magically makes single character keyboard macros work just
|
|
|
97 ; ;; like the real thing. This is slightly bogus, but it's in here for
|
|
|
98 ; ;; compatibility with Emacs 18.
|
|
|
99 ; ;; It's not even clear what the "right thing" is.
|
|
|
100 ; (and executing-macro
|
|
|
101 ; (eq (length executing-macro) 1)
|
|
|
102 ; (setq last-command 't))
|
|
|
103 ;
|
|
|
104 ; ;; Keep looping until somebody wants a different command-loop
|
|
|
105 ; (while (eq command-loop _old-command-loop)
|
|
|
106 ;
|
|
|
107 ; ;; Make sure current window's buffer is selected.
|
|
|
108 ; (set-buffer (window-buffer (selected-window)))
|
|
|
109 ;
|
|
|
110 ; ;; C code had a `QUIT' here so that if ^G was typed before we got here
|
|
|
111 ; ;; (that is, before emacs was idle and waiting for input) then we treat
|
|
|
112 ; ;; that as an interrupt. The easiest way to do that here is to make a
|
|
|
113 ; ;; function call (but pick one the compiler won't optimize away...)
|
|
|
114 ; (let ((inhibit-quit _old-inhibit-quit)) (eval nil))
|
|
|
115 ;
|
|
|
116 ; ;; This condition-case was originally just wrapped around the
|
|
|
117 ; ;; call to dispatch-event, but in fact we can have errors signalled
|
|
|
118 ; ;; by process-filters in either sit-for and next-event. Those errors
|
|
|
119 ; ;; shouldn't be fatal to the command-loop, so we put the condition-case
|
|
|
120 ; ;; here and hope we're not hiding other bugs in the process.
|
|
|
121 ; (condition-case e
|
|
|
122 ; (progn
|
|
|
123 ; (if (and (> (minibuffer-depth) 0)
|
|
|
124 ; (message-displayed-p))
|
|
|
125 ; (progn
|
|
|
126 ; (sit-for 2)
|
|
|
127 ; (message nil)))
|
|
|
128 ;
|
|
|
129 ; (next-event _event)
|
|
|
130 ; ;; If ^G was typed while emacs was reading input from the user,
|
|
|
131 ; ;; then it is treated as just another key. This is what v18
|
|
|
132 ; ;; did. This is bogus because it gives the illusion that one
|
|
|
133 ; ;; can bind commands to sequences involving ^G, when really one
|
|
|
134 ; ;; can only execute those sequences in non-typeahead contexts.
|
|
|
135 ; (setq quit-flag nil)
|
|
|
136 ;
|
|
|
137 ; (let ((inhibit-quit _old-inhibit-quit))
|
|
|
138 ; (dispatch-event _event))
|
|
|
139 ;
|
|
|
140 ; ;; check for bogus code trying to use the old method of unreading.
|
|
|
141 ; (if (globally-boundp 'unread-command-char)
|
|
|
142 ; (progn
|
|
|
143 ; (makunbound 'unread-command-char)
|
|
|
144 ; (error
|
|
|
145 ; "%S set unread-command-char instead of unread-command-event."
|
|
|
146 ; this-command)))
|
|
|
147 ; )
|
|
|
148 ; (t
|
|
|
149 ; (command-error e))))))
|
|
|
150
|
|
|
151 (setq-default command-loop 'command-loop)
|
