home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / prim / cmdloop1.el < prev    next >
Encoding:
Text File  |  1995-05-12  |  5.6 KB  |  150 lines
  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. ;; Written by Richard Mlynarik 8-Jul-92
  21.  
  22. ;; Putting this in lisp slows things down.
  23.  
  24. (defun recursive-edit ()
  25.   "Invoke the editor command loop recursively.
  26. To get out of the recursive edit, a command can do `(throw 'exit nil)';
  27. that tells this function to return.
  28. Alternately, `(throw 'exit t)' makes this function signal an error."
  29.   (interactive)
  30.   (let ((command-loop-level (1+ command-loop-level)))
  31.     (redraw-modeline)
  32.     (let ((_buf (and (not (eq (current-buffer)
  33.                   (window-buffer (selected-window))))
  34.              (current-buffer))))
  35.       (unwind-protect
  36.            ;; command_loop
  37.            (if (catch 'exit
  38.                  (let ((standard-output t)
  39.                        (standard-input t))
  40.                    ;; command_loop_2
  41.                    (while t (funcall command-loop t))))
  42.                ;; turn abort-recursive-edit into a quit
  43.                (signal 'quit '()))
  44.         (if _buf (set-buffer _buf))
  45.         (redraw-modeline)))
  46.     nil))
  47.  
  48. ;; We demand lexical scope!
  49. (defun command-loop (_catch_errors)
  50.   "This function is the default value of the variable command-loop."
  51.   (setq prefix-arg nil)
  52.   (setq last-command 't)
  53.   (cond ((not _catch_errors)
  54.          (command-loop-1))
  55.         ((> (recursion-depth) 0)
  56.          (while (condition-case e
  57.                     (command-loop-1)
  58.                   (t (command-error e) t))))
  59.         (t
  60.          (if (not (null top-level))
  61.              ;; On entry to the outer level, run the startup file
  62.              (condition-case e
  63.                  (catch 'top-level
  64.                    (eval top-level))
  65.                (t (command-error e))))
  66.  
  67.      ;; If an error occurred during startup and the initial device
  68.      ;; wasn't created, then die now (the error was already printed out
  69.      ;; on the terminal device).
  70.      (if (and (not (noninteractive))
  71.           (or (not (devicep (selected-device)))
  72.               (eq 'terminal (device-type (selected-device)))))
  73.          (kill-emacs -1))
  74.  
  75.      ;; End of -batch run causes exit here.
  76.          (if (noninteractive)
  77.              (kill-emacs t))
  78.  
  79.          (catch 'top-level
  80.            (while (condition-case e
  81.                       (command-loop-1)
  82.                     (t (command-error e) t)))))))
  83.  
  84. ;; Putting this in lisp slows things down a lot; see also comment above.
  85. ;(defun command-loop-1 ()
  86. ;  (let ((_event (allocate-event))
  87. ;      (_old-command-loop command-loop)
  88. ;      ;; We deal with quits ourself
  89. ;      (_old-inhibit-quit inhibit-quit)
  90. ;      (inhibit-quit t))
  91. ;
  92. ;  ;; ## cancel_echoing();
  93. ;
  94. ;  ;; This magically makes single character keyboard macros work just
  95. ;  ;; like the real thing.  This is slightly bogus, but it's in here for
  96. ;  ;; compatibility with Emacs 18.
  97. ;  ;; It's not even clear what the "right thing" is.
  98. ;  (and executing-macro
  99. ;       (eq (length executing-macro) 1)
  100. ;       (setq last-command 't))
  101. ;
  102. ;  ;; Keep looping until somebody wants a different command-loop
  103. ;  (while (eq command-loop _old-command-loop)
  104. ;
  105. ;    ;; Make sure current window's buffer is selected.
  106. ;    (set-buffer (window-buffer (selected-window)))
  107. ;
  108. ;    ;; C code had a `QUIT' here so that if ^G was typed before we got here
  109. ;    ;; (that is, before emacs was idle and waiting for input) then we treat
  110. ;    ;; that as an interrupt.  The easiest way to do that here is to make a
  111. ;    ;; function call (but pick one the compiler won't optimize away...)
  112. ;    (let ((inhibit-quit _old-inhibit-quit)) (eval nil))
  113. ;
  114. ;    ;; This condition-case was originally just wrapped around the
  115. ;    ;;  call to dispatch-event, but in fact we can have errors signalled
  116. ;    ;;  by process-filters in either sit-for and next-event.  Those errors
  117. ;    ;;  shouldn't be fatal to the command-loop, so we put the condition-case
  118. ;    ;;  here and hope we're not hiding other bugs in the process.
  119. ;    (condition-case e
  120. ;        (progn
  121. ;          (if (and (> (minibuffer-depth) 0)
  122. ;                   (message-displayed-p))
  123. ;              (progn
  124. ;                (sit-for 2)
  125. ;                (message nil)))
  126. ;
  127. ;          (next-event _event)
  128. ;          ;; If ^G was typed while emacs was reading input from the user, 
  129. ;          ;; then it is treated as just another key.  This is what v18
  130. ;          ;; did.  This is bogus because it gives the illusion that one
  131. ;          ;; can bind commands to sequences involving ^G, when really one
  132. ;          ;; can only execute those sequences in non-typeahead contexts.
  133. ;          (setq quit-flag nil)
  134. ;
  135. ;          (let ((inhibit-quit _old-inhibit-quit))
  136. ;            (dispatch-event _event))
  137. ;
  138. ;          ;; check for bogus code trying to use the old method of unreading.
  139. ;          (if (globally-boundp 'unread-command-char)
  140. ;              (progn
  141. ;                (makunbound 'unread-command-char)
  142. ;                (error
  143. ;                 "%S set unread-command-char instead of unread-command-event."
  144. ;           this-command)))
  145. ;        )
  146. ;        (t
  147. ;         (command-error e))))))
  148.  
  149. (setq-default command-loop 'command-loop)
  150.