Mercurial > hg > xemacs-beta
annotate src/event-stream.c @ 5353:38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
lisp/ChangeLog addition:
2011-02-07 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el:
* bytecomp.el (byte-compile-initial-macro-environment):
Shadow `block', `return-from' here, we implement them differently
when byte-compiling.
* bytecomp.el (byte-compile-active-blocks): New.
* bytecomp.el (byte-compile-block-1): New.
* bytecomp.el (byte-compile-return-from-1): New.
* bytecomp.el (return-from-1): New.
* bytecomp.el (block-1): New.
These are two aliases that exist to have their own associated
byte-compile functions, which functions implement `block' and
`return-from'.
* cl-extra.el (cl-macroexpand-all):
Fix a bug here when macros in the environment have been compiled.
* cl-macs.el (block):
* cl-macs.el (return):
* cl-macs.el (return-from):
Be more careful about lexical scope in these macros.
* cl.el:
* cl.el ('cl-block-wrapper): Removed.
* cl.el ('cl-block-throw): Removed.
These aren't needed in code generated by this XEmacs. They
shouldn't be needed in code generated by XEmacs 21.4, but if it
turns out the packages do need them, we can put them back.
2011-01-30 Mike Sperber <mike@xemacs.org>
* font-lock.el (font-lock-fontify-pending-extents): Don't fail if
`font-lock-mode' is unset, which can happen in the middle of
`revert-buffer'.
2011-01-23 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (delete):
* cl-macs.el (delq):
* cl-macs.el (remove):
* cl-macs.el (remq):
Don't use the compiler macro if these functions were given the
wrong number of arguments, as happens in lisp-tests.el.
* cl-seq.el (remove, remq): Removed.
I added these to subr.el, and forgot to remove them from here.
2011-01-22 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-setq, byte-compile-set):
Remove kludge allowing keywords' values to be set, all the code
that does that is gone.
* cl-compat.el (elt-satisfies-test-p):
* faces.el (set-face-parent):
* faces.el (face-doc-string):
* gtk-font-menu.el:
* gtk-font-menu.el (gtk-reset-device-font-menus):
* msw-font-menu.el:
* msw-font-menu.el (mswindows-reset-device-font-menus):
* package-get.el (package-get-installedp):
* select.el (select-convert-from-image-data):
* sound.el:
* sound.el (load-sound-file):
* x-font-menu.el (x-reset-device-font-menus-core):
Don't quote keywords, they're self-quoting, and the
win from backward-compatibility is sufficiently small now that the
style problem overrides it.
2011-01-22 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (block, return-from): Require that NAME be a symbol
in these macros, as always documented in the #'block docstring and
as required by Common Lisp.
* descr-text.el (unidata-initialize-unihan-database):
Correct the use of non-symbols in #'block and #'return-from in
this function.
2011-01-15 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (concatenate): Accept more complicated TYPEs in this
function, handing the sequences over to #'coerce if we don't
understand them here.
* cl-macs.el (inline): Don't proclaim #'concatenate as inline, its
compiler macro is more useful than doing that.
2011-01-11 Aidan Kehoe <kehoea@parhasard.net>
* subr.el (delete, delq, remove, remq): Move #'remove, #'remq
here, they don't belong in cl-seq.el; move #'delete, #'delq here
from fns.c, implement them in terms of #'delete*, allowing support
for sequences generally.
* update-elc.el (do-autoload-commands): Use #'delete*, not #'delq
here, now the latter's no longer dumped.
* cl-macs.el (delete, delq): Add compiler macros transforming
#'delete and #'delq to #'delete* calls.
2011-01-10 Aidan Kehoe <kehoea@parhasard.net>
* dialog.el (make-dialog-box): Correct a misplaced parenthesis
here, thank you Mats Lidell in 87zkr9gqrh.fsf@mail.contactor.se !
2011-01-02 Aidan Kehoe <kehoea@parhasard.net>
* dialog.el (make-dialog-box):
* list-mode.el (display-completion-list):
These functions used to use cl-parsing-keywords; change them to
use defun* instead, fixing the build. (Not sure what led to me
not including this change in d1b17a33450b!)
2011-01-02 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (define-star-compiler-macros):
Make sure the form has ITEM and LIST specified before attempting
to change to calls with explicit tests; necessary for some tests
in lisp-tests.el to compile correctly.
(stable-union, stable-intersection): Add compiler macros for these
functions, in the same way we do for most of the other functions
in cl-seq.el.
2011-01-01 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (dolist, dotimes, do-symbols, macrolet)
(symbol-macrolet):
Define these macros with defmacro* instead of parsing the argument
list by hand, for the sake of style and readability; use backquote
where appropriate, instead of calling #'list and and friends, for
the same reason.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* x-misc.el (device-x-display):
Provide this function, documented in the Lispref for years, but
not existing previously. Thank you Julian Bradfield, thank you
Jeff Mincy.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* cl-seq.el:
Move the heavy lifting from this file to C. Dump the
cl-parsing-keywords macro, but don't use defun* for the functions
we define that do take keywords, dynamic scope lossage makes that
not practical.
* subr.el (sort, fillarray): Move these aliases here.
(map-plist): #'nsublis is now built-in, but at this point #'eql
isn't necessarily available as a test; use #'eq.
* obsolete.el (cl-delete-duplicates): Make this available for old
compiler macros and old code.
(memql): Document that this is equivalent to #'member*, and worse.
* cl.el (adjoin, subst): Removed. These are in C.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* simple.el (assoc-ignore-case): Remove a duplicate definition of
this function (it's already in subr.el).
* iso8859-1.el (char-width):
On non-Mule, make this function equivalent to that produced by
(constantly 1), but preserve its docstring.
* subr.el (subst-char-in-string): Define this in terms of
#'substitute, #'nsubstitute.
(string-width): Define this using #'reduce and #'char-width.
(char-width): Give this a simpler definition, it makes far more
sense to check for mule at load time and redefine, as we do in
iso8859-1.el.
(store-substring): Implement this in terms of #'replace, now
#'replace is cheap.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* update-elc.el (lisp-files-needed-for-byte-compilation)
(lisp-files-needing-early-byte-compilation):
cl-macs belongs in the former, not the latter, it is as
fundamental as bytecomp.el.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* cl.el:
Provde the Common Lisp program-error, type-error as error
symbols. This doesn't nearly go far enough for anyone using the
Common Lisp errors.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (delete-duplicates):
If the form has an incorrect number of arguments, don't attempt a
compiler macroexpansion.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (cl-safe-expr-p):
Forms that start with the symbol lambda are also safe.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (= < > <= >=):
For these functions' compiler macros, the optimisation is safe
even if the first and the last arguments have side effects, since
they're only used the once.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (inline-side-effect-free-compiler-macros):
Unroll a loop here at macro-expansion time, so these compiler
macros are compiled. Use #'eql instead of #'eq in a couple of
places for better style.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (notany, notevery): Avoid some dynamic scope
stupidity with local variable names in these functions, when they
weren't prefixed with cl-; go into some more detail in the doc
strings.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (side-effect-free-fns): #'remove, #'remq are
free of side-effects.
(side-effect-and-error-free-fns):
Drop dot, dot-marker from the list.
2010-11-17 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (coerce):
In the argument list, name the first argument OBJECT, not X; the
former name was always used in the doc string and is clearer.
Handle vector type specifications which include the length of the
target sequence, error if there's a mismatch.
* cl-macs.el (cl-make-type-test): Handle type specifications
starting with the symbol 'eql.
2010-11-14 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (eql): Don't remove the byte-compile property of this
symbol. That was necessary to override a bug in bytecomp.el where
#'eql was confused with #'eq, which bug we no longer have.
If neither expression is constant, don't attempt to handle the
expression in this compiler macro, leave it to byte-compile-eql,
which produces better code anyway.
* bytecomp.el (eq): #'eql is not the function associated with the
byte-eq byte code.
(byte-compile-eql): Add an explicit compile method for this
function, for cases where the cl-macs compiler macro hasn't
reduced it to #'eq or #'equal.
2010-10-25 Aidan Kehoe <kehoea@parhasard.net>
Add compiler macros and compilation sanity-checking for various
functions that take keywords.
* byte-optimize.el (side-effect-free-fns): #'symbol-value is
side-effect free and not error free.
* bytecomp.el (byte-compile-normal-call): Check keyword argument
lists for sanity; store information about the positions where
keyword arguments start using the new byte-compile-keyword-start
property.
* cl-macs.el (cl-const-expr-val): Take a new optional argument,
cl-not-constant, defaulting to nil, in this function; return it if
the expression is not constant.
(cl-non-fixnum-number-p): Make this into a separate function, we
want to pass it to #'every.
(eql): Use it.
(define-star-compiler-macros): Use the same code to generate the
member*, assoc* and rassoc* compiler macros; special-case some
code in #'add-to-list in subr.el.
(remove, remq): Add compiler macros for these two functions, in
preparation for #'remove being in C.
(define-foo-if-compiler-macros): Transform (remove-if-not ...) calls to
(remove ... :if-not) at compile time, which will be a real win
once the latter is in C.
(define-substitute-if-compiler-macros)
(define-subst-if-compiler-macros): Similarly for these functions.
(delete-duplicates): Change this compiler macro to use
#'plists-equal; if we don't have information about the type of
SEQUENCE at compile time, don't bother attempting to inline the
call, the function will be in C soon enough.
(equalp): Remove an old commented-out compiler macro for this, if
we want to see it it's in version control.
(subst-char-in-string): Transform this to a call to nsubstitute or
nsubstitute, if that is appropriate.
* cl.el (ldiff): Don't call setf here, this makes for a load-time
dependency problem in cl-macs.el
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* term/vt100.el:
Refer to XEmacs, not GNU Emacs, in permissions.
* term/bg-mouse.el:
* term/sup-mouse.el:
Put copyright notice in canonical "Copyright DATE AUTHOR" form.
Refer to XEmacs, not GNU Emacs, in permissions.
* site-load.el:
Add permission boilerplate.
* mule/canna-leim.el:
* alist.el:
Refer to XEmacs, not APEL/this program, in permissions.
* mule/canna-leim.el:
Remove my copyright, I've assigned it to the FSF.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* gtk.el:
* gtk-widget-accessors.el:
* gtk-package.el:
* gtk-marshal.el:
* gtk-compose.el:
* gnome.el:
Add copyright notice based on internal evidence.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* easymenu.el: Add reference to COPYING to permission notice.
* gutter.el:
* gutter-items.el:
* menubar-items.el:
Fix typo "Xmacs" in permissions notice.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* auto-save.el:
* font.el:
* fontconfig.el:
* mule/kinsoku.el:
Add "part of XEmacs" text to permission notice.
2010-10-14 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (side-effect-free-fns):
* cl-macs.el (remf, getf):
* cl-extra.el (tailp, cl-set-getf, cl-do-remf):
* cl.el (ldiff, endp):
Tighten up Common Lisp compatibility for #'ldiff, #'endp, #'tailp;
add circularity checking for the first two.
#'cl-set-getf and #'cl-do-remf were Lisp implementations of
#'plist-put and #'plist-remprop; change the names to aliases,
changes the macros that use them to using #'plist-put and
#'plist-remprop directly.
2010-10-12 Aidan Kehoe <kehoea@parhasard.net>
* abbrev.el (fundamental-mode-abbrev-table, global-abbrev-table):
Create both these abbrev tables using the usual
#'define-abbrev-table calls, rather than attempting to
special-case them.
* cl-extra.el: Force cl-macs to be loaded here, if cl-extra.el is
being loaded interpreted. Previously other, later files would
redundantly call (load "cl-macs") when interpreted, it's more
reasonable to do it here, once.
* cmdloop.el (read-quoted-char-radix): Use defcustom here, we
don't have any dump-order dependencies that would prevent that.
* custom.el (eval-when-compile): Don't load cl-macs when
interpreted or when byte-compiling, rely on cl-extra.el in the
former case and the appropriate entry in bytecomp-load-hook in the
latter. Get rid of custom-declare-variable-list, we have no
dump-time dependencies that would require it.
* faces.el (eval-when-compile): Don't load cl-macs when
interpreted or when byte-compiling.
* packages.el: Remove some inaccurate comments.
* post-gc.el (cleanup-simple-finalizers): Use #'delete-if-not
here, now the order of preloaded-file-list has been changed to
make it available.
* subr.el (custom-declare-variable-list): Remove. No need for it.
Also remove a stub define-abbrev-table from this file, given the
current order of preloaded-file-list there's no need for it.
2010-10-10 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-constp) Forms quoted with FUNCTION are
also constant.
(byte-compile-initial-macro-environment): In #'the, if FORM is
constant and does not match TYPE, warn at byte-compile time.
2010-10-10 Aidan Kehoe <kehoea@parhasard.net>
* backquote.el (bq-vector-contents, bq-list*): Remove; the former
is equivalent to (append VECTOR nil), the latter to (list* ...).
(bq-process-2): Use (append VECTOR nil) instead of using
#'bq-vector-contents to convert to a list.
(bq-process-1): Now we use list* instead of bq-list
* subr.el (list*): Moved from cl.el, since it is now required to
be available the first time a backquoted form is encountered.
* cl.el (list*): Move to subr.el.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* test-harness.el (Check-Message):
Add an omitted comma here, thank you the buildbot.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* hash-table.el (hash-table-key-list, hash-table-value-list)
(hash-table-key-value-alist, hash-table-key-value-plist):
Remove some useless #'nreverse calls in these files; our hash
tables have no order, it's not helpful to pretend they do.
* behavior.el (read-behavior):
Do the same in this file, in some code evidently copied from
hash-table.el.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* info.el (Info-insert-dir):
* format.el (format-deannotate-region):
* files.el (cd, save-buffers-kill-emacs):
Use #'some, #'every and related functions for applying boolean
operations to lists, instead of rolling our own ones that cons and
don't short-circuit.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-initial-macro-environment):
* cl-macs.el (the):
Rephrase the docstring, make its implementation when compiling
files a little nicer.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* descr-text.el (unidata-initialize-unicodedata-database)
(unidata-initialize-unihan-database, describe-char-unicode-data)
(describe-char-unicode-data):
Wrap calls to the database functions with (with-fboundp ...),
avoiding byte compile warnings on builds without support for the
database functions.
(describe-char): (reduce #'max ...), not (apply #'max ...), no
need to cons needlessly.
(describe-char): Remove a redundant lambda wrapping
#'extent-properties.
(describe-char-unicode-data): Call #'nsubst when replacing "" with
nil in the result of #'split-string, instead of consing inside
mapcar.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* x-faces.el (x-available-font-sizes):
* specifier.el (let-specifier):
* package-ui.el (pui-add-required-packages):
* msw-faces.el (mswindows-available-font-sizes):
* modeline.el (modeline-minor-mode-menu):
* minibuf.el (minibuf-directory-files):
Replace the O2N (delq nil (mapcar (lambda (W) (and X Y)) Z)) with
the ON (mapcan (lambda (W) (and X (list Y))) Z) in these files.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (= < > <= >=):
When these functions are handed more than two arguments, and those
arguments have no side effects, transform to a series of two
argument calls, avoiding funcall in the byte-compiled code.
* mule/mule-cmds.el (finish-set-language-environment):
Take advantage of this change in a function called 256 times at
startup.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-function-form, byte-compile-quote)
(byte-compile-quote-form):
Warn at compile time, and error at runtime, if a (quote ...) or a
(function ...) form attempts to quote more than one object.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (byte-optimize-apply): Transform (apply 'nconc
(mapcar ...)) to (mapcan ...); warn about use of the first idiom.
* update-elc.el (do-autoload-commands):
* packages.el (packages-find-package-library-path):
* frame.el (frame-list):
* extents.el (extent-descendants):
* etags.el (buffer-tag-table-files):
* dumped-lisp.el (preloaded-file-list):
* device.el (device-list):
* bytecomp-runtime.el (proclaim-inline, proclaim-notinline)
Use #'mapcan, not (apply #'nconc (mapcar ...) in all these files.
* bytecomp-runtime.el (eval-when-compile, eval-and-compile):
In passing, mention that these macros also evaluate the body when
interpreted.
tests/ChangeLog addition:
2011-02-07 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Test lexical scope for `block', `return-from'; add a
Known-Bug-Expect-Failure for a contorted example that fails when
byte-compiled.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Mon, 07 Feb 2011 12:01:24 +0000 |
| parents | c096d8051f89 |
| children | 6f10ac29bf40 8d29f1c4bb98 |
| rev | line source |
|---|---|
| 428 | 1 /* The portable interface to event streams. |
| 2 Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. | |
| 3 Copyright (C) 1995 Board of Trustees, University of Illinois. | |
| 4 Copyright (C) 1995 Sun Microsystems, Inc. | |
| 5125 | 5 Copyright (C) 1995, 1996, 2001, 2002, 2003, 2005, 2010 Ben Wing. |
| 428 | 6 |
| 7 This file is part of XEmacs. | |
| 8 | |
| 9 XEmacs is free software; you can redistribute it and/or modify it | |
| 10 under the terms of the GNU General Public License as published by the | |
| 11 Free Software Foundation; either version 2, or (at your option) any | |
| 12 later version. | |
| 13 | |
| 14 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 15 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 17 for more details. | |
| 18 | |
| 19 You should have received a copy of the GNU General Public License | |
| 20 along with XEmacs; see the file COPYING. If not, write to | |
| 21 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 22 Boston, MA 02111-1307, USA. */ | |
| 23 | |
| 24 /* Synched up with: Not in FSF. */ | |
| 25 | |
| 442 | 26 /* Authorship: |
| 27 | |
| 28 Created 1991 by Jamie Zawinski. | |
| 29 A great deal of work over the ages by Ben Wing (Mule-ization for 19.12, | |
| 30 device abstraction for 19.12/19.13, async timers for 19.14, | |
| 31 rewriting of focus code for 19.12, pre-idle hook for 19.12, | |
| 32 redoing of signal and quit handling for 19.9 and 19.12, | |
| 33 misc-user events to clean up menu/scrollbar handling for 19.11, | |
| 34 function-key-map/key-translation-map/keyboard-translate-table for | |
| 35 19.13/19.14, open-dribble-file for 19.13, much other cleanup). | |
| 36 focus-follows-mouse from Chuck Thompson, 1995. | |
| 37 XIM stuff by Martin Buchholz, c. 1996?. | |
| 38 */ | |
| 39 | |
| 428 | 40 /* This file has been Mule-ized. */ |
| 41 | |
| 42 /* | |
| 43 * DANGER!! | |
| 44 * | |
| 45 * If you ever change ANYTHING in this file, you MUST run the | |
| 46 * testcases at the end to make sure that you haven't changed | |
| 47 * the semantics of recent-keys, last-input-char, or keyboard | |
| 48 * macros. You'd be surprised how easy it is to break this. | |
| 49 * | |
| 50 */ | |
| 51 | |
| 52 /* TODO: | |
| 1204 | 53 [This stuff is way too hard to maintain - needs rework.] |
| 54 I don't think it's that bad in the main. I've done a fair amount of | |
| 55 cleanup work over the ages; the only stuff that's probably still somewhat | |
| 56 messy is the command-builder handling, which is that way because it's | |
| 57 trying to be "compatible" with pseudo-standards established by Emacs | |
| 58 v18. | |
| 428 | 59 |
| 60 The command builder should deal only with key and button events. | |
| 61 Other command events should be able to come in the MIDDLE of a key | |
| 62 sequence, without disturbing the key sequence composition, or the | |
| 63 command builder structure representing it. | |
| 64 | |
| 65 Someone should rethink universal-argument and figure out how an | |
| 66 arbitrary command can influence the next command (universal-argument | |
| 67 or universal-coding-system-argument) or the next key (hyperify). | |
| 68 | |
| 69 Both C-h and Help in the middle of a key sequence should trigger | |
| 70 prefix-help-command. help-char is stupid. Maybe we need | |
| 71 keymap-of-last-resort? | |
| 72 | |
| 73 After prefix-help is run, one should be able to CONTINUE TYPING, | |
| 74 instead of RETYPING, the key sequence. | |
| 75 */ | |
| 76 | |
| 77 #include <config.h> | |
| 78 #include "lisp.h" | |
| 79 | |
| 80 #include "blocktype.h" | |
| 81 #include "buffer.h" | |
| 82 #include "commands.h" | |
| 872 | 83 #include "device-impl.h" |
| 428 | 84 #include "elhash.h" |
| 85 #include "events.h" | |
| 872 | 86 #include "frame-impl.h" |
| 428 | 87 #include "insdel.h" /* for buffer_reset_changes */ |
| 88 #include "keymap.h" | |
| 89 #include "lstream.h" | |
| 90 #include "macros.h" /* for defining_keyboard_macro */ | |
| 442 | 91 #include "menubar.h" /* #### for evil kludges. */ |
| 428 | 92 #include "process.h" |
| 1292 | 93 #include "profile.h" |
| 872 | 94 #include "window-impl.h" |
| 428 | 95 |
| 96 #include "sysdep.h" /* init_poll_for_quit() */ | |
| 97 #include "syssignal.h" /* SIGCHLD, etc. */ | |
| 98 #include "sysfile.h" | |
| 99 #include "systime.h" /* to set Vlast_input_time */ | |
| 100 | |
| 101 #include "file-coding.h" | |
| 102 | |
| 103 #include <errno.h> | |
| 104 | |
| 105 /* The number of keystrokes between auto-saves. */ | |
| 458 | 106 static Fixnum auto_save_interval; |
| 428 | 107 |
| 108 Lisp_Object Qundefined_keystroke_sequence; | |
| 563 | 109 Lisp_Object Qinvalid_key_binding; |
| 428 | 110 |
| 111 Lisp_Object Qcommand_event_p; | |
| 112 | |
| 113 /* Hooks to run before and after each command. */ | |
| 114 Lisp_Object Vpre_command_hook, Vpost_command_hook; | |
| 115 Lisp_Object Qpre_command_hook, Qpost_command_hook; | |
| 116 | |
| 442 | 117 /* See simple.el */ |
| 118 Lisp_Object Qhandle_pre_motion_command, Qhandle_post_motion_command; | |
| 119 | |
| 428 | 120 /* Hook run when XEmacs is about to be idle. */ |
| 121 Lisp_Object Qpre_idle_hook, Vpre_idle_hook; | |
| 122 | |
| 123 /* Control gratuitous keyboard focus throwing. */ | |
| 124 int focus_follows_mouse; | |
| 125 | |
| 444 | 126 /* When true, modifier keys are sticky. */ |
| 442 | 127 int modifier_keys_are_sticky; |
| 444 | 128 /* Modifier keys are sticky for this many milliseconds. */ |
| 129 Lisp_Object Vmodifier_keys_sticky_time; | |
| 130 | |
| 2828 | 131 /* If true, "Russian C-x processing" is enabled. */ |
| 132 int try_alternate_layouts_for_commands; | |
| 133 | |
| 444 | 134 /* Here FSF Emacs 20.7 defines Vpost_command_idle_hook, |
| 135 post_command_idle_delay, Vdeferred_action_list, and | |
| 136 Vdeferred_action_function, but we don't because that stuff is crap, | |
| 1315 | 137 and we're smarter than them, and their mommas are fat. */ |
| 444 | 138 |
| 139 /* FSF Emacs 20.7 also defines Vinput_method_function, | |
| 140 Qinput_method_exit_on_first_char and Qinput_method_use_echo_area. | |
| 1315 | 141 I don't know whether this should be imported or not. */ |
| 428 | 142 |
| 143 /* Non-nil disable property on a command means | |
| 144 do not execute it; call disabled-command-hook's value instead. */ | |
| 733 | 145 Lisp_Object Qdisabled; |
| 428 | 146 |
| 147 /* Last keyboard or mouse input event read as a command. */ | |
| 148 Lisp_Object Vlast_command_event; | |
| 149 | |
| 150 /* The nearest ASCII equivalent of the above. */ | |
| 151 Lisp_Object Vlast_command_char; | |
| 152 | |
| 153 /* Last keyboard or mouse event read for any purpose. */ | |
| 154 Lisp_Object Vlast_input_event; | |
| 155 | |
| 156 /* The nearest ASCII equivalent of the above. */ | |
| 157 Lisp_Object Vlast_input_char; | |
| 158 | |
| 159 Lisp_Object Vcurrent_mouse_event; | |
| 160 | |
| 161 /* This is fbound in cmdloop.el, see the commentary there */ | |
| 162 Lisp_Object Qcancel_mode_internal; | |
| 163 | |
| 164 /* If not Qnil, event objects to be read as the next command input */ | |
| 165 Lisp_Object Vunread_command_events; | |
| 166 Lisp_Object Vunread_command_event; /* obsoleteness support */ | |
| 167 | |
| 168 static Lisp_Object Qunread_command_events, Qunread_command_event; | |
| 169 | |
| 170 /* Previous command, represented by a Lisp object. | |
| 442 | 171 Does not include prefix commands and arg setting commands. */ |
| 428 | 172 Lisp_Object Vlast_command; |
| 173 | |
| 442 | 174 /* Contents of this-command-properties for the last command. */ |
| 175 Lisp_Object Vlast_command_properties; | |
| 176 | |
| 428 | 177 /* If a command sets this, the value goes into |
| 442 | 178 last-command for the next command. */ |
| 428 | 179 Lisp_Object Vthis_command; |
| 180 | |
| 442 | 181 /* If a command sets this, the value goes into |
| 182 last-command-properties for the next command. */ | |
| 183 Lisp_Object Vthis_command_properties; | |
| 184 | |
| 428 | 185 /* The value of point when the last command was executed. */ |
| 665 | 186 Charbpos last_point_position; |
| 428 | 187 |
| 188 /* The frame that was current when the last command was started. */ | |
| 189 Lisp_Object Vlast_selected_frame; | |
| 190 | |
| 191 /* The buffer that was current when the last command was started. */ | |
| 192 Lisp_Object last_point_position_buffer; | |
| 193 | |
| 194 /* A (16bit . 16bit) representation of the time of the last-command-event. */ | |
| 195 Lisp_Object Vlast_input_time; | |
| 196 | |
| 197 /* A (16bit 16bit usec) representation of the time | |
| 198 of the last-command-event. */ | |
| 199 Lisp_Object Vlast_command_event_time; | |
| 200 | |
| 201 /* Character to recognize as the help char. */ | |
| 202 Lisp_Object Vhelp_char; | |
| 203 | |
| 204 /* Form to execute when help char is typed. */ | |
| 205 Lisp_Object Vhelp_form; | |
| 206 | |
| 207 /* Command to run when the help character follows a prefix key. */ | |
| 208 Lisp_Object Vprefix_help_command; | |
| 209 | |
| 210 /* Flag to tell QUIT that some interesting occurrence (e.g. a keypress) | |
| 211 may have happened. */ | |
| 212 volatile int something_happened; | |
| 213 | |
| 214 /* Hash table to translate keysyms through */ | |
| 215 Lisp_Object Vkeyboard_translate_table; | |
| 216 | |
| 217 /* If control-meta-super-shift-X is undefined, try control-meta-super-x */ | |
| 218 Lisp_Object Vretry_undefined_key_binding_unshifted; | |
| 219 Lisp_Object Qretry_undefined_key_binding_unshifted; | |
| 220 | |
| 221 /* Console that corresponds to our controlling terminal */ | |
| 222 Lisp_Object Vcontrolling_terminal; | |
| 223 | |
| 224 /* An event (actually an event chain linked through event_next) or Qnil. | |
| 225 */ | |
| 226 Lisp_Object Vthis_command_keys; | |
| 227 Lisp_Object Vthis_command_keys_tail; | |
| 228 | |
| 229 /* #### kludge! */ | |
| 230 Lisp_Object Qauto_show_make_point_visible; | |
| 231 | |
| 232 /* File in which we write all commands we read; an lstream */ | |
| 233 static Lisp_Object Vdribble_file; | |
| 234 | |
| 235 /* Recent keys ring location; a vector of events or nil-s */ | |
| 236 Lisp_Object Vrecent_keys_ring; | |
| 237 int recent_keys_ring_size; | |
| 238 int recent_keys_ring_index; | |
| 239 | |
| 240 /* Boolean specifying whether keystrokes should be added to | |
| 241 recent-keys. */ | |
| 242 int inhibit_input_event_recording; | |
| 243 | |
| 430 | 244 Lisp_Object Qself_insert_defer_undo; |
| 245 | |
|
5139
a48ef26d87ee
Clean up prototypes for Lisp variables/symbols. Put decls for them with
Ben Wing <ben@xemacs.org>
parents:
5050
diff
changeset
|
246 Lisp_Object Qsans_modifiers; |
|
a48ef26d87ee
Clean up prototypes for Lisp variables/symbols. Put decls for them with
Ben Wing <ben@xemacs.org>
parents:
5050
diff
changeset
|
247 |
| 1268 | 248 int in_modal_loop; |
| 249 | |
| 250 /* the number of keyboard characters read. callint.c wants this. */ | |
| 251 Charcount num_input_chars; | |
| 428 | 252 |
| 1292 | 253 static Lisp_Object Qnext_event, Qdispatch_event, QSnext_event_internal; |
| 254 static Lisp_Object QSexecute_internal_event; | |
| 255 | |
| 428 | 256 #ifdef DEBUG_XEMACS |
| 458 | 257 Fixnum debug_emacs_events; |
| 428 | 258 |
| 259 static void | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
260 external_debugging_print_event (const Ascbyte *event_description, |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
261 Lisp_Object event) |
| 428 | 262 { |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
263 write_ascstring (Qexternal_debugging_output, "("); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
264 write_ascstring (Qexternal_debugging_output, event_description); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
265 write_ascstring (Qexternal_debugging_output, ") "); |
| 428 | 266 print_internal (event, Qexternal_debugging_output, 1); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
267 write_ascstring (Qexternal_debugging_output, "\n"); |
| 428 | 268 } |
| 269 #define DEBUG_PRINT_EMACS_EVENT(event_description, event) do { \ | |
| 270 if (debug_emacs_events) \ | |
| 271 external_debugging_print_event (event_description, event); \ | |
| 272 } while (0) | |
| 273 #else | |
| 274 #define DEBUG_PRINT_EMACS_EVENT(string, event) | |
| 275 #endif | |
| 276 | |
| 277 | |
| 278 /* The callback routines for the window system or terminal driver */ | |
| 279 struct event_stream *event_stream; | |
| 280 | |
| 2367 | 281 |
| 282 /* | |
| 283 | |
| 284 See also | |
| 285 | |
| 286 (Info-goto-node "(internals)Event Stream Callback Routines") | |
| 287 */ | |
| 1204 | 288 |
| 428 | 289 static Lisp_Object command_event_queue; |
| 290 static Lisp_Object command_event_queue_tail; | |
| 291 | |
| 1204 | 292 Lisp_Object dispatch_event_queue; |
| 293 static Lisp_Object dispatch_event_queue_tail; | |
| 294 | |
| 428 | 295 /* Nonzero means echo unfinished commands after this many seconds of pause. */ |
| 296 static Lisp_Object Vecho_keystrokes; | |
| 297 | |
| 298 /* The number of keystrokes since the last auto-save. */ | |
| 299 static int keystrokes_since_auto_save; | |
| 300 | |
| 301 /* Used by the C-g signal handler so that it will never "hard quit" | |
| 302 when waiting for an event. Otherwise holding down C-g could | |
| 303 cause a suspension back to the shell, which is generally | |
| 304 undesirable. (#### This doesn't fully work.) */ | |
| 305 | |
| 306 int emacs_is_blocking; | |
| 307 | |
| 308 /* Handlers which run during sit-for, sleep-for and accept-process-output | |
| 309 are not allowed to recursively call these routines. We record here | |
| 310 if we are in that situation. */ | |
| 311 | |
| 1268 | 312 static int recursive_sit_for; |
| 313 | |
| 314 static void pre_command_hook (void); | |
| 315 static void post_command_hook (void); | |
| 316 static void maybe_kbd_translate (Lisp_Object event); | |
| 317 static void push_this_command_keys (Lisp_Object event); | |
| 318 static void push_recent_keys (Lisp_Object event); | |
| 319 static void dribble_out_event (Lisp_Object event); | |
| 320 static void execute_internal_event (Lisp_Object event); | |
| 321 static int is_scrollbar_event (Lisp_Object event); | |
| 428 | 322 |
| 323 | |
| 324 /**********************************************************************/ | |
| 325 /* Command-builder object */ | |
| 326 /**********************************************************************/ | |
| 327 | |
| 328 #define XCOMMAND_BUILDER(x) \ | |
| 329 XRECORD (x, command_builder, struct command_builder) | |
| 771 | 330 #define wrap_command_builder(p) wrap_record (p, command_builder) |
| 428 | 331 #define COMMAND_BUILDERP(x) RECORDP (x, command_builder) |
| 332 #define CHECK_COMMAND_BUILDER(x) CHECK_RECORD (x, command_builder) | |
| 771 | 333 #define CONCHECK_COMMAND_BUILDER(x) CONCHECK_RECORD (x, command_builder) |
| 334 | |
| 1204 | 335 static const struct memory_description command_builder_description [] = { |
| 934 | 336 { XD_LISP_OBJECT, offsetof (struct command_builder, current_events) }, |
| 337 { XD_LISP_OBJECT, offsetof (struct command_builder, most_current_event) }, | |
| 338 { XD_LISP_OBJECT, offsetof (struct command_builder, last_non_munged_event) }, | |
| 339 { XD_LISP_OBJECT, offsetof (struct command_builder, console) }, | |
| 1204 | 340 { XD_LISP_OBJECT_ARRAY, offsetof (struct command_builder, first_mungeable_event), 2 }, |
| 934 | 341 { XD_END } |
| 342 }; | |
| 343 | |
| 428 | 344 static Lisp_Object |
| 345 mark_command_builder (Lisp_Object obj) | |
| 346 { | |
| 347 struct command_builder *builder = XCOMMAND_BUILDER (obj); | |
| 348 mark_object (builder->current_events); | |
| 349 mark_object (builder->most_current_event); | |
| 350 mark_object (builder->last_non_munged_event); | |
| 1204 | 351 mark_object (builder->first_mungeable_event[0]); |
| 352 mark_object (builder->first_mungeable_event[1]); | |
| 428 | 353 return builder->console; |
| 354 } | |
| 355 | |
| 356 static void | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
357 finalize_command_builder (Lisp_Object obj) |
| 428 | 358 { |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
359 struct command_builder *b = XCOMMAND_BUILDER (obj); |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
360 if (b->echo_buf) |
| 428 | 361 { |
| 5125 | 362 xfree (b->echo_buf); |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
363 b->echo_buf = 0; |
| 428 | 364 } |
| 365 } | |
| 366 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
367 DEFINE_NODUMP_LISP_OBJECT ("command-builder", command_builder, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
368 mark_command_builder, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
369 internal_object_printer, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
370 finalize_command_builder, 0, 0, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
371 command_builder_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
372 struct command_builder); |
| 771 | 373 |
| 428 | 374 static void |
| 375 reset_command_builder_event_chain (struct command_builder *builder) | |
| 376 { | |
| 377 builder->current_events = Qnil; | |
| 378 builder->most_current_event = Qnil; | |
| 379 builder->last_non_munged_event = Qnil; | |
| 1204 | 380 builder->first_mungeable_event[0] = Qnil; |
| 381 builder->first_mungeable_event[1] = Qnil; | |
| 428 | 382 } |
| 383 | |
| 384 Lisp_Object | |
| 771 | 385 allocate_command_builder (Lisp_Object console, int with_echo_buf) |
| 428 | 386 { |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
387 Lisp_Object builder_obj = ALLOC_NORMAL_LISP_OBJECT (command_builder); |
| 771 | 388 struct command_builder *builder = XCOMMAND_BUILDER (builder_obj); |
| 428 | 389 |
| 390 builder->console = console; | |
| 391 reset_command_builder_event_chain (builder); | |
| 771 | 392 if (with_echo_buf) |
| 393 { | |
| 394 /* #### This badly needs to be turned into a Dynarr */ | |
| 395 builder->echo_buf_length = 300; /* #### Kludge */ | |
| 867 | 396 builder->echo_buf = xnew_array (Ibyte, builder->echo_buf_length); |
| 771 | 397 builder->echo_buf[0] = 0; |
| 398 } | |
| 399 else | |
| 400 { | |
| 401 builder->echo_buf_length = 0; | |
| 402 builder->echo_buf = NULL; | |
| 403 } | |
| 428 | 404 builder->echo_buf_index = -1; |
| 405 builder->self_insert_countdown = 0; | |
| 406 | |
| 407 return builder_obj; | |
| 408 } | |
| 409 | |
| 771 | 410 /* Copy or clone COLLAPSING (copy to NEW_BUILDINGS if non-zero, |
| 411 otherwise clone); but don't copy the echo-buf stuff. (The calling | |
| 412 routines don't need it and will reset it, and we would rather avoid | |
| 413 malloc.) */ | |
| 414 | |
| 415 static Lisp_Object | |
| 416 copy_command_builder (struct command_builder *collapsing, | |
| 417 struct command_builder *new_buildings) | |
| 418 { | |
| 419 if (!new_buildings) | |
| 420 new_buildings = XCOMMAND_BUILDER (allocate_command_builder (Qnil, 0)); | |
| 421 | |
| 3358 | 422 new_buildings->console = collapsing->console; |
| 423 | |
| 771 | 424 new_buildings->self_insert_countdown = collapsing->self_insert_countdown; |
| 425 | |
| 426 deallocate_event_chain (new_buildings->current_events); | |
| 427 new_buildings->current_events = | |
| 428 copy_event_chain (collapsing->current_events); | |
| 429 | |
| 430 new_buildings->most_current_event = | |
| 431 transfer_event_chain_pointer (collapsing->most_current_event, | |
| 432 collapsing->current_events, | |
| 433 new_buildings->current_events); | |
| 434 new_buildings->last_non_munged_event = | |
| 435 transfer_event_chain_pointer (collapsing->last_non_munged_event, | |
| 436 collapsing->current_events, | |
| 437 new_buildings->current_events); | |
| 1204 | 438 new_buildings->first_mungeable_event[0] = |
| 439 transfer_event_chain_pointer (collapsing->first_mungeable_event[0], | |
| 771 | 440 collapsing->current_events, |
| 441 new_buildings->current_events); | |
| 1204 | 442 new_buildings->first_mungeable_event[1] = |
| 443 transfer_event_chain_pointer (collapsing->first_mungeable_event[1], | |
| 771 | 444 collapsing->current_events, |
| 445 new_buildings->current_events); | |
| 446 | |
| 447 return wrap_command_builder (new_buildings); | |
| 448 } | |
| 449 | |
| 450 static void | |
| 451 free_command_builder (struct command_builder *builder) | |
| 452 { | |
| 453 if (builder->echo_buf) | |
| 454 { | |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
455 xfree (builder->echo_buf); |
| 771 | 456 builder->echo_buf = NULL; |
| 457 } | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
458 free_normal_lisp_object (wrap_command_builder (builder)); |
| 771 | 459 } |
| 460 | |
| 428 | 461 static void |
| 462 command_builder_append_event (struct command_builder *builder, | |
| 463 Lisp_Object event) | |
| 464 { | |
| 465 assert (EVENTP (event)); | |
| 466 | |
| 771 | 467 event = Fcopy_event (event, Qnil); |
| 428 | 468 if (EVENTP (builder->most_current_event)) |
| 469 XSET_EVENT_NEXT (builder->most_current_event, event); | |
| 470 else | |
| 471 builder->current_events = event; | |
| 472 | |
| 473 builder->most_current_event = event; | |
| 1204 | 474 if (NILP (builder->first_mungeable_event[0])) |
| 475 builder->first_mungeable_event[0] = event; | |
| 476 if (NILP (builder->first_mungeable_event[1])) | |
| 477 builder->first_mungeable_event[1] = event; | |
| 428 | 478 } |
| 479 | |
| 480 | |
| 481 /**********************************************************************/ | |
| 482 /* Low-level interfaces onto event methods */ | |
| 483 /**********************************************************************/ | |
| 484 | |
| 485 static void | |
| 1268 | 486 check_event_stream_ok (void) |
| 428 | 487 { |
| 488 if (!event_stream && noninteractive) | |
| 814 | 489 /* See comment in init_event_stream() */ |
| 490 init_event_stream (); | |
| 491 else assert (event_stream); | |
| 428 | 492 } |
| 493 | |
| 494 void | |
| 440 | 495 event_stream_handle_magic_event (Lisp_Event *event) |
| 428 | 496 { |
| 1268 | 497 check_event_stream_ok (); |
| 428 | 498 event_stream->handle_magic_event_cb (event); |
| 499 } | |
| 500 | |
| 788 | 501 void |
| 502 event_stream_format_magic_event (Lisp_Event *event, Lisp_Object pstream) | |
| 503 { | |
| 1268 | 504 check_event_stream_ok (); |
| 788 | 505 event_stream->format_magic_event_cb (event, pstream); |
| 506 } | |
| 507 | |
| 508 int | |
| 509 event_stream_compare_magic_event (Lisp_Event *e1, Lisp_Event *e2) | |
| 510 { | |
| 1268 | 511 check_event_stream_ok (); |
| 788 | 512 return event_stream->compare_magic_event_cb (e1, e2); |
| 513 } | |
| 514 | |
| 515 Hashcode | |
| 516 event_stream_hash_magic_event (Lisp_Event *e) | |
| 517 { | |
| 1268 | 518 check_event_stream_ok (); |
| 788 | 519 return event_stream->hash_magic_event_cb (e); |
| 520 } | |
| 521 | |
| 428 | 522 static int |
| 523 event_stream_add_timeout (EMACS_TIME timeout) | |
| 524 { | |
| 1268 | 525 check_event_stream_ok (); |
| 428 | 526 return event_stream->add_timeout_cb (timeout); |
| 527 } | |
| 528 | |
| 529 static void | |
| 530 event_stream_remove_timeout (int id) | |
| 531 { | |
| 1268 | 532 check_event_stream_ok (); |
| 428 | 533 event_stream->remove_timeout_cb (id); |
| 534 } | |
| 535 | |
| 536 void | |
| 537 event_stream_select_console (struct console *con) | |
| 538 { | |
| 1268 | 539 check_event_stream_ok (); |
| 428 | 540 if (!con->input_enabled) |
| 541 { | |
| 542 event_stream->select_console_cb (con); | |
| 543 con->input_enabled = 1; | |
| 544 } | |
| 545 } | |
| 546 | |
| 547 void | |
| 548 event_stream_unselect_console (struct console *con) | |
| 549 { | |
| 1268 | 550 check_event_stream_ok (); |
| 428 | 551 if (con->input_enabled) |
| 552 { | |
| 553 event_stream->unselect_console_cb (con); | |
| 554 con->input_enabled = 0; | |
| 555 } | |
| 556 } | |
| 557 | |
| 558 void | |
| 853 | 559 event_stream_select_process (Lisp_Process *proc, int doin, int doerr) |
| 428 | 560 { |
| 853 | 561 int cur_in, cur_err; |
| 562 | |
| 1268 | 563 check_event_stream_ok (); |
| 853 | 564 |
| 565 cur_in = get_process_selected_p (proc, 0); | |
| 566 if (cur_in) | |
| 567 doin = 0; | |
| 568 | |
| 569 if (!process_has_separate_stderr (wrap_process (proc))) | |
| 428 | 570 { |
| 853 | 571 doerr = 0; |
| 572 cur_err = 0; | |
| 573 } | |
| 574 else | |
| 575 { | |
| 576 cur_err = get_process_selected_p (proc, 1); | |
| 577 if (cur_err) | |
| 578 doerr = 0; | |
| 579 } | |
| 580 | |
| 581 if (doin || doerr) | |
| 582 { | |
| 583 event_stream->select_process_cb (proc, doin, doerr); | |
| 584 set_process_selected_p (proc, cur_in || doin, cur_err || doerr); | |
| 428 | 585 } |
| 586 } | |
| 587 | |
| 588 void | |
| 853 | 589 event_stream_unselect_process (Lisp_Process *proc, int doin, int doerr) |
| 428 | 590 { |
| 853 | 591 int cur_in, cur_err; |
| 592 | |
| 1268 | 593 check_event_stream_ok (); |
| 853 | 594 |
| 595 cur_in = get_process_selected_p (proc, 0); | |
| 596 if (!cur_in) | |
| 597 doin = 0; | |
| 598 | |
| 599 if (!process_has_separate_stderr (wrap_process (proc))) | |
| 428 | 600 { |
| 853 | 601 doerr = 0; |
| 602 cur_err = 0; | |
| 603 } | |
| 604 else | |
| 605 { | |
| 606 cur_err = get_process_selected_p (proc, 1); | |
| 607 if (!cur_err) | |
| 608 doerr = 0; | |
| 609 } | |
| 610 | |
| 611 if (doin || doerr) | |
| 612 { | |
| 613 event_stream->unselect_process_cb (proc, doin, doerr); | |
| 614 set_process_selected_p (proc, cur_in && !doin, cur_err && !doerr); | |
| 428 | 615 } |
| 616 } | |
| 617 | |
| 853 | 618 void |
| 619 event_stream_create_io_streams (void *inhandle, void *outhandle, | |
| 620 void *errhandle, Lisp_Object *instream, | |
| 621 Lisp_Object *outstream, | |
| 622 Lisp_Object *errstream, | |
| 623 USID *in_usid, | |
| 624 USID *err_usid, | |
| 625 int flags) | |
| 428 | 626 { |
| 1268 | 627 check_event_stream_ok (); |
| 853 | 628 event_stream->create_io_streams_cb |
| 629 (inhandle, outhandle, errhandle, instream, outstream, errstream, | |
| 630 in_usid, err_usid, flags); | |
| 428 | 631 } |
| 632 | |
| 853 | 633 void |
| 634 event_stream_delete_io_streams (Lisp_Object instream, | |
| 635 Lisp_Object outstream, | |
| 636 Lisp_Object errstream, | |
| 637 USID *in_usid, | |
| 638 USID *err_usid) | |
| 428 | 639 { |
| 1268 | 640 check_event_stream_ok (); |
| 853 | 641 event_stream->delete_io_streams_cb (instream, outstream, errstream, |
| 642 in_usid, err_usid); | |
| 428 | 643 } |
| 644 | |
| 442 | 645 static int |
| 646 event_stream_current_event_timestamp (struct console *c) | |
| 647 { | |
| 648 if (event_stream && event_stream->current_event_timestamp_cb) | |
| 649 return event_stream->current_event_timestamp_cb (c); | |
| 650 else | |
| 651 return 0; | |
| 652 } | |
| 428 | 653 |
| 654 | |
| 655 /**********************************************************************/ | |
| 656 /* Character prompting */ | |
| 657 /**********************************************************************/ | |
| 658 | |
| 659 static void | |
| 660 echo_key_event (struct command_builder *command_builder, | |
| 661 Lisp_Object event) | |
| 662 { | |
| 663 /* This function can GC */ | |
| 793 | 664 DECLARE_EISTRING_MALLOC (buf); |
| 428 | 665 Bytecount buf_index = command_builder->echo_buf_index; |
| 867 | 666 Ibyte *e; |
| 428 | 667 Bytecount len; |
| 668 | |
| 669 if (buf_index < 0) | |
| 670 { | |
| 671 buf_index = 0; /* We're echoing now */ | |
| 672 clear_echo_area (selected_frame (), Qnil, 0); | |
| 673 } | |
| 674 | |
| 934 | 675 format_event_object (buf, event, 1); |
| 793 | 676 len = eilen (buf); |
| 428 | 677 |
| 678 if (len + buf_index + 4 > command_builder->echo_buf_length) | |
| 793 | 679 { |
| 680 eifree (buf); | |
| 681 return; | |
| 682 } | |
| 428 | 683 e = command_builder->echo_buf + buf_index; |
| 793 | 684 memcpy (e, eidata (buf), len); |
| 428 | 685 e += len; |
| 793 | 686 eifree (buf); |
| 428 | 687 |
| 688 e[0] = ' '; | |
| 689 e[1] = '-'; | |
| 690 e[2] = ' '; | |
| 691 e[3] = 0; | |
| 692 | |
| 693 command_builder->echo_buf_index = buf_index + len + 1; | |
| 694 } | |
| 695 | |
| 696 static void | |
| 697 regenerate_echo_keys_from_this_command_keys (struct command_builder * | |
| 698 builder) | |
| 699 { | |
| 700 Lisp_Object event; | |
| 701 | |
| 702 builder->echo_buf_index = 0; | |
| 703 | |
| 704 EVENT_CHAIN_LOOP (event, Vthis_command_keys) | |
| 705 echo_key_event (builder, event); | |
| 706 } | |
| 707 | |
| 708 static void | |
| 709 maybe_echo_keys (struct command_builder *command_builder, int no_snooze) | |
| 710 { | |
| 711 /* This function can GC */ | |
| 712 double echo_keystrokes; | |
| 713 struct frame *f = selected_frame (); | |
| 853 | 714 int depth = begin_dont_check_for_quit (); |
| 715 | |
| 428 | 716 /* Message turns off echoing unless more keystrokes turn it on again. */ |
| 717 if (echo_area_active (f) && !EQ (Qcommand, echo_area_status (f))) | |
| 853 | 718 goto done; |
| 428 | 719 |
| 720 if (INTP (Vecho_keystrokes) || FLOATP (Vecho_keystrokes)) | |
| 721 echo_keystrokes = extract_float (Vecho_keystrokes); | |
| 722 else | |
| 723 echo_keystrokes = 0; | |
| 724 | |
| 725 if (minibuf_level == 0 | |
| 726 && echo_keystrokes > 0.0 | |
| 442 | 727 #if defined (HAVE_X_WINDOWS) && defined (LWLIB_MENUBARS_LUCID) |
| 728 && !x_kludge_lw_menu_active () | |
| 729 #endif | |
| 730 ) | |
| 428 | 731 { |
| 732 if (!no_snooze) | |
| 733 { | |
| 734 if (NILP (Fsit_for (Vecho_keystrokes, Qnil))) | |
| 735 /* input came in, so don't echo. */ | |
| 853 | 736 goto done; |
| 428 | 737 } |
| 738 | |
| 739 echo_area_message (f, command_builder->echo_buf, Qnil, 0, | |
| 740 /* not echo_buf_index. That doesn't include | |
| 741 the terminating " - ". */ | |
| 742 strlen ((char *) command_builder->echo_buf), | |
| 743 Qcommand); | |
| 744 } | |
| 853 | 745 |
| 746 done: | |
| 747 Vquit_flag = Qnil; /* see begin_dont_check_for_quit() */ | |
| 748 unbind_to (depth); | |
| 428 | 749 } |
| 750 | |
| 751 static void | |
| 752 reset_key_echo (struct command_builder *command_builder, | |
| 753 int remove_echo_area_echo) | |
| 754 { | |
| 755 /* This function can GC */ | |
| 756 struct frame *f = selected_frame (); | |
| 757 | |
| 757 | 758 if (command_builder) |
| 759 command_builder->echo_buf_index = -1; | |
| 428 | 760 |
| 761 if (remove_echo_area_echo) | |
| 762 clear_echo_area (f, Qcommand, 0); | |
| 763 } | |
| 764 | |
| 765 | |
| 766 /**********************************************************************/ | |
| 767 /* random junk */ | |
| 768 /**********************************************************************/ | |
| 769 | |
| 770 /* NB: The following auto-save stuff is in keyboard.c in FSFmacs, and | |
| 771 keystrokes_since_auto_save is equivalent to the difference between | |
| 772 num_nonmacro_input_chars and last_auto_save. */ | |
| 773 | |
| 444 | 774 /* When an auto-save happens, record the number of keystrokes, and |
| 775 don't do again soon. */ | |
| 428 | 776 |
| 777 void | |
| 778 record_auto_save (void) | |
| 779 { | |
| 780 keystrokes_since_auto_save = 0; | |
| 781 } | |
| 782 | |
| 783 /* Make an auto save happen as soon as possible at command level. */ | |
| 784 | |
| 785 void | |
| 786 force_auto_save_soon (void) | |
| 787 { | |
| 788 keystrokes_since_auto_save = 1 + max (auto_save_interval, 20); | |
| 789 } | |
| 790 | |
| 791 static void | |
| 792 maybe_do_auto_save (void) | |
| 793 { | |
| 794 /* This function can call lisp */ | |
| 795 keystrokes_since_auto_save++; | |
| 796 if (auto_save_interval > 0 && | |
| 797 keystrokes_since_auto_save > max (auto_save_interval, 20) && | |
| 1268 | 798 !detect_input_pending (1)) |
| 428 | 799 { |
| 800 Fdo_auto_save (Qnil, Qnil); | |
| 801 record_auto_save (); | |
| 802 } | |
| 803 } | |
| 804 | |
| 805 static Lisp_Object | |
| 806 print_help (Lisp_Object object) | |
| 807 { | |
| 808 Fprinc (object, Qnil); | |
| 809 return Qnil; | |
| 810 } | |
| 811 | |
| 812 static void | |
| 813 execute_help_form (struct command_builder *command_builder, | |
| 814 Lisp_Object event) | |
| 815 { | |
| 816 /* This function can GC */ | |
| 817 Lisp_Object help = Qnil; | |
| 818 int speccount = specpdl_depth (); | |
| 819 Bytecount buf_index = command_builder->echo_buf_index; | |
| 820 Lisp_Object echo = ((buf_index <= 0) | |
| 821 ? Qnil | |
| 822 : make_string (command_builder->echo_buf, | |
| 823 buf_index)); | |
| 824 struct gcpro gcpro1, gcpro2; | |
| 825 GCPRO2 (echo, help); | |
| 826 | |
|
4775
1d61580e0cf7
Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4718
diff
changeset
|
827 record_unwind_protect (Feval, |
|
1d61580e0cf7
Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4718
diff
changeset
|
828 list2 (Qset_window_configuration, |
|
1d61580e0cf7
Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4718
diff
changeset
|
829 call0 (Qcurrent_window_configuration))); |
| 428 | 830 reset_key_echo (command_builder, 1); |
| 831 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4528
diff
changeset
|
832 help = IGNORE_MULTIPLE_VALUES (Feval (Vhelp_form)); |
| 428 | 833 if (STRINGP (help)) |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
834 internal_with_output_to_temp_buffer (build_ascstring ("*Help*"), |
| 428 | 835 print_help, help, Qnil); |
| 836 Fnext_command_event (event, Qnil); | |
| 837 /* Remove the help from the frame */ | |
| 771 | 838 unbind_to (speccount); |
| 428 | 839 /* Hmmmm. Tricky. The unbind restores an old window configuration, |
| 840 apparently bypassing any setting of windows_structure_changed. | |
| 841 So we need to set it so that things get redrawn properly. */ | |
| 842 /* #### This is massive overkill. Look at doing it better once the | |
| 843 new redisplay is fully in place. */ | |
| 844 { | |
| 845 Lisp_Object frmcons, devcons, concons; | |
| 846 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons) | |
| 847 { | |
| 848 struct frame *f = XFRAME (XCAR (frmcons)); | |
| 849 MARK_FRAME_WINDOWS_STRUCTURE_CHANGED (f); | |
| 850 } | |
| 851 } | |
| 852 | |
| 853 redisplay (); | |
| 1204 | 854 if (event_matches_key_specifier_p (event, make_char (' '))) |
| 428 | 855 { |
| 856 /* Discard next key if it is a space */ | |
| 857 reset_key_echo (command_builder, 1); | |
| 858 Fnext_command_event (event, Qnil); | |
| 859 } | |
| 860 | |
| 861 command_builder->echo_buf_index = buf_index; | |
| 862 if (buf_index > 0) | |
| 863 memcpy (command_builder->echo_buf, | |
| 864 XSTRING_DATA (echo), buf_index + 1); /* terminating 0 */ | |
| 865 UNGCPRO; | |
| 866 } | |
| 867 | |
| 868 | |
| 869 /**********************************************************************/ | |
| 870 /* timeouts */ | |
| 871 /**********************************************************************/ | |
| 872 | |
| 593 | 873 /* NOTE: "Low-level" or "interval" timeouts are one-shot timeouts that |
| 874 measure single intervals. "High-level timeouts" or "wakeups" are | |
| 875 the objects generated by `add-timeout' or `add-async-timout' -- | |
| 876 they can fire repeatedly (and in fact can have a different initial | |
| 877 time and resignal time). Given the nature of both setitimer() and | |
| 878 select() -- i.e. all we get is a single one-shot timer -- we have | |
| 879 to decompose all high-level timeouts into a series of intervals or | |
| 880 low-level timeouts. | |
| 881 | |
| 882 Low-level timeouts are of two varieties: synchronous and asynchronous. | |
| 883 The former are handled at the window-system level, the latter in | |
| 884 signal.c. | |
| 885 */ | |
| 886 | |
| 887 /**** Low-level timeout helper functions. **** | |
| 428 | 888 |
| 889 These functions maintain a sorted list of one-shot timeouts (where | |
| 593 | 890 the timeouts are in absolute time so we never lose any time as a |
| 891 result of the delay between noting an interval and firing the next | |
| 892 one). They are intended for use by functions that need to convert | |
| 893 a list of absolute timeouts into a series of intervals to wait | |
| 894 for. */ | |
| 428 | 895 |
| 896 /* We ensure that 0 is never a valid ID, so that a value of 0 can be | |
| 897 used to indicate an absence of a timer. */ | |
| 898 static int low_level_timeout_id_tick; | |
| 899 | |
| 900 static struct low_level_timeout_blocktype | |
| 901 { | |
| 902 Blocktype_declare (struct low_level_timeout); | |
| 903 } *the_low_level_timeout_blocktype; | |
| 904 | |
| 905 /* Add a one-shot timeout at time TIME to TIMEOUT_LIST. Return | |
| 906 a unique ID identifying the timeout. */ | |
| 907 | |
| 908 int | |
| 909 add_low_level_timeout (struct low_level_timeout **timeout_list, | |
| 910 EMACS_TIME thyme) | |
| 911 { | |
| 912 struct low_level_timeout *tm; | |
| 913 struct low_level_timeout *t, **tt; | |
| 914 | |
| 915 /* Allocate a new time struct. */ | |
| 916 | |
| 917 tm = Blocktype_alloc (the_low_level_timeout_blocktype); | |
| 918 tm->next = NULL; | |
| 593 | 919 /* Don't just use ++low_level_timeout_id_tick, for the (admittedly |
| 920 rare) case in which numbers wrap around. */ | |
| 428 | 921 if (low_level_timeout_id_tick == 0) |
| 922 low_level_timeout_id_tick++; | |
| 923 tm->id = low_level_timeout_id_tick++; | |
| 924 tm->time = thyme; | |
| 925 | |
| 926 /* Add it to the queue. */ | |
| 927 | |
| 928 tt = timeout_list; | |
| 929 t = *tt; | |
| 930 while (t && EMACS_TIME_EQUAL_OR_GREATER (tm->time, t->time)) | |
| 931 { | |
| 932 tt = &t->next; | |
| 933 t = *tt; | |
| 934 } | |
| 935 tm->next = t; | |
| 936 *tt = tm; | |
| 937 | |
| 938 return tm->id; | |
| 939 } | |
| 940 | |
| 941 /* Remove the low-level timeout identified by ID from TIMEOUT_LIST. | |
| 942 If the timeout is not there, do nothing. */ | |
| 943 | |
| 944 void | |
| 945 remove_low_level_timeout (struct low_level_timeout **timeout_list, int id) | |
| 946 { | |
| 947 struct low_level_timeout *t, *prev; | |
| 948 | |
| 949 /* find it */ | |
| 950 | |
| 951 for (t = *timeout_list, prev = NULL; t && t->id != id; t = t->next) | |
| 952 prev = t; | |
| 953 | |
| 954 if (!t) | |
| 955 return; /* couldn't find it */ | |
| 956 | |
| 957 if (!prev) | |
| 958 *timeout_list = t->next; | |
| 959 else prev->next = t->next; | |
| 960 | |
| 961 Blocktype_free (the_low_level_timeout_blocktype, t); | |
| 962 } | |
| 963 | |
| 964 /* If there are timeouts on TIMEOUT_LIST, store the relative time | |
| 965 interval to the first timeout on the list into INTERVAL and | |
| 966 return 1. Otherwise, return 0. */ | |
| 967 | |
| 968 int | |
| 969 get_low_level_timeout_interval (struct low_level_timeout *timeout_list, | |
| 970 EMACS_TIME *interval) | |
| 971 { | |
| 972 if (!timeout_list) /* no timer events; block indefinitely */ | |
| 973 return 0; | |
| 974 else | |
| 975 { | |
| 976 EMACS_TIME current_time; | |
| 977 | |
| 978 /* The time to block is the difference between the first | |
| 979 (earliest) timer on the queue and the current time. | |
| 980 If that is negative, then the timer will fire immediately | |
| 981 but we still have to call select(), with a zero-valued | |
| 982 timeout: user events must have precedence over timer events. */ | |
| 983 EMACS_GET_TIME (current_time); | |
| 984 if (EMACS_TIME_GREATER (timeout_list->time, current_time)) | |
| 985 EMACS_SUB_TIME (*interval, timeout_list->time, | |
| 986 current_time); | |
| 987 else | |
| 988 EMACS_SET_SECS_USECS (*interval, 0, 0); | |
| 989 return 1; | |
| 990 } | |
| 991 } | |
| 992 | |
| 993 /* Pop the first (i.e. soonest) timeout off of TIMEOUT_LIST and return | |
| 994 its ID. Also, if TIME_OUT is not 0, store the absolute time of the | |
| 995 timeout into TIME_OUT. */ | |
| 996 | |
| 997 int | |
| 998 pop_low_level_timeout (struct low_level_timeout **timeout_list, | |
| 999 EMACS_TIME *time_out) | |
| 1000 { | |
| 1001 struct low_level_timeout *tm = *timeout_list; | |
| 1002 int id; | |
| 1003 | |
| 1004 assert (tm); | |
| 1005 id = tm->id; | |
| 1006 if (time_out) | |
| 1007 *time_out = tm->time; | |
| 1008 *timeout_list = tm->next; | |
| 1009 Blocktype_free (the_low_level_timeout_blocktype, tm); | |
| 1010 return id; | |
| 1011 } | |
| 1012 | |
| 1013 | |
| 593 | 1014 /**** High-level timeout functions. **** */ |
| 1015 | |
| 1016 /* We ensure that 0 is never a valid ID, so that a value of 0 can be | |
| 1017 used to indicate an absence of a timer. */ | |
| 428 | 1018 static int timeout_id_tick; |
| 1019 | |
| 1020 static Lisp_Object pending_timeout_list, pending_async_timeout_list; | |
| 1021 | |
| 1022 static Lisp_Object | |
| 1023 mark_timeout (Lisp_Object obj) | |
| 1024 { | |
| 440 | 1025 Lisp_Timeout *tm = XTIMEOUT (obj); |
| 428 | 1026 mark_object (tm->function); |
| 1027 return tm->object; | |
| 1028 } | |
| 1029 | |
| 1204 | 1030 static const struct memory_description timeout_description[] = { |
| 440 | 1031 { XD_LISP_OBJECT, offsetof (Lisp_Timeout, function) }, |
| 1032 { XD_LISP_OBJECT, offsetof (Lisp_Timeout, object) }, | |
| 428 | 1033 { XD_END } |
| 1034 }; | |
| 1035 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1036 DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("timeout", timeout, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1037 mark_timeout, timeout_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
1038 Lisp_Timeout); |
| 428 | 1039 |
| 1040 /* Generate a timeout and return its ID. */ | |
| 1041 | |
| 1042 int | |
| 1043 event_stream_generate_wakeup (unsigned int milliseconds, | |
| 1044 unsigned int vanilliseconds, | |
| 1045 Lisp_Object function, Lisp_Object object, | |
| 1046 int async_p) | |
| 1047 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1048 Lisp_Object op = ALLOC_NORMAL_LISP_OBJECT (timeout); |
| 440 | 1049 Lisp_Timeout *timeout = XTIMEOUT (op); |
| 428 | 1050 EMACS_TIME current_time; |
| 1051 EMACS_TIME interval; | |
| 1052 | |
| 593 | 1053 /* Don't just use ++timeout_id_tick, for the (admittedly rare) case |
| 1054 in which numbers wrap around. */ | |
| 1055 if (timeout_id_tick == 0) | |
| 1056 timeout_id_tick++; | |
| 428 | 1057 timeout->id = timeout_id_tick++; |
| 1058 timeout->resignal_msecs = vanilliseconds; | |
| 1059 timeout->function = function; | |
| 1060 timeout->object = object; | |
| 1061 | |
| 1062 EMACS_GET_TIME (current_time); | |
| 1063 EMACS_SET_SECS_USECS (interval, milliseconds / 1000, | |
| 1064 1000 * (milliseconds % 1000)); | |
| 1065 EMACS_ADD_TIME (timeout->next_signal_time, current_time, interval); | |
| 1066 | |
| 1067 if (async_p) | |
| 1068 { | |
| 1069 timeout->interval_id = | |
| 593 | 1070 signal_add_async_interval_timeout (timeout->next_signal_time); |
| 1071 pending_async_timeout_list = | |
| 1072 noseeum_cons (op, pending_async_timeout_list); | |
| 428 | 1073 } |
| 1074 else | |
| 1075 { | |
| 1076 timeout->interval_id = | |
| 1077 event_stream_add_timeout (timeout->next_signal_time); | |
| 1078 pending_timeout_list = noseeum_cons (op, pending_timeout_list); | |
| 1079 } | |
| 1080 return timeout->id; | |
| 1081 } | |
| 1082 | |
| 1083 /* Given the INTERVAL-ID of a timeout just signalled, resignal the timeout | |
| 1084 as necessary and return the timeout's ID and function and object slots. | |
| 1085 | |
| 1086 This should be called as a result of receiving notice that a timeout | |
| 1087 has fired. INTERVAL-ID is *not* the timeout's ID, but is the ID that | |
| 1088 identifies this particular firing of the timeout. INTERVAL-ID's and | |
| 1089 timeout ID's are in separate number spaces and bear no relation to | |
| 1090 each other. The INTERVAL-ID is all that the event callback routines | |
| 1091 work with: they work only with one-shot intervals, not with timeouts | |
| 1092 that may fire repeatedly. | |
| 1093 | |
| 1094 NOTE: The returned FUNCTION and OBJECT are *not* GC-protected at all. | |
| 1095 */ | |
| 1096 | |
| 593 | 1097 int |
| 428 | 1098 event_stream_resignal_wakeup (int interval_id, int async_p, |
| 1099 Lisp_Object *function, Lisp_Object *object) | |
| 1100 { | |
| 1101 Lisp_Object op = Qnil, rest; | |
| 440 | 1102 Lisp_Timeout *timeout; |
| 428 | 1103 Lisp_Object *timeout_list; |
| 1104 struct gcpro gcpro1; | |
| 1105 int id; | |
| 1106 | |
| 1107 GCPRO1 (op); /* just in case ... because it's removed from the list | |
| 1108 for awhile. */ | |
| 1109 | |
| 1110 timeout_list = async_p ? &pending_async_timeout_list : &pending_timeout_list; | |
| 1111 | |
| 1112 /* Find the timeout on the list of pending ones. */ | |
| 1113 LIST_LOOP (rest, *timeout_list) | |
| 1114 { | |
| 1115 timeout = XTIMEOUT (XCAR (rest)); | |
| 1116 if (timeout->interval_id == interval_id) | |
| 1117 break; | |
| 1118 } | |
| 1119 | |
| 1120 assert (!NILP (rest)); | |
| 1121 op = XCAR (rest); | |
| 1122 timeout = XTIMEOUT (op); | |
| 1123 /* We make sure to snarf the data out of the timeout object before | |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
1124 we free it with free_normal_lisp_object(). */ |
| 428 | 1125 id = timeout->id; |
| 1126 *function = timeout->function; | |
| 1127 *object = timeout->object; | |
| 1128 | |
| 1129 /* Remove this one from the list of pending timeouts */ | |
| 1130 *timeout_list = delq_no_quit_and_free_cons (op, *timeout_list); | |
| 1131 | |
| 1132 /* If this timeout wants to be resignalled, do it now. */ | |
| 1133 if (timeout->resignal_msecs) | |
| 1134 { | |
| 1135 EMACS_TIME current_time; | |
| 1136 EMACS_TIME interval; | |
| 1137 | |
| 1138 /* Determine the time that the next resignalling should occur. | |
| 1139 We do that by adding the interval time to the last signalled | |
| 1140 time until we get a time that's current. | |
| 1141 | |
| 1142 (This way, it doesn't matter if the timeout was signalled | |
| 1143 exactly when we asked for it, or at some time later.) | |
| 1144 */ | |
| 1145 EMACS_GET_TIME (current_time); | |
| 1146 EMACS_SET_SECS_USECS (interval, timeout->resignal_msecs / 1000, | |
| 1147 1000 * (timeout->resignal_msecs % 1000)); | |
| 1148 do | |
| 1149 { | |
| 1150 EMACS_ADD_TIME (timeout->next_signal_time, timeout->next_signal_time, | |
| 1151 interval); | |
| 1152 } while (EMACS_TIME_GREATER (current_time, timeout->next_signal_time)); | |
| 1153 | |
| 1154 if (async_p) | |
| 1155 timeout->interval_id = | |
| 593 | 1156 signal_add_async_interval_timeout (timeout->next_signal_time); |
| 428 | 1157 else |
| 1158 timeout->interval_id = | |
| 1159 event_stream_add_timeout (timeout->next_signal_time); | |
| 1160 /* Add back onto the list. Note that the effect of this | |
| 1161 is to move frequently-hit timeouts to the front of the | |
| 1162 list, which is a good thing. */ | |
| 1163 *timeout_list = noseeum_cons (op, *timeout_list); | |
| 1164 } | |
| 1165 else | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1166 free_normal_lisp_object (op); |
| 428 | 1167 |
| 1168 UNGCPRO; | |
| 1169 return id; | |
| 1170 } | |
| 1171 | |
| 1172 void | |
| 1173 event_stream_disable_wakeup (int id, int async_p) | |
| 1174 { | |
| 440 | 1175 Lisp_Timeout *timeout = 0; |
| 428 | 1176 Lisp_Object rest; |
| 1177 Lisp_Object *timeout_list; | |
| 1178 | |
| 1179 if (async_p) | |
| 1180 timeout_list = &pending_async_timeout_list; | |
| 1181 else | |
| 1182 timeout_list = &pending_timeout_list; | |
| 1183 | |
| 1184 /* Find the timeout on the list of pending ones, if it's still there. */ | |
| 1185 LIST_LOOP (rest, *timeout_list) | |
| 1186 { | |
| 1187 timeout = XTIMEOUT (XCAR (rest)); | |
| 1188 if (timeout->id == id) | |
| 1189 break; | |
| 1190 } | |
| 1191 | |
| 1192 /* If we found it, remove it from the list and disable the pending | |
| 1193 one-shot. */ | |
| 1194 if (!NILP (rest)) | |
| 1195 { | |
| 1196 Lisp_Object op = XCAR (rest); | |
| 1197 *timeout_list = | |
| 1198 delq_no_quit_and_free_cons (op, *timeout_list); | |
| 1199 if (async_p) | |
| 593 | 1200 signal_remove_async_interval_timeout (timeout->interval_id); |
| 428 | 1201 else |
| 1202 event_stream_remove_timeout (timeout->interval_id); | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
1203 free_normal_lisp_object (op); |
| 428 | 1204 } |
| 1205 } | |
| 1206 | |
| 1207 static int | |
| 1208 event_stream_wakeup_pending_p (int id, int async_p) | |
| 1209 { | |
| 440 | 1210 Lisp_Timeout *timeout; |
| 428 | 1211 Lisp_Object rest; |
| 1212 Lisp_Object timeout_list; | |
| 1213 int found = 0; | |
| 1214 | |
| 1215 | |
| 1216 if (async_p) | |
| 1217 timeout_list = pending_async_timeout_list; | |
| 1218 else | |
| 1219 timeout_list = pending_timeout_list; | |
| 1220 | |
| 1221 /* Find the element on the list of pending ones, if it's still there. */ | |
| 1222 LIST_LOOP (rest, timeout_list) | |
| 1223 { | |
| 1224 timeout = XTIMEOUT (XCAR (rest)); | |
| 1225 if (timeout->id == id) | |
| 1226 { | |
| 1227 found = 1; | |
| 1228 break; | |
| 1229 } | |
| 1230 } | |
| 1231 | |
| 1232 return found; | |
| 1233 } | |
| 1234 | |
| 1235 | |
| 1236 /**** Lisp-level timeout functions. ****/ | |
| 1237 | |
| 1238 static unsigned long | |
| 1239 lisp_number_to_milliseconds (Lisp_Object secs, int allow_0) | |
| 1240 { | |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1241 Lisp_Object args[] = { allow_0 ? Qzero : make_int (1), |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1242 secs, |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1243 /* (((unsigned int) 0xFFFFFFFF) / 1000) - 1 */ |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1244 make_int (4294967 - 1) }; |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1245 |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1246 if (!allow_0 && FLOATP (secs) && XFLOAT_DATA (secs) > 0) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1247 { |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1248 args[0] = secs; |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1249 } |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1250 |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1251 if (NILP (Fleq (countof (args), args))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1252 { |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1253 args_out_of_range_3 (secs, args[0], args[2]); |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1254 } |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1255 |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1256 args[0] = make_int (1000); |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1257 args[0] = Ftimes (2, args); |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1258 |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1259 if (INTP (args[0])) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1260 { |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1261 return XINT (args[0]); |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1262 } |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1263 |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
1264 return (unsigned long) extract_float (args[0]); |
| 428 | 1265 } |
| 1266 | |
| 1267 DEFUN ("add-timeout", Fadd_timeout, 3, 4, 0, /* | |
| 1268 Add a timeout, to be signaled after the timeout period has elapsed. | |
| 1269 SECS is a number of seconds, expressed as an integer or a float. | |
| 1270 FUNCTION will be called after that many seconds have elapsed, with one | |
| 1271 argument, the given OBJECT. If the optional RESIGNAL argument is provided, | |
| 1272 then after this timeout expires, `add-timeout' will automatically be called | |
| 1273 again with RESIGNAL as the first argument. | |
| 1274 | |
| 1275 This function returns an object which is the id number of this particular | |
| 1276 timeout. You can pass that object to `disable-timeout' to turn off the | |
| 1277 timeout before it has been signalled. | |
| 1278 | |
| 1279 NOTE: Id numbers as returned by this function are in a distinct namespace | |
| 1280 from those returned by `add-async-timeout'. This means that the same id | |
| 1281 number could refer to a pending synchronous timeout and a different pending | |
| 1282 asynchronous timeout, and that you cannot pass an id from `add-timeout' | |
| 1283 to `disable-async-timeout', or vice-versa. | |
| 1284 | |
| 1285 The number of seconds may be expressed as a floating-point number, in which | |
| 1286 case some fractional part of a second will be used. Caveat: the usable | |
| 1287 timeout granularity will vary from system to system. | |
| 1288 | |
| 1289 Adding a timeout causes a timeout event to be returned by `next-event', and | |
| 1290 the function will be invoked by `dispatch-event,' so if emacs is in a tight | |
| 1291 loop, the function will not be invoked until the next call to sit-for or | |
| 1292 until the return to top-level (the same is true of process filters). | |
| 1293 | |
| 1294 If you need to have a timeout executed even when XEmacs is in the midst of | |
| 1295 running Lisp code, use `add-async-timeout'. | |
| 1296 | |
| 1297 WARNING: if you are thinking of calling add-timeout from inside of a | |
| 1298 callback function as a way of resignalling a timeout, think again. There | |
| 1299 is a race condition. That's why the RESIGNAL argument exists. | |
| 1300 */ | |
| 1301 (secs, function, object, resignal)) | |
| 1302 { | |
| 1303 unsigned long msecs = lisp_number_to_milliseconds (secs, 0); | |
| 1304 unsigned long msecs2 = (NILP (resignal) ? 0 : | |
| 1305 lisp_number_to_milliseconds (resignal, 0)); | |
| 1306 int id; | |
| 1307 Lisp_Object lid; | |
| 1308 id = event_stream_generate_wakeup (msecs, msecs2, function, object, 0); | |
| 1309 lid = make_int (id); | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
4976
diff
changeset
|
1310 assert (id == XINT (lid)); |
| 428 | 1311 return lid; |
| 1312 } | |
| 1313 | |
| 1314 DEFUN ("disable-timeout", Fdisable_timeout, 1, 1, 0, /* | |
| 1315 Disable a timeout from signalling any more. | |
| 1316 ID should be a timeout id number as returned by `add-timeout'. If ID | |
| 1317 corresponds to a one-shot timeout that has already signalled, nothing | |
| 1318 will happen. | |
| 1319 | |
| 1320 It will not work to call this function on an id number returned by | |
| 1321 `add-async-timeout'. Use `disable-async-timeout' for that. | |
| 1322 */ | |
| 1323 (id)) | |
| 1324 { | |
| 1325 CHECK_INT (id); | |
| 1326 event_stream_disable_wakeup (XINT (id), 0); | |
| 1327 return Qnil; | |
| 1328 } | |
| 1329 | |
| 1330 DEFUN ("add-async-timeout", Fadd_async_timeout, 3, 4, 0, /* | |
| 1331 Add an asynchronous timeout, to be signaled after an interval has elapsed. | |
| 1332 SECS is a number of seconds, expressed as an integer or a float. | |
| 1333 FUNCTION will be called after that many seconds have elapsed, with one | |
| 1334 argument, the given OBJECT. If the optional RESIGNAL argument is provided, | |
| 1335 then after this timeout expires, `add-async-timeout' will automatically be | |
| 1336 called again with RESIGNAL as the first argument. | |
| 1337 | |
| 1338 This function returns an object which is the id number of this particular | |
| 1339 timeout. You can pass that object to `disable-async-timeout' to turn off | |
| 1340 the timeout before it has been signalled. | |
| 1341 | |
| 1342 NOTE: Id numbers as returned by this function are in a distinct namespace | |
| 1343 from those returned by `add-timeout'. This means that the same id number | |
| 1344 could refer to a pending synchronous timeout and a different pending | |
| 1345 asynchronous timeout, and that you cannot pass an id from | |
| 1346 `add-async-timeout' to `disable-timeout', or vice-versa. | |
| 1347 | |
| 1348 The number of seconds may be expressed as a floating-point number, in which | |
| 1349 case some fractional part of a second will be used. Caveat: the usable | |
| 1350 timeout granularity will vary from system to system. | |
| 1351 | |
| 1352 Adding an asynchronous timeout causes the function to be invoked as soon | |
| 1353 as the timeout occurs, even if XEmacs is in the midst of executing some | |
| 1354 other code. (This is unlike the synchronous timeouts added with | |
| 1355 `add-timeout', where the timeout will only be signalled when XEmacs is | |
| 1356 waiting for events, i.e. the next return to top-level or invocation of | |
| 1357 `sit-for' or related functions.) This means that the function that is | |
| 1358 called *must* not signal an error or change any global state (e.g. switch | |
| 1359 buffers or windows) except when locking code is in place to make sure | |
| 1360 that race conditions don't occur in the interaction between the | |
| 1361 asynchronous timeout function and other code. | |
| 1362 | |
| 1363 Under most circumstances, you should use `add-timeout' instead, as it is | |
| 1364 much safer. Asynchronous timeouts should only be used when such behavior | |
| 1365 is really necessary. | |
| 1366 | |
| 1367 Asynchronous timeouts are blocked and will not occur when `inhibit-quit' | |
| 1368 is non-nil. As soon as `inhibit-quit' becomes nil again, any pending | |
| 1369 asynchronous timeouts will get called immediately. (Multiple occurrences | |
| 1370 of the same asynchronous timeout are not queued, however.) While the | |
| 1371 callback function of an asynchronous timeout is invoked, `inhibit-quit' | |
| 1372 is automatically bound to non-nil, and thus other asynchronous timeouts | |
| 1373 will be blocked unless the callback function explicitly sets `inhibit-quit' | |
| 1374 to nil. | |
| 1375 | |
| 1376 WARNING: if you are thinking of calling `add-async-timeout' from inside of a | |
| 1377 callback function as a way of resignalling a timeout, think again. There | |
| 1378 is a race condition. That's why the RESIGNAL argument exists. | |
| 1379 */ | |
| 1380 (secs, function, object, resignal)) | |
| 1381 { | |
| 1382 unsigned long msecs = lisp_number_to_milliseconds (secs, 0); | |
| 1383 unsigned long msecs2 = (NILP (resignal) ? 0 : | |
| 1384 lisp_number_to_milliseconds (resignal, 0)); | |
| 1385 int id; | |
| 1386 Lisp_Object lid; | |
| 1387 id = event_stream_generate_wakeup (msecs, msecs2, function, object, 1); | |
| 1388 lid = make_int (id); | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
4976
diff
changeset
|
1389 assert (id == XINT (lid)); |
| 428 | 1390 return lid; |
| 1391 } | |
| 1392 | |
| 1393 DEFUN ("disable-async-timeout", Fdisable_async_timeout, 1, 1, 0, /* | |
| 1394 Disable an asynchronous timeout from signalling any more. | |
| 1395 ID should be a timeout id number as returned by `add-async-timeout'. If ID | |
| 1396 corresponds to a one-shot timeout that has already signalled, nothing | |
| 1397 will happen. | |
| 1398 | |
| 1399 It will not work to call this function on an id number returned by | |
| 1400 `add-timeout'. Use `disable-timeout' for that. | |
| 1401 */ | |
| 1402 (id)) | |
| 1403 { | |
| 1404 CHECK_INT (id); | |
| 1405 event_stream_disable_wakeup (XINT (id), 1); | |
| 1406 return Qnil; | |
| 1407 } | |
| 1408 | |
| 1409 | |
| 1410 /**********************************************************************/ | |
| 1411 /* enqueuing and dequeuing events */ | |
| 1412 /**********************************************************************/ | |
| 1413 | |
| 1414 /* Add an event to the back of the command-event queue: it will be the next | |
| 1415 event read after all pending events. This only works on keyboard, | |
| 1416 mouse-click, misc-user, and eval events. | |
| 1417 */ | |
| 1418 static void | |
| 1419 enqueue_command_event (Lisp_Object event) | |
| 1420 { | |
| 1421 enqueue_event (event, &command_event_queue, &command_event_queue_tail); | |
| 1422 } | |
| 1423 | |
| 1424 static Lisp_Object | |
| 1425 dequeue_command_event (void) | |
| 1426 { | |
| 1427 return dequeue_event (&command_event_queue, &command_event_queue_tail); | |
| 1428 } | |
| 1429 | |
| 1204 | 1430 void |
| 1431 enqueue_dispatch_event (Lisp_Object event) | |
| 1432 { | |
| 1433 enqueue_event (event, &dispatch_event_queue, &dispatch_event_queue_tail); | |
| 1434 } | |
| 1435 | |
| 1436 Lisp_Object | |
| 1437 dequeue_dispatch_event (void) | |
| 1438 { | |
| 1439 return dequeue_event (&dispatch_event_queue, &dispatch_event_queue_tail); | |
| 1440 } | |
| 1441 | |
| 428 | 1442 static void |
| 1443 enqueue_command_event_1 (Lisp_Object event_to_copy) | |
| 1444 { | |
| 853 | 1445 enqueue_command_event (Fcopy_event (event_to_copy, Qnil)); |
| 428 | 1446 } |
| 1447 | |
| 1448 void | |
| 1449 enqueue_magic_eval_event (void (*fun) (Lisp_Object), Lisp_Object object) | |
| 1450 { | |
| 1451 Lisp_Object event = Fmake_event (Qnil, Qnil); | |
| 934 | 1452 XSET_EVENT_TYPE (event, magic_eval_event); |
| 1453 /* channel for magic_eval events is nil */ | |
| 1204 | 1454 XSET_EVENT_MAGIC_EVAL_INTERNAL_FUNCTION (event, fun); |
| 1455 XSET_EVENT_MAGIC_EVAL_OBJECT (event, object); | |
| 428 | 1456 enqueue_command_event (event); |
| 1457 } | |
| 1458 | |
| 1459 DEFUN ("enqueue-eval-event", Fenqueue_eval_event, 2, 2, 0, /* | |
| 1460 Add an eval event to the back of the eval event queue. | |
| 1461 When this event is dispatched, FUNCTION (which should be a function | |
| 1462 of one argument) will be called with OBJECT as its argument. | |
| 1463 See `next-event' for a description of event types and how events | |
| 1464 are received. | |
| 1465 */ | |
| 1466 (function, object)) | |
| 1467 { | |
| 1468 Lisp_Object event = Fmake_event (Qnil, Qnil); | |
| 1469 | |
| 934 | 1470 XSET_EVENT_TYPE (event, eval_event); |
| 1471 /* channel for eval events is nil */ | |
| 1204 | 1472 XSET_EVENT_EVAL_FUNCTION (event, function); |
| 1473 XSET_EVENT_EVAL_OBJECT (event, object); | |
| 428 | 1474 enqueue_command_event (event); |
| 1475 | |
| 1476 return event; | |
| 1477 } | |
| 1478 | |
| 1479 Lisp_Object | |
| 1480 enqueue_misc_user_event (Lisp_Object channel, Lisp_Object function, | |
| 1481 Lisp_Object object) | |
| 1482 { | |
| 1483 Lisp_Object event = Fmake_event (Qnil, Qnil); | |
| 934 | 1484 XSET_EVENT_TYPE (event, misc_user_event); |
| 1485 XSET_EVENT_CHANNEL (event, channel); | |
| 1204 | 1486 XSET_EVENT_MISC_USER_FUNCTION (event, function); |
| 1487 XSET_EVENT_MISC_USER_OBJECT (event, object); | |
| 1488 XSET_EVENT_MISC_USER_BUTTON (event, 0); | |
| 1489 XSET_EVENT_MISC_USER_MODIFIERS (event, 0); | |
| 1490 XSET_EVENT_MISC_USER_X (event, -1); | |
| 1491 XSET_EVENT_MISC_USER_Y (event, -1); | |
| 428 | 1492 enqueue_command_event (event); |
| 1493 | |
| 1494 return event; | |
| 1495 } | |
| 1496 | |
| 1497 Lisp_Object | |
| 1498 enqueue_misc_user_event_pos (Lisp_Object channel, Lisp_Object function, | |
| 1499 Lisp_Object object, | |
| 1500 int button, int modifiers, int x, int y) | |
| 1501 { | |
| 1502 Lisp_Object event = Fmake_event (Qnil, Qnil); | |
| 1503 | |
| 934 | 1504 XSET_EVENT_TYPE (event, misc_user_event); |
| 1505 XSET_EVENT_CHANNEL (event, channel); | |
| 1204 | 1506 XSET_EVENT_MISC_USER_FUNCTION (event, function); |
| 1507 XSET_EVENT_MISC_USER_OBJECT (event, object); | |
| 1508 XSET_EVENT_MISC_USER_BUTTON (event, button); | |
| 1509 XSET_EVENT_MISC_USER_MODIFIERS (event, modifiers); | |
| 1510 XSET_EVENT_MISC_USER_X (event, x); | |
| 1511 XSET_EVENT_MISC_USER_Y (event, y); | |
| 428 | 1512 enqueue_command_event (event); |
| 1513 | |
| 1514 return event; | |
| 1515 } | |
| 1516 | |
| 1517 | |
| 1518 /**********************************************************************/ | |
| 1519 /* focus-event handling */ | |
| 1520 /**********************************************************************/ | |
| 1521 | |
| 1522 /* | |
| 1523 | |
| 2367 | 1524 See also |
| 1525 | |
| 1526 (Info-goto-node "(internals)Focus Handling") | |
| 428 | 1527 */ |
| 1528 | |
| 2367 | 1529 |
| 428 | 1530 static void |
| 1531 run_select_frame_hook (void) | |
| 1532 { | |
| 1533 run_hook (Qselect_frame_hook); | |
| 1534 } | |
| 1535 | |
| 1536 static void | |
| 1537 run_deselect_frame_hook (void) | |
| 1538 { | |
| 1539 run_hook (Qdeselect_frame_hook); | |
| 1540 } | |
| 1541 | |
| 1542 /* When select-frame is called and focus_follows_mouse is false, we want | |
| 1543 to tell the window system that the focus should be changed to point to | |
| 1544 the new frame. However, | |
| 1545 sometimes Lisp functions will temporarily change the selected frame | |
| 1546 (e.g. to call a function that operates on the selected frame), | |
| 1547 and it's annoying if this focus-change happens exactly when | |
| 1548 select-frame is called, because then you get some flickering of the | |
| 1549 window-manager border and perhaps other undesirable results. We | |
| 1550 really only want to change the focus when we're about to retrieve | |
| 1551 an event from the user. To do this, we keep track of the frame | |
| 1552 where the window-manager focus lies on, and just before waiting | |
| 1553 for user events, check the currently selected frame and change | |
| 1554 the focus as necessary. | |
| 1555 | |
| 1556 On the other hand, if focus_follows_mouse is true, we need to switch the | |
| 1557 selected frame back to the frame with window manager focus just before we | |
| 1558 execute the next command in Fcommand_loop_1, just as the selected buffer is | |
| 1559 reverted after a set-buffer. | |
| 1560 | |
| 1561 Both cases are handled by this function. It must be called as appropriate | |
| 1562 from these two places, depending on the value of focus_follows_mouse. */ | |
| 1563 | |
| 1564 void | |
| 1565 investigate_frame_change (void) | |
| 1566 { | |
| 1567 Lisp_Object devcons, concons; | |
| 1568 | |
| 1569 /* if the selected frame was changed, change the window-system | |
| 1570 focus to the new frame. We don't do it when select-frame was | |
| 1571 called, to avoid flickering and other unwanted side effects when | |
| 1572 the frame is just changed temporarily. */ | |
| 1573 DEVICE_LOOP_NO_BREAK (devcons, concons) | |
| 1574 { | |
| 1575 struct device *d = XDEVICE (XCAR (devcons)); | |
| 1576 Lisp_Object sel_frame = DEVICE_SELECTED_FRAME (d); | |
| 1577 | |
| 1578 /* You'd think that maybe we should use FRAME_WITH_FOCUS_REAL, | |
| 1579 but that can cause us to end up in an infinite loop focusing | |
| 1580 between two frames. It seems that since the call to `select-frame' | |
| 1581 in emacs_handle_focus_change_final() is based on the _FOR_HOOKS | |
| 1582 value, we need to do so too. */ | |
| 1583 if (!NILP (sel_frame) && | |
| 1584 !EQ (DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d), sel_frame) && | |
| 1585 !NILP (DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d)) && | |
| 1586 !EQ (DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d), sel_frame)) | |
| 1587 { | |
| 1588 /* At this point, we know that the frame has been changed. Now, if | |
| 1589 * focus_follows_mouse is not set, we finish off the frame change, | |
| 1590 * so that user events will now come from the new frame. Otherwise, | |
| 1591 * if focus_follows_mouse is set, no gratuitous frame changing | |
| 1592 * should take place. Set the focus back to the frame which was | |
| 1593 * originally selected for user input. | |
| 1594 */ | |
| 1595 if (!focus_follows_mouse) | |
| 1596 { | |
| 1597 /* prevent us from issuing the same request more than once */ | |
| 1598 DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d) = sel_frame; | |
| 1599 MAYBE_DEVMETH (d, focus_on_frame, (XFRAME (sel_frame))); | |
| 1600 } | |
| 1601 else | |
| 1602 { | |
| 1603 Lisp_Object old_frame = Qnil; | |
| 1604 | |
| 1605 /* #### Do we really want to check OUGHT ?? | |
| 1606 * It seems to make sense, though I have never seen us | |
| 1607 * get here and have it be non-nil. | |
| 1608 */ | |
| 1609 if (FRAMEP (DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d))) | |
| 1610 old_frame = DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d); | |
| 1611 else if (FRAMEP (DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d))) | |
| 1612 old_frame = DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d); | |
| 1613 | |
| 1614 /* #### Can old_frame ever be NIL? play it safe.. */ | |
| 1615 if (!NILP (old_frame)) | |
| 1616 { | |
| 1617 /* Fselect_frame is not really the right thing: it frobs the | |
| 1618 * buffer stack. But there's no easy way to do the right | |
| 1619 * thing, and this code already had this problem anyway. | |
| 1620 */ | |
| 1621 Fselect_frame (old_frame); | |
| 1622 } | |
| 1623 } | |
| 1624 } | |
| 1625 } | |
| 1626 } | |
| 1627 | |
| 1628 static Lisp_Object | |
| 1629 cleanup_after_missed_defocusing (Lisp_Object frame) | |
| 1630 { | |
| 1631 if (FRAMEP (frame) && FRAME_LIVE_P (XFRAME (frame))) | |
| 1632 Fselect_frame (frame); | |
| 1633 return Qnil; | |
| 1634 } | |
| 1635 | |
| 1636 void | |
| 1637 emacs_handle_focus_change_preliminary (Lisp_Object frame_inp_and_dev) | |
| 1638 { | |
| 1639 Lisp_Object frame = Fcar (frame_inp_and_dev); | |
| 1640 Lisp_Object device = Fcar (Fcdr (frame_inp_and_dev)); | |
| 1641 int in_p = !NILP (Fcdr (Fcdr (frame_inp_and_dev))); | |
| 1642 struct device *d; | |
| 1643 | |
| 1644 if (!DEVICE_LIVE_P (XDEVICE (device))) | |
| 1645 return; | |
| 1646 else | |
| 1647 d = XDEVICE (device); | |
| 1648 | |
| 1649 /* Any received focus-change notifications render invalid any | |
| 1650 pending focus-change requests. */ | |
| 1651 DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d) = Qnil; | |
| 1652 if (in_p) | |
| 1653 { | |
| 1654 Lisp_Object focus_frame; | |
| 1655 | |
| 1656 if (!FRAME_LIVE_P (XFRAME (frame))) | |
| 1657 return; | |
| 1658 else | |
| 1659 focus_frame = DEVICE_FRAME_WITH_FOCUS_REAL (d); | |
| 1660 | |
| 1661 /* Mark the minibuffer as changed to make sure it gets updated | |
| 1662 properly if the echo area is active. */ | |
| 1663 { | |
| 1664 struct window *w = XWINDOW (FRAME_MINIBUF_WINDOW (XFRAME (frame))); | |
| 1665 MARK_WINDOWS_CHANGED (w); | |
| 1666 } | |
| 1667 | |
| 452 | 1668 if (FRAMEP (focus_frame) && FRAME_LIVE_P (XFRAME (focus_frame)) |
| 1669 && !EQ (frame, focus_frame)) | |
| 428 | 1670 { |
| 1671 /* Oops, we missed a focus-out event. */ | |
| 1672 DEVICE_FRAME_WITH_FOCUS_REAL (d) = Qnil; | |
| 1673 redisplay_redraw_cursor (XFRAME (focus_frame), 1); | |
| 1674 } | |
| 1675 DEVICE_FRAME_WITH_FOCUS_REAL (d) = frame; | |
| 1676 if (!EQ (frame, focus_frame)) | |
| 1677 { | |
| 1678 redisplay_redraw_cursor (XFRAME (frame), 1); | |
| 1679 } | |
| 1680 } | |
| 1681 else | |
| 1682 { | |
| 1683 /* We ignore the frame reported in the event. If it's different | |
| 1684 from where we think the focus was, oh well -- we messed up. | |
| 1685 Nonetheless, we pretend we were right, for sensible behavior. */ | |
| 1686 frame = DEVICE_FRAME_WITH_FOCUS_REAL (d); | |
| 1687 if (!NILP (frame)) | |
| 1688 { | |
| 1689 DEVICE_FRAME_WITH_FOCUS_REAL (d) = Qnil; | |
| 1690 | |
| 1691 if (FRAME_LIVE_P (XFRAME (frame))) | |
| 1692 redisplay_redraw_cursor (XFRAME (frame), 1); | |
| 1693 } | |
| 1694 } | |
| 1695 } | |
| 1696 | |
| 1697 /* Called from the window-system-specific code when we receive a | |
| 1698 notification that the focus lies on a particular frame. | |
| 1699 Argument is a cons: (frame . (device . in-p)) where in-p is non-nil | |
| 1700 for focus-in. | |
| 1701 */ | |
| 1702 void | |
| 1703 emacs_handle_focus_change_final (Lisp_Object frame_inp_and_dev) | |
| 1704 { | |
| 1705 Lisp_Object frame = Fcar (frame_inp_and_dev); | |
| 1706 Lisp_Object device = Fcar (Fcdr (frame_inp_and_dev)); | |
| 1707 int in_p = !NILP (Fcdr (Fcdr (frame_inp_and_dev))); | |
| 1708 struct device *d; | |
| 1709 int count; | |
| 1710 | |
| 1711 if (!DEVICE_LIVE_P (XDEVICE (device))) | |
| 1712 return; | |
| 1713 else | |
| 1714 d = XDEVICE (device); | |
| 1715 | |
| 1716 if (in_p) | |
| 1717 { | |
| 1718 Lisp_Object focus_frame; | |
| 1719 | |
| 1720 if (!FRAME_LIVE_P (XFRAME (frame))) | |
| 1721 return; | |
| 1722 else | |
| 1723 focus_frame = DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d); | |
| 1724 | |
| 1725 DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d) = frame; | |
| 1726 if (FRAMEP (focus_frame) && !EQ (frame, focus_frame)) | |
| 1727 { | |
| 1728 /* Oops, we missed a focus-out event. */ | |
| 1729 Fselect_frame (focus_frame); | |
| 1730 /* Do an unwind-protect in case an error occurs in | |
| 1731 the deselect-frame-hook */ | |
| 1732 count = specpdl_depth (); | |
| 1733 record_unwind_protect (cleanup_after_missed_defocusing, frame); | |
| 1734 run_deselect_frame_hook (); | |
| 771 | 1735 unbind_to (count); |
| 428 | 1736 /* the cleanup method changed the focus frame to nil, so |
| 1737 we need to reflect this */ | |
| 1738 focus_frame = Qnil; | |
| 1739 } | |
| 1740 else | |
| 1741 Fselect_frame (frame); | |
| 1742 if (!EQ (frame, focus_frame)) | |
| 1743 run_select_frame_hook (); | |
| 1744 } | |
| 1745 else | |
| 1746 { | |
| 1747 /* We ignore the frame reported in the event. If it's different | |
| 1748 from where we think the focus was, oh well -- we messed up. | |
| 1749 Nonetheless, we pretend we were right, for sensible behavior. */ | |
| 1750 frame = DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d); | |
| 1751 if (!NILP (frame)) | |
| 1752 { | |
| 1753 DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d) = Qnil; | |
| 1754 run_deselect_frame_hook (); | |
| 1755 } | |
| 1756 } | |
| 1757 } | |
| 1758 | |
| 1759 | |
| 1760 /**********************************************************************/ | |
| 1268 | 1761 /* input pending/quit checking */ |
| 1762 /**********************************************************************/ | |
| 1763 | |
| 1764 /* If HOW_MANY is 0, return true if there are any user or non-user events | |
| 1765 pending. If HOW_MANY is > 0, return true if there are that many *user* | |
| 1766 events pending, irrespective of non-user events. */ | |
| 1767 | |
| 1768 static int | |
| 1769 event_stream_event_pending_p (int how_many) | |
| 1770 { | |
| 1771 /* #### Hmmm ... There may be some duplication in "drain queue" and | |
| 1772 "event pending". Couldn't we just drain the queue and see what's in | |
| 1773 it, and not maybe need a separate event method for this? Would this | |
| 1774 work when HOW_MANY is 0? Maybe this would be slow? */ | |
| 1775 return event_stream && event_stream->event_pending_p (how_many); | |
| 1776 } | |
| 1777 | |
| 1778 static void | |
| 1779 event_stream_force_event_pending (struct frame *f) | |
| 1780 { | |
| 1781 if (event_stream->force_event_pending_cb) | |
| 1782 event_stream->force_event_pending_cb (f); | |
| 1783 } | |
| 1784 | |
| 1785 void | |
| 1786 event_stream_drain_queue (void) | |
| 1787 { | |
| 1318 | 1788 /* This can call Lisp */ |
| 1268 | 1789 if (event_stream && event_stream->drain_queue_cb) |
| 1790 event_stream->drain_queue_cb (); | |
| 1791 } | |
| 1792 | |
| 1793 /* Return non-zero if at least HOW_MANY user events are pending. */ | |
| 1794 int | |
| 1795 detect_input_pending (int how_many) | |
| 1796 { | |
| 1318 | 1797 /* This can call Lisp */ |
| 1268 | 1798 Lisp_Object event; |
| 1799 | |
| 1800 if (!NILP (Vunread_command_event)) | |
| 1801 how_many--; | |
| 1802 | |
| 1803 how_many -= XINT (Fsafe_length (Vunread_command_events)); | |
| 1804 | |
| 1805 if (how_many <= 0) | |
| 1806 return 1; | |
| 1807 | |
| 1808 EVENT_CHAIN_LOOP (event, command_event_queue) | |
| 1809 { | |
| 1810 if (XEVENT_TYPE (event) != eval_event | |
| 1811 && XEVENT_TYPE (event) != magic_eval_event) | |
| 1812 { | |
| 1813 how_many--; | |
| 1814 if (how_many <= 0) | |
| 1815 return 1; | |
| 1816 } | |
| 1817 } | |
| 1818 | |
| 1819 return event_stream_event_pending_p (how_many); | |
| 1820 } | |
| 1821 | |
| 1822 DEFUN ("input-pending-p", Finput_pending_p, 0, 0, 0, /* | |
| 1823 Return t if command input is currently available with no waiting. | |
| 1824 Actually, the value is nil only if we can be sure that no input is available. | |
| 1825 */ | |
| 1826 ()) | |
| 1827 { | |
| 1318 | 1828 /* This can call Lisp */ |
| 1268 | 1829 return detect_input_pending (1) ? Qt : Qnil; |
| 1830 } | |
| 1831 | |
| 1832 static int | |
| 1833 maybe_read_quit_event (Lisp_Event *event) | |
| 1834 { | |
| 1835 /* A C-g that came from `sigint_happened' will always come from the | |
| 1836 controlling terminal. If that doesn't exist, however, then the | |
| 1837 user manually sent us a SIGINT, and we pretend the C-g came from | |
| 1838 the selected console. */ | |
| 1839 struct console *con; | |
| 1840 | |
| 1841 if (CONSOLEP (Vcontrolling_terminal) && | |
| 1842 CONSOLE_LIVE_P (XCONSOLE (Vcontrolling_terminal))) | |
| 1843 con = XCONSOLE (Vcontrolling_terminal); | |
| 1844 else | |
| 1845 con = XCONSOLE (Fselected_console ()); | |
| 1846 | |
| 1847 if (sigint_happened) | |
| 1848 { | |
| 1849 sigint_happened = 0; | |
| 1850 Vquit_flag = Qnil; | |
| 1851 Fcopy_event (CONSOLE_QUIT_EVENT (con), wrap_event (event)); | |
| 1852 return 1; | |
| 1853 } | |
| 1854 return 0; | |
| 1855 } | |
| 1856 | |
| 1857 struct remove_quit_p_data | |
| 1858 { | |
| 1859 int critical; | |
| 1860 }; | |
| 1861 | |
| 1862 static int | |
| 1863 remove_quit_p_event (Lisp_Object ev, void *the_data) | |
| 1864 { | |
| 1865 struct remove_quit_p_data *data = (struct remove_quit_p_data *) the_data; | |
| 1866 struct console *con = event_console_or_selected (ev); | |
| 1867 | |
| 1868 if (XEVENT_TYPE (ev) == key_press_event) | |
| 1869 { | |
| 1870 if (event_matches_key_specifier_p (ev, CONSOLE_QUIT_EVENT (con))) | |
| 1871 return 1; | |
| 1872 if (event_matches_key_specifier_p (ev, | |
| 1873 CONSOLE_CRITICAL_QUIT_EVENT (con))) | |
| 1874 { | |
| 1875 data->critical = 1; | |
| 1876 return 1; | |
| 1877 } | |
| 1878 } | |
| 1879 | |
| 1880 return 0; | |
| 1881 } | |
| 1882 | |
| 1883 void | |
| 1884 event_stream_quit_p (void) | |
| 1885 { | |
| 1318 | 1886 /* This can call Lisp */ |
| 1268 | 1887 struct remove_quit_p_data data; |
| 1888 | |
| 1889 /* Quit checking cannot happen in modal loop. Because it attempts to | |
| 1890 retrieve and dispatch events, it will cause lots of problems if we try | |
| 1891 to do this when already in the process of doing this -- deadlocking | |
| 1892 under Windows, crashes in lwlib etc. under X due to non-reentrant | |
| 1893 code. This is automatically caught, however, in | |
| 1894 event_stream_drain_queue() (checks for in_modal_loop in the | |
| 1895 event-specific code). */ | |
| 1896 | |
| 1897 /* Drain queue so we can check for pending C-g events. */ | |
| 1898 event_stream_drain_queue (); | |
| 1899 data.critical = 0; | |
| 1900 | |
| 1901 if (map_event_chain_remove (remove_quit_p_event, | |
| 1902 &dispatch_event_queue, | |
| 1903 &dispatch_event_queue_tail, | |
| 1904 &data, MECR_DEALLOCATE_EVENT)) | |
| 1905 Vquit_flag = data.critical ? Qcritical : Qt; | |
| 1906 } | |
| 1907 | |
| 1908 Lisp_Object | |
| 1909 event_stream_protect_modal_loop (const char *error_string, | |
| 1910 Lisp_Object (*bfun) (void *barg), | |
| 1911 void *barg, int flags) | |
| 1912 { | |
| 1913 Lisp_Object tmp; | |
| 1914 | |
| 1915 ++in_modal_loop; | |
| 1916 tmp = call_trapping_problems (Qevent, error_string, flags, 0, bfun, barg); | |
| 1917 --in_modal_loop; | |
| 1918 | |
| 1919 return tmp; | |
| 1920 } | |
| 1921 | |
| 1922 | |
| 1923 /**********************************************************************/ | |
| 428 | 1924 /* retrieving the next event */ |
| 1925 /**********************************************************************/ | |
| 1926 | |
| 1927 static int in_single_console; | |
| 1928 | |
| 1929 /* #### These functions don't currently do anything. */ | |
| 1930 void | |
| 1931 single_console_state (void) | |
| 1932 { | |
| 1933 in_single_console = 1; | |
| 1934 } | |
| 1935 | |
| 1936 void | |
| 1937 any_console_state (void) | |
| 1938 { | |
| 1939 in_single_console = 0; | |
| 1940 } | |
| 1941 | |
| 1942 int | |
| 1943 in_single_console_state (void) | |
| 1944 { | |
| 1945 return in_single_console; | |
| 1946 } | |
| 1947 | |
| 1268 | 1948 static void |
| 1949 event_stream_next_event (Lisp_Event *event) | |
| 1950 { | |
| 1951 Lisp_Object event_obj; | |
| 1952 | |
| 1953 check_event_stream_ok (); | |
| 1954 | |
| 1955 event_obj = wrap_event (event); | |
| 1956 zero_event (event); | |
| 1957 /* SIGINT occurs when C-g was pressed on a TTY. (SIGINT might have | |
| 1958 been sent manually by the user, but we don't care; we treat it | |
| 1959 the same.) | |
| 1960 | |
| 1961 The SIGINT signal handler sets Vquit_flag as well as sigint_happened | |
| 1962 and write a byte on our "fake pipe", which unblocks us when we are | |
| 1963 waiting for an event. */ | |
| 1964 | |
| 1965 /* If SIGINT was received after we disabled quit checking (because | |
| 1966 we want to read C-g's as characters), but before we got a chance | |
| 1967 to start reading, notice it now and treat it as a character to be | |
| 1968 read. If above callers wanted this to be QUIT, they can | |
| 1969 determine this by comparing the event against quit-char. */ | |
| 1970 | |
| 1971 if (maybe_read_quit_event (event)) | |
| 1972 { | |
| 1973 DEBUG_PRINT_EMACS_EVENT ("SIGINT", event_obj); | |
| 1974 return; | |
| 1975 } | |
| 1976 | |
| 1977 /* If a longjmp() happens in the callback, we're screwed. | |
| 1978 Let's hope it doesn't. I think the code here is fairly | |
| 1979 clean and doesn't do this. */ | |
| 1980 emacs_is_blocking = 1; | |
| 1981 event_stream->next_event_cb (event); | |
| 1982 emacs_is_blocking = 0; | |
| 1983 | |
| 1984 /* Now check to see if C-g was pressed while we were blocking. | |
| 1985 We treat it as an event, just like above. */ | |
| 1986 if (maybe_read_quit_event (event)) | |
| 1987 { | |
| 1988 DEBUG_PRINT_EMACS_EVENT ("SIGINT", event_obj); | |
| 1989 return; | |
| 1990 } | |
| 1991 | |
| 1992 #ifdef DEBUG_XEMACS | |
| 1993 /* timeout events have more info set later, so | |
| 1994 print the event out in next_event_internal(). */ | |
| 1995 if (event->event_type != timeout_event) | |
| 1996 DEBUG_PRINT_EMACS_EVENT ("real", event_obj); | |
| 1997 #endif | |
| 1998 maybe_kbd_translate (event_obj); | |
| 1999 } | |
| 428 | 2000 |
| 853 | 2001 /* Read an event from the window system (or tty). If ALLOW_QUEUED is |
| 2002 non-zero, read from the command-event queue first. | |
| 2003 | |
| 2004 If C-g was pressed, this function will attempt to QUIT. If you want | |
| 2005 to read C-g as an event, wrap this function with a call to | |
| 2006 begin_dont_check_for_quit(), and set Vquit_flag to Qnil just before | |
| 2007 you unbind. In this case, TARGET_EVENT will contain a C-g. | |
| 2008 | |
| 2009 Note that even if you are interested in C-g doing QUIT, a caller of you | |
| 2010 might not be. | |
| 2011 */ | |
| 2012 | |
| 428 | 2013 static void |
| 2014 next_event_internal (Lisp_Object target_event, int allow_queued) | |
| 2015 { | |
| 2016 struct gcpro gcpro1; | |
| 1292 | 2017 PROFILE_DECLARE (); |
| 2018 | |
| 853 | 2019 QUIT; |
| 428 | 2020 |
| 1292 | 2021 PROFILE_RECORD_ENTERING_SECTION (QSnext_event_internal); |
| 2022 | |
| 428 | 2023 assert (NILP (XEVENT_NEXT (target_event))); |
| 2024 | |
| 2025 GCPRO1 (target_event); | |
| 2026 | |
| 2027 /* When focus_follows_mouse is nil, if a frame change took place, we need | |
| 2028 * to actually switch window manager focus to the selected window now. | |
| 2029 */ | |
| 2030 if (!focus_follows_mouse) | |
| 2031 investigate_frame_change (); | |
| 2032 | |
| 2033 if (allow_queued && !NILP (command_event_queue)) | |
| 2034 { | |
| 2035 Lisp_Object event = dequeue_command_event (); | |
| 2036 Fcopy_event (event, target_event); | |
| 2037 Fdeallocate_event (event); | |
| 2038 DEBUG_PRINT_EMACS_EVENT ("command event queue", target_event); | |
| 2039 } | |
| 2040 else | |
| 2041 { | |
| 440 | 2042 Lisp_Event *e = XEVENT (target_event); |
| 428 | 2043 |
| 2044 /* The command_event_queue was empty. Wait for an event. */ | |
| 2045 event_stream_next_event (e); | |
| 2046 /* If this was a timeout, then we need to extract some data | |
| 2047 out of the returned closure and might need to resignal | |
| 2048 it. */ | |
| 934 | 2049 if (EVENT_TYPE (e) == timeout_event) |
| 428 | 2050 { |
| 2051 Lisp_Object tristan, isolde; | |
| 2052 | |
| 1204 | 2053 SET_EVENT_TIMEOUT_ID_NUMBER (e, |
| 2054 event_stream_resignal_wakeup (EVENT_TIMEOUT_INTERVAL_ID (e), 0, &tristan, &isolde)); | |
| 2055 | |
| 2056 SET_EVENT_TIMEOUT_FUNCTION (e, tristan); | |
| 2057 SET_EVENT_TIMEOUT_OBJECT (e, isolde); | |
| 934 | 2058 /* next_event_internal() doesn't print out timeout events |
| 2059 because of the extra info we just set. */ | |
| 428 | 2060 DEBUG_PRINT_EMACS_EVENT ("real, timeout", target_event); |
| 2061 } | |
| 2062 | |
| 853 | 2063 /* If we read a ^G, then set quit-flag and try to QUIT. |
| 2064 This may be blocked (see above). | |
| 428 | 2065 */ |
| 934 | 2066 if (EVENT_TYPE (e) == key_press_event && |
| 428 | 2067 event_matches_key_specifier_p |
| 1204 | 2068 (target_event, CONSOLE_QUIT_EVENT (XCONSOLE (EVENT_CHANNEL (e))))) |
| 428 | 2069 { |
| 2070 Vquit_flag = Qt; | |
| 853 | 2071 QUIT; |
| 428 | 2072 } |
| 2073 } | |
| 2074 | |
| 2075 UNGCPRO; | |
| 1292 | 2076 |
| 2077 PROFILE_RECORD_EXITING_SECTION (QSnext_event_internal); | |
| 428 | 2078 } |
| 2079 | |
| 853 | 2080 void |
| 428 | 2081 run_pre_idle_hook (void) |
| 2082 { | |
| 1318 | 2083 /* This can call Lisp */ |
| 428 | 2084 if (!NILP (Vpre_idle_hook) |
| 1268 | 2085 && !detect_input_pending (1)) |
| 853 | 2086 safe_run_hook_trapping_problems |
| 1333 | 2087 (Qredisplay, Qpre_idle_hook, |
| 1268 | 2088 /* Quit is inhibited as a result of being within next-event so |
| 2089 we need to fix that. */ | |
| 2090 INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION | UNINHIBIT_QUIT); | |
| 428 | 2091 } |
| 2092 | |
| 2093 DEFUN ("next-event", Fnext_event, 0, 2, 0, /* | |
| 2094 Return the next available event. | |
| 2095 Pass this object to `dispatch-event' to handle it. | |
| 2096 In most cases, you will want to use `next-command-event', which returns | |
| 2097 the next available "user" event (i.e. keypress, button-press, | |
| 2098 button-release, or menu selection) instead of this function. | |
| 2099 | |
| 2100 If EVENT is non-nil, it should be an event object and will be filled in | |
| 2101 and returned; otherwise a new event object will be created and returned. | |
| 2102 If PROMPT is non-nil, it should be a string and will be displayed in the | |
| 2103 echo area while this function is waiting for an event. | |
| 2104 | |
| 2105 The next available event will be | |
| 2106 | |
| 2107 -- any events in `unread-command-events' or `unread-command-event'; else | |
| 2108 -- the next event in the currently executing keyboard macro, if any; else | |
| 442 | 2109 -- an event queued by `enqueue-eval-event', if any, or any similar event |
| 2110 queued internally, such as a misc-user event. (For example, when an item | |
| 2111 is selected from a menu or from a `question'-type dialog box, the item's | |
| 2112 callback is not immediately executed, but instead a misc-user event | |
| 2113 is generated and placed onto this queue; when it is dispatched, the | |
| 2114 callback is executed.) Else | |
| 428 | 2115 -- the next available event from the window system or terminal driver. |
| 2116 | |
| 2117 In the last case, this function will block until an event is available. | |
| 2118 | |
| 2119 The returned event will be one of the following types: | |
| 2120 | |
| 2121 -- a key-press event. | |
| 2122 -- a button-press or button-release event. | |
| 2123 -- a misc-user-event, meaning the user selected an item on a menu or used | |
| 2124 the scrollbar. | |
| 2125 -- a process event, meaning that output from a subprocess is available. | |
| 2126 -- a timeout event, meaning that a timeout has elapsed. | |
| 2127 -- an eval event, which simply causes a function to be executed when the | |
| 2128 event is dispatched. Eval events are generated by `enqueue-eval-event' | |
| 2129 or by certain other conditions happening. | |
| 2130 -- a magic event, indicating that some window-system-specific event | |
| 2131 happened (such as a focus-change notification) that must be handled | |
| 2132 synchronously with other events. `dispatch-event' knows what to do with | |
| 2133 these events. | |
| 2134 */ | |
| 2135 (event, prompt)) | |
| 2136 { | |
| 2137 /* This function can call lisp */ | |
| 2138 /* #### We start out using the selected console before an event | |
| 2139 is received, for echoing the partially completed command. | |
| 2140 This is most definitely wrong -- there needs to be a separate | |
| 2141 echo area for each console! */ | |
| 2142 struct console *con = XCONSOLE (Vselected_console); | |
| 2143 struct command_builder *command_builder = | |
| 2144 XCOMMAND_BUILDER (con->command_builder); | |
| 2145 int store_this_key = 0; | |
| 2146 struct gcpro gcpro1; | |
| 853 | 2147 int depth; |
| 1292 | 2148 PROFILE_DECLARE (); |
| 428 | 2149 |
| 2150 GCPRO1 (event); | |
| 853 | 2151 |
| 1268 | 2152 /* This is not strictly necessary. Trying to retrieve an event inside of |
| 2153 a modal loop can cause major problems (see event_stream_quit_p()), but | |
| 2154 the event-specific code knows about this and will make sure we don't | |
| 2155 do anything dangerous. However, if we've gotten here, it's highly | |
| 2156 likely that some code is trying to fetch user events (e.g. in custom | |
| 2157 dialog-box code), and will almost certainly deadlock, so it's probably | |
| 2158 best to error out. #### This could cause problems because there are | |
| 2159 (potentially, at least) legitimate reasons for calling next-event | |
| 2160 inside of a modal loop, in particular if the code is trying to search | |
| 2161 for a timeout event, which will still get retrieved in such a case. | |
| 2162 However, the code to error in such a case has already been present for | |
| 2163 a long time without obvious problems so leaving it in isn't so | |
| 1279 | 2164 bad. |
| 2165 | |
| 2166 #### I used to conditionalize on in_modal_loop but that fails utterly | |
| 2167 because event-msw.c specifically calls Fnext_event() inside of a modal | |
| 2168 loop to clear the dispatch queue. --ben */ | |
| 1315 | 2169 #ifdef HAVE_MENUBARS |
| 1279 | 2170 if (in_menu_callback) |
| 2171 invalid_operation ("Attempt to call next-event inside menu callback", | |
| 1268 | 2172 Qunbound); |
| 1315 | 2173 #endif /* HAVE_MENUBARS */ |
| 1268 | 2174 |
| 1292 | 2175 PROFILE_RECORD_ENTERING_SECTION (Qnext_event); |
| 2176 | |
| 853 | 2177 depth = begin_dont_check_for_quit (); |
| 428 | 2178 |
| 2179 if (NILP (event)) | |
| 2180 event = Fmake_event (Qnil, Qnil); | |
| 2181 else | |
| 2182 CHECK_LIVE_EVENT (event); | |
| 2183 | |
| 2184 if (!NILP (prompt)) | |
| 2185 { | |
| 2186 Bytecount len; | |
| 2187 CHECK_STRING (prompt); | |
| 2188 | |
| 2189 len = XSTRING_LENGTH (prompt); | |
| 2190 if (command_builder->echo_buf_length < len) | |
| 2191 len = command_builder->echo_buf_length - 1; | |
| 2192 memcpy (command_builder->echo_buf, XSTRING_DATA (prompt), len); | |
| 2193 command_builder->echo_buf[len] = 0; | |
| 2194 command_builder->echo_buf_index = len; | |
| 2195 echo_area_message (XFRAME (CONSOLE_SELECTED_FRAME (con)), | |
| 2196 command_builder->echo_buf, | |
| 2197 Qnil, 0, | |
| 2198 command_builder->echo_buf_index, | |
| 2199 Qcommand); | |
| 2200 } | |
| 2201 | |
| 2202 start_over_and_avoid_hosage: | |
| 2203 | |
| 2204 /* If there is something in unread-command-events, simply return it. | |
| 2205 But do some error checking to make sure the user hasn't put something | |
| 2206 in the unread-command-events that they shouldn't have. | |
| 2207 This does not update this-command-keys and recent-keys. | |
| 2208 */ | |
| 2209 if (!NILP (Vunread_command_events)) | |
| 2210 { | |
| 2211 if (!CONSP (Vunread_command_events)) | |
| 2212 { | |
| 2213 Vunread_command_events = Qnil; | |
| 563 | 2214 signal_error_1 (Qwrong_type_argument, |
| 428 | 2215 list3 (Qconsp, Vunread_command_events, |
| 2216 Qunread_command_events)); | |
| 2217 } | |
| 2218 else | |
| 2219 { | |
| 2220 Lisp_Object e = XCAR (Vunread_command_events); | |
| 2221 Vunread_command_events = XCDR (Vunread_command_events); | |
| 2222 if (!EVENTP (e) || !command_event_p (e)) | |
| 563 | 2223 signal_error_1 (Qwrong_type_argument, |
| 428 | 2224 list3 (Qcommand_event_p, e, Qunread_command_events)); |
| 853 | 2225 redisplay_no_pre_idle_hook (); |
| 428 | 2226 if (!EQ (e, event)) |
| 2227 Fcopy_event (e, event); | |
| 2228 DEBUG_PRINT_EMACS_EVENT ("unread-command-events", event); | |
| 2229 } | |
| 2230 } | |
| 2231 | |
| 2232 /* Do similar for unread-command-event (obsoleteness support). */ | |
| 2233 else if (!NILP (Vunread_command_event)) | |
| 2234 { | |
| 2235 Lisp_Object e = Vunread_command_event; | |
| 2236 Vunread_command_event = Qnil; | |
| 2237 | |
| 2238 if (!EVENTP (e) || !command_event_p (e)) | |
| 2239 { | |
| 563 | 2240 signal_error_1 (Qwrong_type_argument, |
| 428 | 2241 list3 (Qeventp, e, Qunread_command_event)); |
| 2242 } | |
| 2243 if (!EQ (e, event)) | |
| 2244 Fcopy_event (e, event); | |
| 853 | 2245 redisplay_no_pre_idle_hook (); |
| 428 | 2246 DEBUG_PRINT_EMACS_EVENT ("unread-command-event", event); |
| 2247 } | |
| 2248 | |
| 2249 /* If we're executing a keyboard macro, take the next event from that, | |
| 2250 and update this-command-keys and recent-keys. | |
| 2251 Note that the unread-command-events take precedence over kbd macros. | |
| 2252 */ | |
| 2253 else | |
| 2254 { | |
| 2255 if (!NILP (Vexecuting_macro)) | |
| 2256 { | |
| 853 | 2257 redisplay_no_pre_idle_hook (); |
| 428 | 2258 pop_kbd_macro_event (event); /* This throws past us at |
| 2259 end-of-macro. */ | |
| 2260 store_this_key = 1; | |
| 2261 DEBUG_PRINT_EMACS_EVENT ("keyboard macro", event); | |
| 2262 } | |
| 2263 /* Otherwise, read a real event, possibly from the | |
| 2264 command_event_queue, and update this-command-keys and | |
| 2265 recent-keys. */ | |
| 2266 else | |
| 2267 { | |
| 2268 redisplay (); | |
| 2269 next_event_internal (event, 1); | |
| 2270 store_this_key = 1; | |
| 2271 } | |
| 2272 } | |
| 2273 | |
| 853 | 2274 /* temporarily reenable quit checking here, because arbitrary lisp |
| 2275 is executed */ | |
| 2276 Vquit_flag = Qnil; /* see begin_dont_check_for_quit() */ | |
| 2277 unbind_to (depth); | |
| 428 | 2278 status_notify (); /* Notice process change */ |
| 853 | 2279 depth = begin_dont_check_for_quit (); |
| 428 | 2280 |
| 2281 /* Since we can free the most stuff here | |
| 2282 * (since this is typically called from | |
| 2283 * the command-loop top-level). */ | |
| 851 | 2284 if (need_to_check_c_alloca) |
| 2285 xemacs_c_alloca (0); /* Cause a garbage collection now */ | |
| 428 | 2286 |
| 2287 if (object_dead_p (XEVENT (event)->channel)) | |
| 2288 /* event_console_or_selected may crash if the channel is dead. | |
| 2289 Best just to eat it and get the next event. */ | |
| 2290 goto start_over_and_avoid_hosage; | |
| 2291 | |
| 2292 /* OK, now we can stop the selected-console kludge and use the | |
| 2293 actual console from the event. */ | |
| 2294 con = event_console_or_selected (event); | |
| 2295 command_builder = XCOMMAND_BUILDER (con->command_builder); | |
| 2296 | |
| 2297 switch (XEVENT_TYPE (event)) | |
| 2298 { | |
| 2299 case button_release_event: | |
| 2300 case misc_user_event: | |
| 2301 /* don't echo menu accelerator keys */ | |
| 2302 reset_key_echo (command_builder, 1); | |
| 2303 goto EXECUTE_KEY; | |
| 2304 case button_press_event: /* key or mouse input can trigger prompting */ | |
| 2305 goto STORE_AND_EXECUTE_KEY; | |
| 2306 case key_press_event: /* any key input can trigger autosave */ | |
| 2307 break; | |
| 898 | 2308 default: |
| 2309 goto RETURN; | |
| 428 | 2310 } |
| 2311 | |
| 853 | 2312 /* temporarily reenable quit checking here, because we could get stuck */ |
| 2313 Vquit_flag = Qnil; /* see begin_dont_check_for_quit() */ | |
| 2314 unbind_to (depth); | |
| 428 | 2315 maybe_do_auto_save (); |
| 853 | 2316 depth = begin_dont_check_for_quit (); |
| 2317 | |
| 428 | 2318 num_input_chars++; |
| 2319 STORE_AND_EXECUTE_KEY: | |
| 2320 if (store_this_key) | |
| 2321 { | |
| 2322 echo_key_event (command_builder, event); | |
| 2323 } | |
| 2324 | |
| 2325 EXECUTE_KEY: | |
| 2326 /* Store the last-input-event. The semantics of this is that it is | |
| 2327 the thing most recently returned by next-command-event. It need | |
| 2328 not have come from the keyboard or a keyboard macro, it may have | |
| 2329 come from unread-command-events. It's always a command-event (a | |
| 2330 key, click, or menu selection), never a motion or process event. | |
| 2331 */ | |
| 2332 if (!EVENTP (Vlast_input_event)) | |
| 2333 Vlast_input_event = Fmake_event (Qnil, Qnil); | |
| 2334 if (XEVENT_TYPE (Vlast_input_event) == dead_event) | |
| 2335 { | |
| 2336 Vlast_input_event = Fmake_event (Qnil, Qnil); | |
| 563 | 2337 invalid_state ("Someone deallocated last-input-event!", Qunbound); |
| 428 | 2338 } |
| 2339 if (! EQ (event, Vlast_input_event)) | |
| 2340 Fcopy_event (event, Vlast_input_event); | |
| 2341 | |
| 2342 /* last-input-char and last-input-time are derived from | |
| 2343 last-input-event. | |
| 2344 Note that last-input-char will never have its high-bit set, in an | |
| 2345 effort to sidestep the ambiguity between M-x and oslash. | |
| 2346 */ | |
| 2862 | 2347 Vlast_input_char = Fevent_to_character (Vlast_input_event, Qnil, Qnil, Qnil); |
| 428 | 2348 { |
| 2349 EMACS_TIME t; | |
| 2350 EMACS_GET_TIME (t); | |
| 2351 if (!CONSP (Vlast_input_time)) | |
| 2352 Vlast_input_time = Fcons (Qnil, Qnil); | |
| 2353 XCAR (Vlast_input_time) = make_int ((EMACS_SECS (t) >> 16) & 0xffff); | |
| 2354 XCDR (Vlast_input_time) = make_int ((EMACS_SECS (t) >> 0) & 0xffff); | |
| 2355 if (!CONSP (Vlast_command_event_time)) | |
| 2356 Vlast_command_event_time = list3 (Qnil, Qnil, Qnil); | |
| 2357 XCAR (Vlast_command_event_time) = | |
| 2358 make_int ((EMACS_SECS (t) >> 16) & 0xffff); | |
| 2359 XCAR (XCDR (Vlast_command_event_time)) = | |
| 2360 make_int ((EMACS_SECS (t) >> 0) & 0xffff); | |
| 2361 XCAR (XCDR (XCDR (Vlast_command_event_time))) | |
| 2362 = make_int (EMACS_USECS (t)); | |
| 2363 } | |
| 2364 /* If this key came from the keyboard or from a keyboard macro, then | |
| 2365 it goes into the recent-keys and this-command-keys vectors. | |
| 2366 If this key came from the keyboard, and we're defining a keyboard | |
| 2367 macro, then it goes into the macro. | |
| 2368 */ | |
| 2369 if (store_this_key) | |
| 2370 { | |
| 479 | 2371 if (!is_scrollbar_event (event)) /* #### not quite right, see |
| 2372 comment in execute_command_event */ | |
| 2373 push_this_command_keys (event); | |
| 428 | 2374 if (!inhibit_input_event_recording) |
| 2375 push_recent_keys (event); | |
| 2376 dribble_out_event (event); | |
| 2377 if (!NILP (con->defining_kbd_macro) && NILP (Vexecuting_macro)) | |
| 2378 { | |
| 2379 if (!EVENTP (command_builder->current_events)) | |
| 2380 finalize_kbd_macro_chars (con); | |
| 2381 store_kbd_macro_event (event); | |
| 2382 } | |
| 2383 } | |
| 853 | 2384 /* If this is the help char and there is a help form, then execute |
| 2385 the help form and swallow this character. Note that | |
| 2386 execute_help_form() calls Fnext_command_event(), which calls this | |
| 2387 function, as well as Fdispatch_event. */ | |
| 428 | 2388 if (!NILP (Vhelp_form) && |
| 1204 | 2389 event_matches_key_specifier_p (event, Vhelp_char)) |
| 853 | 2390 { |
| 2391 /* temporarily reenable quit checking here, because we could get stuck */ | |
| 2392 Vquit_flag = Qnil; /* see begin_dont_check_for_quit() */ | |
| 2393 unbind_to (depth); | |
| 2394 execute_help_form (command_builder, event); | |
| 2395 depth = begin_dont_check_for_quit (); | |
| 2396 } | |
| 428 | 2397 |
| 2398 RETURN: | |
| 853 | 2399 Vquit_flag = Qnil; /* see begin_dont_check_for_quit() */ |
| 2400 unbind_to (depth); | |
| 2401 | |
| 1292 | 2402 PROFILE_RECORD_EXITING_SECTION (Qnext_event); |
| 2403 | |
| 428 | 2404 UNGCPRO; |
| 853 | 2405 |
| 428 | 2406 return event; |
| 2407 } | |
| 2408 | |
| 2409 DEFUN ("next-command-event", Fnext_command_event, 0, 2, 0, /* | |
| 2410 Return the next available "user" event. | |
| 2411 Pass this object to `dispatch-event' to handle it. | |
| 2412 | |
| 2413 If EVENT is non-nil, it should be an event object and will be filled in | |
| 2414 and returned; otherwise a new event object will be created and returned. | |
| 2415 If PROMPT is non-nil, it should be a string and will be displayed in the | |
| 2416 echo area while this function is waiting for an event. | |
| 2417 | |
| 2418 The event returned will be a keyboard, mouse press, or mouse release event. | |
| 2419 If there are non-command events available (mouse motion, sub-process output, | |
| 2420 etc) then these will be executed (with `dispatch-event') and discarded. This | |
| 2421 function is provided as a convenience; it is roughly equivalent to the lisp code | |
| 2422 | |
| 2423 (while (progn | |
| 2424 (next-event event prompt) | |
| 2425 (not (or (key-press-event-p event) | |
| 2426 (button-press-event-p event) | |
| 2427 (button-release-event-p event) | |
| 2428 (misc-user-event-p event)))) | |
| 2429 (dispatch-event event)) | |
| 2430 | |
| 2431 but it also makes a provision for displaying keystrokes in the echo area. | |
| 2432 */ | |
| 2433 (event, prompt)) | |
| 2434 { | |
| 2435 /* This function can GC */ | |
| 2436 struct gcpro gcpro1; | |
| 2437 GCPRO1 (event); | |
| 934 | 2438 |
| 428 | 2439 maybe_echo_keys (XCOMMAND_BUILDER |
| 2440 (XCONSOLE (Vselected_console)-> | |
| 2441 command_builder), 0); /* #### This sucks bigtime */ | |
| 853 | 2442 |
| 428 | 2443 for (;;) |
| 2444 { | |
| 2445 event = Fnext_event (event, prompt); | |
| 2446 if (command_event_p (event)) | |
| 2447 break; | |
| 2448 else | |
| 2449 execute_internal_event (event); | |
| 2450 } | |
| 2451 UNGCPRO; | |
| 2452 return event; | |
| 2453 } | |
| 2454 | |
| 442 | 2455 DEFUN ("dispatch-non-command-events", Fdispatch_non_command_events, 0, 0, 0, /* |
| 2456 Dispatch any pending "magic" events. | |
| 2457 | |
| 2458 This function is useful for forcing the redisplay of native | |
| 2459 widgets. Normally these are redisplayed through a native window-system | |
| 2460 event encoded as magic event, rather than by the redisplay code. This | |
| 2461 function does not call redisplay or do any of the other things that | |
| 2462 `next-event' does. | |
| 2463 */ | |
| 2464 ()) | |
| 2465 { | |
| 2466 /* This function can GC */ | |
| 2467 Lisp_Object event = Qnil; | |
| 2468 struct gcpro gcpro1; | |
| 2469 GCPRO1 (event); | |
| 2470 event = Fmake_event (Qnil, Qnil); | |
| 2471 | |
| 2472 /* Make sure that there will be something in the native event queue | |
| 2473 so that externally managed things (e.g. widgets) get some CPU | |
| 2474 time. */ | |
| 2475 event_stream_force_event_pending (selected_frame ()); | |
| 2476 | |
| 2477 while (event_stream_event_pending_p (0)) | |
| 2478 { | |
| 2479 /* We're a generator of the command_event_queue, so we can't be a | |
| 2480 consumer as well. Also, we have no reason to consult the | |
| 2481 command_event_queue; there are only user and eval-events there, | |
| 2482 and we'd just have to put them back anyway. | |
| 2483 */ | |
| 2484 next_event_internal (event, 0); /* blocks */ | |
| 2485 if (XEVENT_TYPE (event) == magic_event || | |
| 2486 XEVENT_TYPE (event) == timeout_event || | |
| 2487 XEVENT_TYPE (event) == process_event || | |
| 2488 XEVENT_TYPE (event) == pointer_motion_event) | |
| 2489 execute_internal_event (event); | |
| 2490 else | |
| 2491 { | |
| 2492 enqueue_command_event_1 (event); | |
| 2493 break; | |
| 2494 } | |
| 2495 } | |
| 2496 | |
| 2497 Fdeallocate_event (event); | |
| 2498 UNGCPRO; | |
| 2499 return Qnil; | |
| 2500 } | |
| 2501 | |
| 428 | 2502 static void |
| 2503 reset_current_events (struct command_builder *command_builder) | |
| 2504 { | |
| 2505 Lisp_Object event = command_builder->current_events; | |
| 2506 reset_command_builder_event_chain (command_builder); | |
| 2507 if (EVENTP (event)) | |
| 2508 deallocate_event_chain (event); | |
| 2509 } | |
| 2510 | |
| 1268 | 2511 static int |
| 2286 | 2512 command_event_p_cb (Lisp_Object ev, void *UNUSED (the_data)) |
| 1268 | 2513 { |
| 2514 return command_event_p (ev); | |
| 2515 } | |
| 2516 | |
| 428 | 2517 DEFUN ("discard-input", Fdiscard_input, 0, 0, 0, /* |
| 2518 Discard any pending "user" events. | |
| 2519 Also cancel any kbd macro being defined. | |
| 2520 A user event is a key press, button press, button release, or | |
| 2521 "misc-user" event (menu selection or scrollbar action). | |
| 2522 */ | |
| 2523 ()) | |
| 2524 { | |
| 1318 | 2525 /* This can call Lisp */ |
| 1268 | 2526 Lisp_Object concons; |
| 2527 | |
| 2528 CONSOLE_LOOP (concons) | |
| 428 | 2529 { |
| 1268 | 2530 struct console *con = XCONSOLE (XCAR (concons)); |
| 2531 | |
| 2532 /* If a macro was being defined then we have to mark the modeline | |
| 2533 has changed to ensure that it gets updated correctly. */ | |
| 2534 if (!NILP (con->defining_kbd_macro)) | |
| 2535 MARK_MODELINE_CHANGED; | |
| 2536 con->defining_kbd_macro = Qnil; | |
| 2537 reset_current_events (XCOMMAND_BUILDER (con->command_builder)); | |
| 428 | 2538 } |
| 2539 | |
| 1268 | 2540 /* This function used to be a lot more complicated. Now, we just |
| 2541 drain the pending queue and discard all user events from the | |
| 2542 command and dispatch queues. */ | |
| 2543 event_stream_drain_queue (); | |
| 2544 | |
| 2545 map_event_chain_remove (command_event_p_cb, | |
| 2546 &dispatch_event_queue, &dispatch_event_queue_tail, | |
| 2547 0, MECR_DEALLOCATE_EVENT); | |
| 2548 map_event_chain_remove (command_event_p_cb, | |
| 2549 &command_event_queue, &command_event_queue_tail, | |
| 2550 0, MECR_DEALLOCATE_EVENT); | |
| 428 | 2551 |
| 2552 return Qnil; | |
| 2553 } | |
| 2554 | |
| 2555 | |
| 2556 /**********************************************************************/ | |
| 2557 /* pausing until an action occurs */ | |
| 2558 /**********************************************************************/ | |
| 2559 | |
| 2560 /* This is used in accept-process-output, sleep-for and sit-for. | |
| 2561 Before running any process_events in these routines, we set | |
| 1268 | 2562 recursive_sit_for to 1, and use this unwind protect to reset it to |
| 2563 Qnil upon exit. When recursive_sit_for is 1, calling sit-for will | |
| 428 | 2564 cause it to return immediately. |
| 2565 | |
| 2566 All of these routines install timeouts, so we clear the installed | |
| 2567 timeout as well. | |
| 2568 | |
| 2569 Note: It's very easy to break the desired behaviors of these | |
| 2570 3 routines. If you make any changes to anything in this area, run | |
| 2571 the regression tests at the bottom of the file. -- dmoore */ | |
| 2572 | |
| 2573 | |
| 2574 static Lisp_Object | |
| 2575 sit_for_unwind (Lisp_Object timeout_id) | |
| 2576 { | |
| 2577 if (!NILP(timeout_id)) | |
| 2578 Fdisable_timeout (timeout_id); | |
| 2579 | |
| 1268 | 2580 recursive_sit_for = 0; |
| 428 | 2581 return Qnil; |
| 2582 } | |
| 2583 | |
| 2584 /* #### Is (accept-process-output nil 3) supposed to be like (sleep-for 3)? | |
| 2585 */ | |
| 2586 | |
| 2587 DEFUN ("accept-process-output", Faccept_process_output, 0, 3, 0, /* | |
| 2588 Allow any pending output from subprocesses to be read by Emacs. | |
| 2589 It is read into the process' buffers or given to their filter functions. | |
| 2590 Non-nil arg PROCESS means do not return until some output has been received | |
| 2591 from PROCESS. Nil arg PROCESS means do not return until some output has | |
| 2592 been received from any process. | |
| 2593 If the second arg is non-nil, it is the maximum number of seconds to wait: | |
| 2594 this function will return after that much time even if no input has arrived | |
| 2595 from PROCESS. This argument may be a float, meaning wait some fractional | |
| 2596 part of a second. | |
| 2597 If the third arg is non-nil, it is a number of milliseconds that is added | |
| 2598 to the second arg. (This exists only for compatibility.) | |
| 2599 Return non-nil iff we received any output before the timeout expired. | |
| 2600 */ | |
| 2601 (process, timeout_secs, timeout_msecs)) | |
| 2602 { | |
| 2603 /* This function can GC */ | |
| 2604 struct gcpro gcpro1, gcpro2; | |
| 2605 Lisp_Object event = Qnil; | |
| 2606 Lisp_Object result = Qnil; | |
| 2607 int timeout_id = -1; | |
| 2608 int timeout_enabled = 0; | |
| 2609 int done = 0; | |
| 2610 struct buffer *old_buffer = current_buffer; | |
| 2611 int count; | |
| 2612 | |
| 2613 /* We preserve the current buffer but nothing else. If a focus | |
| 2614 change alters the selected window then the top level event loop | |
| 2615 will eventually alter current_buffer to match. In the mean time | |
| 2616 we don't want to mess up whatever called this function. */ | |
| 2617 | |
| 2618 if (!NILP (process)) | |
| 2619 CHECK_PROCESS (process); | |
| 2620 | |
| 2621 GCPRO2 (event, process); | |
| 2622 | |
| 2623 if (!NILP (timeout_secs) || !NILP (timeout_msecs)) | |
| 2624 { | |
| 2625 unsigned long msecs = 0; | |
| 2626 if (!NILP (timeout_secs)) | |
| 2627 msecs = lisp_number_to_milliseconds (timeout_secs, 1); | |
| 2628 if (!NILP (timeout_msecs)) | |
| 2629 { | |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2630 check_integer_range (timeout_msecs, Qzero, |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
2631 make_integer (EMACS_INT_MAX)); |
| 428 | 2632 msecs += XINT (timeout_msecs); |
| 2633 } | |
| 2634 if (msecs) | |
| 2635 { | |
| 2636 timeout_id = event_stream_generate_wakeup (msecs, 0, Qnil, Qnil, 0); | |
| 2637 timeout_enabled = 1; | |
| 2638 } | |
| 2639 } | |
| 2640 | |
| 2641 event = Fmake_event (Qnil, Qnil); | |
| 2642 | |
| 2643 count = specpdl_depth (); | |
| 2644 record_unwind_protect (sit_for_unwind, | |
| 2645 timeout_enabled ? make_int (timeout_id) : Qnil); | |
| 1268 | 2646 recursive_sit_for = 1; |
| 428 | 2647 |
| 2648 while (!done && | |
| 2649 ((NILP (process) && timeout_enabled) || | |
| 2650 (NILP (process) && event_stream_event_pending_p (0)) || | |
| 2651 (!NILP (process)))) | |
| 2652 /* Calling detect_input_pending() is the wrong thing here, because | |
| 2653 that considers the Vunread_command_events and command_event_queue. | |
| 2654 We don't need to look at the command_event_queue because we are | |
| 2655 only interested in process events, which don't go on that. In | |
| 2656 fact, we can't read from it anyway, because we put stuff on it. | |
| 2657 | |
| 2658 Note that event_stream->event_pending_p must be called in such | |
| 2659 a way that it says whether any events *of any kind* are ready, | |
| 2660 not just user events, or (accept-process-output nil) will fail | |
| 2661 to dispatch any process events that may be on the queue. It is | |
| 2662 not clear to me that this is important, because the top-level | |
| 2663 loop will process it, and I don't think that there is ever a | |
| 2664 time when one calls accept-process-output with a nil argument | |
| 2665 and really need the processes to be handled. */ | |
| 2666 { | |
| 2667 /* If our timeout has arrived, we move along. */ | |
| 2668 if (timeout_enabled && !event_stream_wakeup_pending_p (timeout_id, 0)) | |
| 2669 { | |
| 2670 timeout_enabled = 0; | |
| 2671 done = 1; /* We're done. */ | |
| 2672 continue; /* Don't call next_event_internal */ | |
| 2673 } | |
| 2674 | |
| 2675 next_event_internal (event, 0); | |
| 2676 switch (XEVENT_TYPE (event)) | |
| 2677 { | |
| 2678 case process_event: | |
| 2679 { | |
| 2680 if (NILP (process) || | |
| 1204 | 2681 EQ (XEVENT_PROCESS_PROCESS (event), process)) |
| 428 | 2682 { |
| 2683 done = 1; | |
| 2684 /* RMS's version always returns nil when proc is nil, | |
| 2685 and only returns t if input ever arrived on proc. */ | |
| 2686 result = Qt; | |
| 2687 } | |
| 2688 | |
| 2689 execute_internal_event (event); | |
| 2690 break; | |
| 2691 } | |
| 2692 case timeout_event: | |
| 2693 /* We execute the event even if it's ours, and notice that it's | |
| 2694 happened above. */ | |
| 2695 case pointer_motion_event: | |
| 2696 case magic_event: | |
| 2697 { | |
| 2698 execute_internal_event (event); | |
| 2699 break; | |
| 2700 } | |
| 2701 default: | |
| 2702 { | |
| 2703 enqueue_command_event_1 (event); | |
| 2704 break; | |
| 2705 } | |
| 2706 } | |
| 2707 } | |
| 2708 | |
| 771 | 2709 unbind_to_1 (count, timeout_enabled ? make_int (timeout_id) : Qnil); |
| 428 | 2710 |
| 2711 Fdeallocate_event (event); | |
| 853 | 2712 |
| 2713 status_notify (); | |
| 2714 | |
| 428 | 2715 UNGCPRO; |
| 2716 current_buffer = old_buffer; | |
| 2717 return result; | |
| 2718 } | |
| 2719 | |
| 2720 DEFUN ("sleep-for", Fsleep_for, 1, 1, 0, /* | |
| 444 | 2721 Pause, without updating display, for SECONDS seconds. |
| 2722 SECONDS may be a float, allowing pauses for fractional parts of a second. | |
| 428 | 2723 |
| 2724 It is recommended that you never call sleep-for from inside of a process | |
| 444 | 2725 filter function or timer event (either synchronous or asynchronous). |
| 428 | 2726 */ |
| 2727 (seconds)) | |
| 2728 { | |
| 2729 /* This function can GC */ | |
| 2730 unsigned long msecs = lisp_number_to_milliseconds (seconds, 1); | |
| 2731 int id; | |
| 2732 Lisp_Object event = Qnil; | |
| 2733 int count; | |
| 2734 struct gcpro gcpro1; | |
| 2735 | |
| 2736 GCPRO1 (event); | |
| 2737 | |
| 2738 id = event_stream_generate_wakeup (msecs, 0, Qnil, Qnil, 0); | |
| 2739 event = Fmake_event (Qnil, Qnil); | |
| 2740 | |
| 2741 count = specpdl_depth (); | |
| 2742 record_unwind_protect (sit_for_unwind, make_int (id)); | |
| 1268 | 2743 recursive_sit_for = 1; |
| 428 | 2744 |
| 2745 while (1) | |
| 2746 { | |
| 2747 /* If our timeout has arrived, we move along. */ | |
| 2748 if (!event_stream_wakeup_pending_p (id, 0)) | |
| 2749 goto DONE_LABEL; | |
| 2750 | |
| 2751 /* We're a generator of the command_event_queue, so we can't be a | |
| 2752 consumer as well. We don't care about command and eval-events | |
| 2753 anyway. | |
| 2754 */ | |
| 2755 next_event_internal (event, 0); /* blocks */ | |
| 2756 switch (XEVENT_TYPE (event)) | |
| 2757 { | |
| 2758 case timeout_event: | |
| 2759 /* We execute the event even if it's ours, and notice that it's | |
| 2760 happened above. */ | |
| 2761 case process_event: | |
| 2762 case pointer_motion_event: | |
| 2763 case magic_event: | |
| 2764 { | |
| 2765 execute_internal_event (event); | |
| 2766 break; | |
| 2767 } | |
| 2768 default: | |
| 2769 { | |
| 2770 enqueue_command_event_1 (event); | |
| 2771 break; | |
| 2772 } | |
| 2773 } | |
| 2774 } | |
| 2775 DONE_LABEL: | |
| 771 | 2776 unbind_to_1 (count, make_int (id)); |
| 428 | 2777 Fdeallocate_event (event); |
| 2778 UNGCPRO; | |
| 2779 return Qnil; | |
| 2780 } | |
| 2781 | |
| 2782 DEFUN ("sit-for", Fsit_for, 1, 2, 0, /* | |
| 444 | 2783 Perform redisplay, then wait SECONDS seconds or until user input is available. |
| 2784 SECONDS may be a float, meaning a fractional part of a second. | |
| 2785 Optional second arg NODISPLAY non-nil means don't redisplay; just wait. | |
| 428 | 2786 Redisplay is preempted as always if user input arrives, and does not |
| 2787 happen if input is available before it starts. | |
| 2788 Value is t if waited the full time with no input arriving. | |
| 2789 | |
| 2790 If sit-for is called from within a process filter function or timer | |
| 2791 event (either synchronous or asynchronous) it will return immediately. | |
| 2792 */ | |
| 2793 (seconds, nodisplay)) | |
| 2794 { | |
| 2795 /* This function can GC */ | |
| 2796 unsigned long msecs = lisp_number_to_milliseconds (seconds, 1); | |
| 2797 Lisp_Object event, result; | |
| 2798 struct gcpro gcpro1; | |
| 2799 int id; | |
| 2800 int count; | |
| 2801 | |
| 2802 /* The unread-command-events count as pending input */ | |
| 2803 if (!NILP (Vunread_command_events) || !NILP (Vunread_command_event)) | |
| 2804 return Qnil; | |
| 2805 | |
| 2806 /* If the command-builder already has user-input on it (not eval events) | |
| 2807 then that means we're done too. | |
| 2808 */ | |
| 2809 if (!NILP (command_event_queue)) | |
| 2810 { | |
| 2811 EVENT_CHAIN_LOOP (event, command_event_queue) | |
| 2812 { | |
| 2813 if (command_event_p (event)) | |
| 2814 return Qnil; | |
| 2815 } | |
| 2816 } | |
| 2817 | |
| 2818 /* If we're in a macro, or noninteractive, or early in temacs, then | |
| 2819 don't wait. */ | |
| 2820 if (noninteractive || !NILP (Vexecuting_macro)) | |
| 2821 return Qnil; | |
| 2822 | |
| 2823 /* Recursive call from a filter function or timeout handler. */ | |
| 1268 | 2824 if (recursive_sit_for) |
| 428 | 2825 { |
| 2826 if (!event_stream_event_pending_p (1) && NILP (nodisplay)) | |
| 2827 redisplay (); | |
| 2828 return Qnil; | |
| 2829 } | |
| 2830 | |
| 2831 | |
| 2832 /* Otherwise, start reading events from the event_stream. | |
| 2833 Do this loop at least once even if (sit-for 0) so that we | |
| 2834 redisplay when no input pending. | |
| 2835 */ | |
| 2836 GCPRO1 (event); | |
| 2837 event = Fmake_event (Qnil, Qnil); | |
| 2838 | |
| 2839 /* Generate the wakeup even if MSECS is 0, so that existing timeout/etc. | |
| 2840 events get processed. The old (pre-19.12) code special-cased this | |
| 2841 and didn't generate a wakeup, but the resulting behavior was less than | |
| 2842 ideal; viz. the occurrence of (sit-for 0.001) scattered throughout | |
| 2843 the E-Lisp universe. */ | |
| 2844 | |
| 2845 id = event_stream_generate_wakeup (msecs, 0, Qnil, Qnil, 0); | |
| 2846 | |
| 2847 count = specpdl_depth (); | |
| 2848 record_unwind_protect (sit_for_unwind, make_int (id)); | |
| 1268 | 2849 recursive_sit_for = 1; |
| 428 | 2850 |
| 2851 while (1) | |
| 2852 { | |
| 2853 /* If there is no user input pending, then redisplay. | |
| 2854 */ | |
| 2855 if (!event_stream_event_pending_p (1) && NILP (nodisplay)) | |
| 2856 redisplay (); | |
| 2857 | |
| 2858 /* If our timeout has arrived, we move along. */ | |
| 2859 if (!event_stream_wakeup_pending_p (id, 0)) | |
| 2860 { | |
| 2861 result = Qt; | |
| 2862 goto DONE_LABEL; | |
| 2863 } | |
| 2864 | |
| 2865 /* We're a generator of the command_event_queue, so we can't be a | |
| 2866 consumer as well. In fact, we know there's nothing on the | |
| 2867 command_event_queue that we didn't just put there. | |
| 2868 */ | |
| 2869 next_event_internal (event, 0); /* blocks */ | |
| 2870 | |
| 2871 if (command_event_p (event)) | |
| 2872 { | |
| 2873 result = Qnil; | |
| 2874 goto DONE_LABEL; | |
| 2875 } | |
| 2876 switch (XEVENT_TYPE (event)) | |
| 2877 { | |
| 2878 case eval_event: | |
| 2879 { | |
| 2880 /* eval-events get delayed until later. */ | |
| 2881 enqueue_command_event (Fcopy_event (event, Qnil)); | |
| 2882 break; | |
| 2883 } | |
| 2884 | |
| 2885 case timeout_event: | |
| 2886 /* We execute the event even if it's ours, and notice that it's | |
| 2887 happened above. */ | |
| 2888 default: | |
| 2889 { | |
| 2890 execute_internal_event (event); | |
| 2891 break; | |
| 2892 } | |
| 2893 } | |
| 2894 } | |
| 2895 | |
| 2896 DONE_LABEL: | |
| 771 | 2897 unbind_to_1 (count, make_int (id)); |
| 428 | 2898 |
| 2899 /* Put back the event (if any) that made Fsit_for() exit before the | |
| 2900 timeout. Note that it is being added to the back of the queue, which | |
| 2901 would be inappropriate if there were any user events on the queue | |
| 2902 already: we would be misordering them. But we know that there are | |
| 2903 no user-events on the queue, or else we would not have reached this | |
| 2904 point at all. | |
| 2905 */ | |
| 2906 if (NILP (result)) | |
| 2907 enqueue_command_event (event); | |
| 2908 else | |
| 2909 Fdeallocate_event (event); | |
| 2910 | |
| 2911 UNGCPRO; | |
| 2912 return result; | |
| 2913 } | |
| 2914 | |
| 442 | 2915 /* This handy little function is used by select-x.c to wait for replies |
| 2916 from processes that aren't really processes (e.g. the X server) */ | |
| 428 | 2917 void |
| 2918 wait_delaying_user_input (int (*predicate) (void *arg), void *predicate_arg) | |
| 2919 { | |
| 2920 /* This function can GC */ | |
| 2921 Lisp_Object event = Fmake_event (Qnil, Qnil); | |
| 2922 struct gcpro gcpro1; | |
| 2923 GCPRO1 (event); | |
| 2924 | |
| 2925 while (!(*predicate) (predicate_arg)) | |
| 2926 { | |
| 2927 /* We're a generator of the command_event_queue, so we can't be a | |
| 2928 consumer as well. Also, we have no reason to consult the | |
| 2929 command_event_queue; there are only user and eval-events there, | |
| 2930 and we'd just have to put them back anyway. | |
| 2931 */ | |
| 2932 next_event_internal (event, 0); | |
| 2933 if (command_event_p (event) | |
| 2934 || (XEVENT_TYPE (event) == eval_event) | |
| 2935 || (XEVENT_TYPE (event) == magic_eval_event)) | |
| 2936 enqueue_command_event_1 (event); | |
| 2937 else | |
| 2938 execute_internal_event (event); | |
| 2939 } | |
| 2940 UNGCPRO; | |
| 2941 } | |
| 2942 | |
| 2943 | |
| 2944 /**********************************************************************/ | |
| 2945 /* dispatching events; command builder */ | |
| 2946 /**********************************************************************/ | |
| 2947 | |
| 2948 static void | |
| 2949 execute_internal_event (Lisp_Object event) | |
| 2950 { | |
| 1292 | 2951 PROFILE_DECLARE (); |
| 2952 | |
| 428 | 2953 /* events on dead channels get silently eaten */ |
| 2954 if (object_dead_p (XEVENT (event)->channel)) | |
| 2955 return; | |
| 2956 | |
| 1292 | 2957 PROFILE_RECORD_ENTERING_SECTION (QSexecute_internal_event); |
| 2958 | |
| 428 | 2959 /* This function can GC */ |
| 2960 switch (XEVENT_TYPE (event)) | |
| 2961 { | |
| 2962 case empty_event: | |
| 1292 | 2963 goto done; |
| 428 | 2964 |
| 2965 case eval_event: | |
| 2966 { | |
| 1204 | 2967 call1 (XEVENT_EVAL_FUNCTION (event), |
| 2968 XEVENT_EVAL_OBJECT (event)); | |
| 1292 | 2969 goto done; |
| 428 | 2970 } |
| 2971 | |
| 2972 case magic_eval_event: | |
| 2973 { | |
| 1204 | 2974 XEVENT_MAGIC_EVAL_INTERNAL_FUNCTION (event) |
| 2975 XEVENT_MAGIC_EVAL_OBJECT (event); | |
| 1292 | 2976 goto done; |
| 428 | 2977 } |
| 2978 | |
| 2979 case pointer_motion_event: | |
| 2980 { | |
| 2981 if (!NILP (Vmouse_motion_handler)) | |
| 2982 call1 (Vmouse_motion_handler, event); | |
| 1292 | 2983 goto done; |
| 428 | 2984 } |
| 2985 | |
| 2986 case process_event: | |
| 2987 { | |
| 1204 | 2988 Lisp_Object p = XEVENT_PROCESS_PROCESS (event); |
| 428 | 2989 Charcount readstatus; |
| 853 | 2990 int iter; |
| 2991 | |
| 2992 assert (PROCESSP (p)); | |
| 2993 for (iter = 0; iter < 2; iter++) | |
| 2994 { | |
| 2995 if (iter == 1 && !process_has_separate_stderr (p)) | |
| 2996 break; | |
| 2997 while ((readstatus = read_process_output (p, iter)) > 0) | |
| 2998 ; | |
| 2999 if (readstatus > 0) | |
| 3000 ; /* this clauses never gets executed but | |
| 3001 allows the #ifdefs to work cleanly. */ | |
| 428 | 3002 #ifdef EWOULDBLOCK |
| 853 | 3003 else if (readstatus == -1 && errno == EWOULDBLOCK) |
| 3004 ; | |
| 428 | 3005 #endif /* EWOULDBLOCK */ |
| 3006 #ifdef EAGAIN | |
| 853 | 3007 else if (readstatus == -1 && errno == EAGAIN) |
| 3008 ; | |
| 428 | 3009 #endif /* EAGAIN */ |
| 853 | 3010 else if ((readstatus == 0 && |
| 3011 /* Note that we cannot distinguish between no input | |
| 3012 available now and a closed pipe. | |
| 3013 With luck, a closed pipe will be accompanied by | |
| 3014 subprocess termination and SIGCHLD. */ | |
| 3015 (!network_connection_p (p) || | |
| 3016 /* | |
| 3017 When connected to ToolTalk (i.e. | |
| 3018 connected_via_filedesc_p()), it's not possible to | |
| 3019 reliably determine whether there is a message | |
| 3020 waiting for ToolTalk to receive. ToolTalk expects | |
| 3021 to have tt_message_receive() called exactly once | |
| 3022 every time the file descriptor becomes active, so | |
| 3023 the filter function forces this by returning 0. | |
| 3024 Emacs must not interpret this as a closed pipe. */ | |
| 3025 connected_via_filedesc_p (XPROCESS (p)))) | |
| 3026 | |
| 3027 /* On some OSs with ptys, when the process on one end of | |
| 3028 a pty exits, the other end gets an error reading with | |
| 3029 errno = EIO instead of getting an EOF (0 bytes read). | |
| 3030 Therefore, if we get an error reading and errno = | |
| 3031 EIO, just continue, because the child process has | |
| 3032 exited and should clean itself up soon (e.g. when we | |
| 3033 get a SIGCHLD). */ | |
| 535 | 3034 #ifdef EIO |
| 853 | 3035 || (readstatus == -1 && errno == EIO) |
| 428 | 3036 #endif |
| 535 | 3037 |
| 853 | 3038 ) |
| 3039 { | |
| 3040 /* Currently, we rely on SIGCHLD to indicate that the | |
| 3041 process has terminated. Unfortunately, on some systems | |
| 3042 the SIGCHLD gets missed some of the time. So we put an | |
| 3043 additional check in status_notify() to see whether a | |
| 3044 process has terminated. We must tell status_notify() | |
| 3045 to enable that check, and we do so now. */ | |
| 3046 kick_status_notify (); | |
| 3047 } | |
| 898 | 3048 else |
| 3049 { | |
| 3050 /* Deactivate network connection */ | |
| 3051 Lisp_Object status = Fprocess_status (p); | |
| 3052 if (EQ (status, Qopen) | |
| 3053 /* In case somebody changes the theory of whether to | |
| 3054 return open as opposed to run for network connection | |
| 3055 "processes"... */ | |
| 3056 || EQ (status, Qrun)) | |
| 3057 update_process_status (p, Qexit, 256, 0); | |
| 3058 deactivate_process (p); | |
| 3059 status_notify (); | |
| 3060 } | |
| 853 | 3061 |
| 3062 /* We must call status_notify here to allow the | |
| 3063 event_stream->unselect_process_cb to be run if appropriate. | |
| 3064 Otherwise, dead fds may be selected for, and we will get a | |
| 3065 continuous stream of process events for them. Since we don't | |
| 3066 return until all process events have been flushed, we would | |
| 3067 get stuck here, processing events on a process whose status | |
| 3025 | 3068 was `exit'. Call this after dispatch-event, or the fds will |
| 853 | 3069 have been closed before we read the last data from them. |
| 3070 It's safe for the filter to signal an error because | |
| 3071 status_notify() will be called on return to top-level. | |
| 3072 */ | |
| 3073 status_notify (); | |
| 428 | 3074 } |
| 1292 | 3075 goto done; |
| 428 | 3076 } |
| 3077 | |
| 3078 case timeout_event: | |
| 3079 { | |
| 440 | 3080 Lisp_Event *e = XEVENT (event); |
| 934 | 3081 |
| 1204 | 3082 if (!NILP (EVENT_TIMEOUT_FUNCTION (e))) |
| 3083 call1 (EVENT_TIMEOUT_FUNCTION (e), | |
| 3084 EVENT_TIMEOUT_OBJECT (e)); | |
| 1292 | 3085 goto done; |
| 428 | 3086 } |
| 3087 case magic_event: | |
| 3088 event_stream_handle_magic_event (XEVENT (event)); | |
| 1292 | 3089 goto done; |
| 428 | 3090 default: |
| 2500 | 3091 ABORT (); |
| 428 | 3092 } |
| 1292 | 3093 |
| 3094 done: | |
| 3095 PROFILE_RECORD_EXITING_SECTION (QSexecute_internal_event); | |
| 428 | 3096 } |
| 3097 | |
| 3098 | |
| 3099 | |
| 3100 static void | |
| 3101 this_command_keys_replace_suffix (Lisp_Object suffix, Lisp_Object chain) | |
| 3102 { | |
| 3103 Lisp_Object first_before_suffix = | |
| 3104 event_chain_find_previous (Vthis_command_keys, suffix); | |
| 3105 | |
| 3106 if (NILP (first_before_suffix)) | |
| 3107 Vthis_command_keys = chain; | |
| 3108 else | |
| 3109 XSET_EVENT_NEXT (first_before_suffix, chain); | |
| 3110 deallocate_event_chain (suffix); | |
| 3111 Vthis_command_keys_tail = event_chain_tail (chain); | |
| 3112 } | |
| 3113 | |
| 3114 static void | |
| 3115 command_builder_replace_suffix (struct command_builder *builder, | |
| 3116 Lisp_Object suffix, Lisp_Object chain) | |
| 3117 { | |
| 3118 Lisp_Object first_before_suffix = | |
| 3119 event_chain_find_previous (builder->current_events, suffix); | |
| 3120 | |
| 3121 if (NILP (first_before_suffix)) | |
| 3122 builder->current_events = chain; | |
| 3123 else | |
| 3124 XSET_EVENT_NEXT (first_before_suffix, chain); | |
| 3125 deallocate_event_chain (suffix); | |
| 3126 builder->most_current_event = event_chain_tail (chain); | |
| 3127 } | |
| 3128 | |
| 3129 static Lisp_Object | |
| 3130 command_builder_find_leaf_1 (struct command_builder *builder) | |
| 3131 { | |
| 3132 Lisp_Object event0 = builder->current_events; | |
| 3133 | |
| 3134 if (NILP (event0)) | |
| 3135 return Qnil; | |
| 3136 | |
| 3137 return event_binding (event0, 1); | |
| 3138 } | |
| 3139 | |
| 1268 | 3140 static void |
| 3141 maybe_kbd_translate (Lisp_Object event) | |
| 3142 { | |
| 3143 Ichar c; | |
| 3144 int did_translate = 0; | |
| 3145 | |
| 3146 if (XEVENT_TYPE (event) != key_press_event) | |
| 3147 return; | |
| 3148 if (!HASH_TABLEP (Vkeyboard_translate_table)) | |
| 3149 return; | |
| 3150 if (EQ (Fhash_table_count (Vkeyboard_translate_table), Qzero)) | |
| 3151 return; | |
| 3152 | |
| 2828 | 3153 c = event_to_character (event, 0, 0); |
| 1268 | 3154 if (c != -1) |
| 3155 { | |
| 3156 Lisp_Object traduit = Fgethash (make_char (c), Vkeyboard_translate_table, | |
| 3157 Qnil); | |
| 3158 if (!NILP (traduit) && SYMBOLP (traduit)) | |
| 3159 { | |
| 3160 XSET_EVENT_KEY_KEYSYM (event, traduit); | |
| 3161 XSET_EVENT_KEY_MODIFIERS (event, 0); | |
| 3162 did_translate = 1; | |
| 3163 } | |
| 3164 else if (CHARP (traduit)) | |
| 3165 { | |
| 3166 /* This used to call Fcharacter_to_event() directly into EVENT, | |
| 3167 but that can eradicate timestamps and other such stuff. | |
| 3168 This way is safer. */ | |
| 3169 Lisp_Object ev2 = Fmake_event (Qnil, Qnil); | |
| 3170 | |
| 3171 character_to_event (XCHAR (traduit), XEVENT (ev2), | |
|
4780
2fd201d73a92
Call character_to_event on characters received from XIM, event-Xt.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
4775
diff
changeset
|
3172 XCONSOLE (XEVENT_CHANNEL (event)), |
|
2fd201d73a92
Call character_to_event on characters received from XIM, event-Xt.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
4775
diff
changeset
|
3173 high_bit_is_meta, 1); |
| 1268 | 3174 XSET_EVENT_KEY_KEYSYM (event, XEVENT_KEY_KEYSYM (ev2)); |
| 3175 XSET_EVENT_KEY_MODIFIERS (event, XEVENT_KEY_MODIFIERS (ev2)); | |
| 3176 Fdeallocate_event (ev2); | |
| 3177 did_translate = 1; | |
| 3178 } | |
| 3179 } | |
| 3180 | |
| 3181 if (!did_translate) | |
| 3182 { | |
| 3183 Lisp_Object traduit = Fgethash (XEVENT_KEY_KEYSYM (event), | |
| 3184 Vkeyboard_translate_table, Qnil); | |
| 3185 if (!NILP (traduit) && SYMBOLP (traduit)) | |
| 3186 { | |
| 3187 XSET_EVENT_KEY_KEYSYM (event, traduit); | |
| 3188 did_translate = 1; | |
| 3189 } | |
| 3190 else if (CHARP (traduit)) | |
| 3191 { | |
| 3192 /* This used to call Fcharacter_to_event() directly into EVENT, | |
| 3193 but that can eradicate timestamps and other such stuff. | |
| 3194 This way is safer. */ | |
| 3195 Lisp_Object ev2 = Fmake_event (Qnil, Qnil); | |
| 3196 | |
| 3197 character_to_event (XCHAR (traduit), XEVENT (ev2), | |
|
4780
2fd201d73a92
Call character_to_event on characters received from XIM, event-Xt.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
4775
diff
changeset
|
3198 XCONSOLE (XEVENT_CHANNEL (event)), |
|
2fd201d73a92
Call character_to_event on characters received from XIM, event-Xt.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
4775
diff
changeset
|
3199 high_bit_is_meta, 1); |
| 1268 | 3200 XSET_EVENT_KEY_KEYSYM (event, XEVENT_KEY_KEYSYM (ev2)); |
| 3201 XSET_EVENT_KEY_MODIFIERS (event, | |
| 3202 XEVENT_KEY_MODIFIERS (event) | | |
| 3203 XEVENT_KEY_MODIFIERS (ev2)); | |
| 3204 | |
| 3205 Fdeallocate_event (ev2); | |
| 3206 did_translate = 1; | |
| 3207 } | |
| 3208 } | |
| 3209 | |
| 3210 #ifdef DEBUG_XEMACS | |
| 3211 if (did_translate) | |
| 3212 DEBUG_PRINT_EMACS_EVENT ("->keyboard-translate-table", event); | |
| 3213 #endif | |
| 3214 } | |
| 3215 | |
| 428 | 3216 /* See if we can do function-key-map or key-translation-map translation |
| 3217 on the current events in the command builder. If so, do this, and | |
| 771 | 3218 return the resulting binding, if any. |
| 3219 | |
| 3220 DID_MUNGE must be initialized before calling this function. If munging | |
| 3221 happened, DID_MUNGE will be non-zero; otherwise, it will be left alone. | |
| 3222 */ | |
| 428 | 3223 |
| 3224 static Lisp_Object | |
| 3225 munge_keymap_translate (struct command_builder *builder, | |
| 3226 enum munge_me_out_the_door munge, | |
| 771 | 3227 int has_normal_binding_p, int *did_munge) |
| 428 | 3228 { |
| 3229 Lisp_Object suffix; | |
| 3230 | |
| 1204 | 3231 EVENT_CHAIN_LOOP (suffix, builder->first_mungeable_event[munge]) |
| 428 | 3232 { |
| 3233 Lisp_Object result = munging_key_map_event_binding (suffix, munge); | |
| 3234 | |
| 3235 if (NILP (result)) | |
| 3236 continue; | |
| 3237 | |
| 3238 if (KEYMAPP (result)) | |
| 3239 { | |
| 3240 if (NILP (builder->last_non_munged_event) | |
| 3241 && !has_normal_binding_p) | |
| 3242 builder->last_non_munged_event = builder->most_current_event; | |
| 3243 } | |
| 3244 else | |
| 3245 builder->last_non_munged_event = Qnil; | |
| 3246 | |
| 3247 if (!KEYMAPP (result) && | |
| 3248 !VECTORP (result) && | |
| 3249 !STRINGP (result)) | |
| 3250 { | |
| 3251 struct gcpro gcpro1; | |
| 3252 GCPRO1 (suffix); | |
| 3253 result = call1 (result, Qnil); | |
| 3254 UNGCPRO; | |
| 3255 if (NILP (result)) | |
| 3256 return Qnil; | |
| 3257 } | |
| 3258 | |
| 3259 if (KEYMAPP (result)) | |
| 3260 return result; | |
| 3261 | |
| 3262 if (VECTORP (result) || STRINGP (result)) | |
| 3263 { | |
| 3264 Lisp_Object new_chain = key_sequence_to_event_chain (result); | |
| 3265 Lisp_Object tempev; | |
| 3266 | |
| 3267 /* If the first_mungeable_event of the other munger is | |
| 3268 within the events we're munging, then it will point to | |
| 3269 deallocated events afterwards, which is bad -- so make it | |
| 3270 point at the beginning of the munged events. */ | |
| 3271 EVENT_CHAIN_LOOP (tempev, suffix) | |
| 3272 { | |
| 3273 Lisp_Object *mungeable_event = | |
| 1204 | 3274 &builder->first_mungeable_event[1 - munge]; |
| 428 | 3275 if (EQ (tempev, *mungeable_event)) |
| 3276 { | |
| 3277 *mungeable_event = new_chain; | |
| 3278 break; | |
| 3279 } | |
| 3280 } | |
| 3281 | |
| 771 | 3282 /* Now munge the current event chain in the command builder. */ |
| 428 | 3283 command_builder_replace_suffix (builder, suffix, new_chain); |
| 1204 | 3284 builder->first_mungeable_event[munge] = Qnil; |
| 771 | 3285 |
| 3286 *did_munge = 1; | |
| 428 | 3287 |
| 793 | 3288 return command_builder_find_leaf_1 (builder); |
| 428 | 3289 } |
| 3290 | |
| 563 | 3291 signal_error (Qinvalid_key_binding, |
| 3292 (munge == MUNGE_ME_FUNCTION_KEY ? | |
| 3293 "Invalid binding in function-key-map" : | |
| 3294 "Invalid binding in key-translation-map"), | |
| 3295 result); | |
| 428 | 3296 } |
| 3297 | |
| 3298 return Qnil; | |
| 3299 } | |
| 3300 | |
| 2828 | 3301 /* Same as command_builder_find_leaf() below, but without offering the |
| 3302 platform-specific event code the opportunity to give a default binding of | |
| 3303 an unseen keysym to self-insert-command, and without the fallback to | |
| 3304 other keymaps for lookups that allows someone with a Cyrillic keyboard | |
| 3305 to pretend it's Qwerty for C-x C-f, for example. */ | |
| 771 | 3306 |
| 428 | 3307 static Lisp_Object |
| 2828 | 3308 command_builder_find_leaf_no_jit_binding (struct command_builder *builder, |
| 771 | 3309 int allow_misc_user_events_p, |
| 3310 int *did_munge) | |
| 428 | 3311 { |
| 3312 /* This function can GC */ | |
| 3313 Lisp_Object result; | |
| 3314 Lisp_Object evee = builder->current_events; | |
| 3315 | |
| 3316 if (XEVENT_TYPE (evee) == misc_user_event) | |
| 3317 { | |
| 3318 if (allow_misc_user_events_p && (NILP (XEVENT_NEXT (evee)))) | |
| 1204 | 3319 return list2 (XEVENT_EVAL_FUNCTION (evee), |
| 3320 XEVENT_EVAL_OBJECT (evee)); | |
| 428 | 3321 else |
| 3322 return Qnil; | |
| 3323 } | |
| 3324 | |
| 442 | 3325 /* if we're currently in a menu accelerator, check there for further |
| 3326 events */ | |
| 3327 /* #### fuck me! who wrote this crap? think "abstraction", baby. */ | |
| 771 | 3328 /* #### this horribly-written crap can mess with global state, which |
| 3329 this function should not do. i'm not fixing it now. someone | |
| 3330 needs to go and rewrite that shit correctly. --ben */ | |
| 1268 | 3331 #if defined (HAVE_X_WINDOWS) && defined (LWLIB_MENUBARS_LUCID) |
| 442 | 3332 if (x_kludge_lw_menu_active ()) |
| 428 | 3333 { |
| 3334 return command_builder_operate_menu_accelerator (builder); | |
| 3335 } | |
| 3336 else | |
| 3337 { | |
| 3338 result = Qnil; | |
| 3339 if (EQ (Vmenu_accelerator_enabled, Qmenu_force)) | |
| 3340 result = command_builder_find_menu_accelerator (builder); | |
| 3341 if (NILP (result)) | |
| 3342 #endif | |
| 3343 result = command_builder_find_leaf_1 (builder); | |
| 1268 | 3344 #if defined (HAVE_X_WINDOWS) && defined (LWLIB_MENUBARS_LUCID) |
| 428 | 3345 if (NILP (result) |
| 3346 && EQ (Vmenu_accelerator_enabled, Qmenu_fallback)) | |
| 3347 result = command_builder_find_menu_accelerator (builder); | |
| 3348 } | |
| 3349 #endif | |
| 3350 | |
| 3351 /* Check to see if we have a potential function-key-map match. */ | |
| 3352 if (NILP (result)) | |
| 771 | 3353 result = munge_keymap_translate (builder, MUNGE_ME_FUNCTION_KEY, 0, |
| 3354 did_munge); | |
| 3355 | |
| 428 | 3356 /* Check to see if we have a potential key-translation-map match. */ |
| 3357 { | |
| 3358 Lisp_Object key_translate_result = | |
| 3359 munge_keymap_translate (builder, MUNGE_ME_KEY_TRANSLATION, | |
| 771 | 3360 !NILP (result), did_munge); |
| 428 | 3361 if (!NILP (key_translate_result)) |
| 771 | 3362 result = key_translate_result; |
| 428 | 3363 } |
| 3364 | |
| 3365 if (!NILP (result)) | |
| 3366 return result; | |
| 3367 | |
| 3368 /* If key-sequence wasn't bound, we'll try some fallbacks. */ | |
| 3369 | |
| 3370 /* If we didn't find a binding, and the last event in the sequence is | |
| 3371 a shifted character, then try again with the lowercase version. */ | |
| 3372 | |
| 3373 if (XEVENT_TYPE (builder->most_current_event) == key_press_event | |
| 3374 && !NILP (Vretry_undefined_key_binding_unshifted)) | |
| 3375 { | |
| 1204 | 3376 if (event_upshifted_p (builder->most_current_event)) |
| 428 | 3377 { |
| 771 | 3378 Lisp_Object neubauten = copy_command_builder (builder, 0); |
| 3379 struct command_builder *neub = XCOMMAND_BUILDER (neubauten); | |
| 3380 struct gcpro gcpro1; | |
| 3381 | |
| 3382 GCPRO1 (neubauten); | |
| 1204 | 3383 downshift_event (event_chain_tail (neub->current_events)); |
| 771 | 3384 result = |
| 2828 | 3385 command_builder_find_leaf_no_jit_binding |
| 771 | 3386 (neub, allow_misc_user_events_p, did_munge); |
| 3387 | |
| 428 | 3388 if (!NILP (result)) |
| 771 | 3389 { |
| 3390 copy_command_builder (neub, builder); | |
| 3391 *did_munge = 1; | |
| 3392 } | |
| 3393 free_command_builder (neub); | |
| 3394 UNGCPRO; | |
| 3395 if (!NILP (result)) | |
| 428 | 3396 return result; |
| 3397 } | |
| 3398 } | |
| 3399 | |
| 3400 /* help-char is `auto-bound' in every keymap */ | |
| 3401 if (!NILP (Vprefix_help_command) && | |
| 1204 | 3402 event_matches_key_specifier_p (builder->most_current_event, Vhelp_char)) |
| 428 | 3403 return Vprefix_help_command; |
| 3404 | |
| 771 | 3405 return Qnil; |
| 3406 } | |
| 3407 | |
| 3408 /* Compare the current state of the command builder against the local and | |
| 3409 global keymaps, and return the binding. If there is no match, try again, | |
| 3410 case-insensitively. The return value will be one of: | |
| 3411 -- nil (there is no binding) | |
| 3412 -- a keymap (part of a command has been specified) | |
| 3413 -- a command (anything that satisfies `commandp'; this includes | |
| 3414 some symbols, lists, subrs, strings, vectors, and | |
| 3415 compiled-function objects) | |
| 3416 | |
| 3417 This may "munge" the current event chain in the command builder; | |
| 3418 i.e. the sequence might be mutated into a different sequence, | |
| 3419 which we then pretend is what the user actually typed instead of | |
| 3420 the passed-in sequence. This happens as a result of: | |
| 3421 | |
| 3422 -- key-translation-map changes | |
| 3423 -- function-key-map changes | |
| 3424 -- retry-undefined-key-binding-unshifted (q.v.) | |
| 3425 -- "Russian C-x problem" changes (see definition of struct key_data, | |
| 3426 events.h) | |
| 3427 | |
| 3428 DID_MUNGE must be initialized before calling this function. If munging | |
| 3429 happened, DID_MUNGE will be non-zero; otherwise, it will be left alone. | |
| 2828 | 3430 |
| 3431 (The above was Ben, I think.) | |
| 3432 | |
| 3433 It might be nice to have lookup-key call this function, directly or | |
| 3434 indirectly. Though it is arguably the right thing if lookup-key fails on | |
| 3435 a keysym that the X11 event code hasn't seen. There's no way to know if | |
| 3436 that keysym is generatable by the keyboard until it's generated, | |
| 3437 therefore there's no reasonable expectation that it be bound before it's | |
| 3438 generated--all the other default bindings depend on our knowing the | |
| 3439 keyboard layout and relying on it. And describe-key works without it, so | |
| 3440 I think we're fine. | |
| 3441 | |
| 3442 Some weirdness with this code--try this on a keyboard where X11 will | |
| 3443 produce ediaeresis with dead-diaeresis and e, but it's not produced by | |
| 3444 any other combination of keys on the keyboard; | |
| 3445 | |
| 3446 (defun ding-command () | |
| 3447 (interactive) | |
| 3448 (ding)) | |
| 3449 | |
| 3450 (define-key global-map 'ediaeresis 'ding-command) | |
| 3451 | |
| 3452 Now, pressing dead-diaeresis and then e will ding. Next; | |
| 3453 | |
| 3454 (define-key global-map 'ediaeresis 'self-insert-command) | |
| 3455 | |
| 3456 and press dead-diaeresis and then e. It'll give you "Invalid argument: | |
| 3457 typed key has no ASCII equivalent" Then; | |
| 3458 | |
| 3459 (define-key global-map 'ediaeresis nil) | |
| 3460 | |
| 3461 and press the combination again; it'll self-insert. The moral of the | |
| 3462 story is, if you want to suppress all bindings to a non-ASCII X11 key, | |
| 3463 bind it to a trivial no-op command, because the automatic mapping to | |
| 3464 self-insert-command will happen if there's no existing binding for the | |
| 3465 symbol. I can't see a way around this. -- Aidan Kehoe, 2005-05-14 */ | |
| 771 | 3466 |
| 3467 static Lisp_Object | |
| 3468 command_builder_find_leaf (struct command_builder *builder, | |
| 3469 int allow_misc_user_events_p, | |
| 3470 int *did_munge) | |
| 3471 { | |
| 3472 Lisp_Object result = | |
| 2828 | 3473 command_builder_find_leaf_no_jit_binding |
| 771 | 3474 (builder, allow_misc_user_events_p, did_munge); |
| 2828 | 3475 Lisp_Object event, console, channel, lookup_res; |
| 3476 int redolookup = 0, i; | |
| 771 | 3477 |
| 3478 if (!NILP (result)) | |
| 3479 return result; | |
| 3480 | |
| 2828 | 3481 /* If some of the events are keyboard events, and this is the first time |
| 3482 the platform event code has seen their keysyms--which will be the case | |
| 3483 the first time we see a composed keysym on X11, for example--offer it | |
| 3484 the chance to define them as a self-insert-command, and do the lookup | |
| 3485 again. | |
| 3486 | |
| 3487 This isn't Mule-specific; in a world where x-iso8859-1.el is gone, it's | |
| 3488 needed for non-Mule too. | |
| 3489 | |
| 3490 Probably this can just be limited to the checking the last | |
| 3491 keypress. */ | |
| 3492 | |
| 3493 EVENT_CHAIN_LOOP (event, builder->current_events) | |
| 3494 { | |
| 3495 /* We can ignore key release events because the preceding presses will | |
| 3496 have initiated the mapping. */ | |
| 3497 if (key_press_event != XEVENT_TYPE (event)) | |
| 3498 continue; | |
| 3499 | |
| 3500 channel = XEVENT_CHANNEL (event); | |
| 3501 if (object_dead_p (channel)) | |
| 3502 continue; | |
| 3503 | |
| 3504 console = CDFW_CONSOLE (channel); | |
| 3505 if (NILP (console)) | |
| 3506 console = Vselected_console; | |
| 3507 | |
| 3508 if (CONSOLE_LIVE_P(XCONSOLE(console))) | |
| 3509 { | |
| 3510 lookup_res = MAYBE_LISP_CONMETH(XCONSOLE(console), | |
| 3511 perhaps_init_unseen_key_defaults, | |
| 3512 (XCONSOLE(console), | |
| 3513 XEVENT_KEY_KEYSYM(event))); | |
| 3514 if (EQ(lookup_res, Qt)) | |
| 3515 { | |
| 3516 redolookup += 1; | |
| 3517 } | |
| 3518 } | |
| 3519 } | |
| 3520 | |
| 3521 if (redolookup) | |
| 428 | 3522 { |
| 2828 | 3523 result = command_builder_find_leaf_no_jit_binding |
| 3524 (builder, allow_misc_user_events_p, did_munge); | |
| 3525 if (!NILP (result)) | |
| 3526 { | |
| 3527 return result; | |
| 3528 } | |
| 3529 } | |
| 3530 | |
| 3531 /* The old composed-character-default-binding handling that used to be | |
| 3532 here was wrong--if a user wants to bind a given key to something other | |
| 3533 than self-insert-command, then they should go ahead and do it, we won't | |
| 3534 override it, and the sane thing to do with any key that has a known | |
| 3535 character correspondence is _always_ to default it to | |
| 3536 self-insert-command, nothing else. | |
| 3537 | |
| 3538 I'm adding the variable to control whether "Russian C-x processing" is | |
| 3539 used because I have a feeling that it's not always the most appropriate | |
| 3540 thing to do--in cases where people are using a non-Qwerty | |
| 3541 Roman-alphabet layout, do they really want C-x with some random letter | |
| 3542 to call `switch-to-buffer'? I can imagine that being very confusing, | |
| 3543 certainly for new users, and it might be that defaulting the value for | |
| 3544 `try-alternate-layouts-for-commands' as part of the language | |
| 3545 environment is the right thing to do, only defaulting to `t' for those | |
| 3546 languages that don't use the Roman alphabet. | |
| 3547 | |
| 3548 Much of that reasoning is tentative on my part, and feel free to change | |
| 3549 this code if you have more experience with the problem and an intuition | |
| 3550 that differs from mine. (Aidan Kehoe, 2005-05-29)*/ | |
| 3551 | |
| 3552 if (!try_alternate_layouts_for_commands) | |
| 3553 { | |
| 3554 return Qnil; | |
| 428 | 3555 } |
| 2828 | 3556 |
| 3557 if (key_press_event == XEVENT_TYPE (builder->most_current_event)) | |
| 3558 { | |
| 3559 Lisp_Object ev = builder->most_current_event, newbuilder; | |
| 3560 Ichar this_alternative; | |
| 3561 | |
| 3562 struct command_builder *newb; | |
| 3563 struct gcpro gcpro1; | |
| 3564 | |
| 3565 /* Ignore the value for CURRENT_LANGENV, because we've checked it | |
| 3566 already, above. */ | |
| 3567 for (i = KEYCHAR_CURRENT_LANGENV, ++i; i < KEYCHAR_LAST; ++i) | |
| 3568 { | |
| 3569 this_alternative = XEVENT_KEY_ALT_KEYCHARS(ev, i); | |
| 3570 | |
| 3571 if (0 == this_alternative) | |
| 3572 continue; | |
| 3573 | |
| 3574 newbuilder = copy_command_builder(builder, 0); | |
| 3575 GCPRO1(newbuilder); | |
| 3576 | |
| 3577 newb = XCOMMAND_BUILDER(newbuilder); | |
| 3578 | |
| 2830 | 3579 XSET_EVENT_KEY_KEYSYM(event_chain_tail |
| 3580 (XCOMMAND_BUILDER(newbuilder)->current_events), | |
| 2828 | 3581 make_char(this_alternative)); |
| 3582 | |
| 3583 result = command_builder_find_leaf_no_jit_binding | |
| 3584 (newb, allow_misc_user_events_p, did_munge); | |
| 3585 | |
| 3586 if (!NILP (result)) | |
| 3587 { | |
| 3588 copy_command_builder (newb, builder); | |
| 3589 *did_munge = 1; | |
| 3590 } | |
| 2830 | 3591 else if (event_upshifted_p |
| 3592 (XCOMMAND_BUILDER(newbuilder)->most_current_event) && | |
| 2828 | 3593 !NILP (Vretry_undefined_key_binding_unshifted) |
| 3594 && isascii(this_alternative)) | |
| 3595 { | |
| 2830 | 3596 downshift_event (event_chain_tail |
| 3597 (XCOMMAND_BUILDER(newbuilder)->current_events)); | |
| 3598 XSET_EVENT_KEY_KEYSYM(event_chain_tail | |
| 3599 (newb->current_events), | |
| 2828 | 3600 make_char(tolower(this_alternative))); |
| 3601 result = command_builder_find_leaf_no_jit_binding | |
| 3602 (newb, allow_misc_user_events_p, did_munge); | |
| 3603 } | |
| 3604 | |
| 3605 free_command_builder (newb); | |
| 3606 UNGCPRO; | |
| 3607 | |
| 3608 if (!NILP (result)) | |
| 3609 return result; | |
| 3610 } | |
| 3611 } | |
| 428 | 3612 |
| 3613 return Qnil; | |
| 3614 } | |
| 3615 | |
| 771 | 3616 /* Like command_builder_find_leaf but update this-command-keys and the |
| 3617 echo area as necessary when the current event chain was munged. */ | |
| 3618 | |
| 3619 static Lisp_Object | |
| 3620 command_builder_find_leaf_and_update_global_state (struct command_builder * | |
| 3621 builder, | |
| 3622 int | |
| 3623 allow_misc_user_events_p) | |
| 3624 { | |
| 3625 int did_munge = 0; | |
| 3626 int orig_length = event_chain_count (builder->current_events); | |
| 3627 Lisp_Object result = command_builder_find_leaf (builder, | |
| 3628 allow_misc_user_events_p, | |
| 3629 &did_munge); | |
| 3630 | |
| 3631 if (did_munge) | |
| 3632 { | |
| 3633 int tck_length = event_chain_count (Vthis_command_keys); | |
| 3634 | |
| 3635 /* We just assume that the events we just replaced are | |
| 3636 sitting in copied form at the end of this-command-keys. | |
| 3637 If the user did weird things with `dispatch-event' this | |
| 3638 may not be the case, but at least we make sure we won't | |
| 3639 crash. */ | |
| 3640 | |
| 3641 if (tck_length >= orig_length) | |
| 3642 { | |
| 3643 Lisp_Object new_chain = | |
| 3644 copy_event_chain (builder->current_events); | |
| 3645 this_command_keys_replace_suffix | |
| 3646 (event_chain_nth (Vthis_command_keys, tck_length - orig_length), | |
| 3647 new_chain); | |
| 3648 | |
| 3649 regenerate_echo_keys_from_this_command_keys (builder); | |
| 3650 } | |
| 3651 } | |
| 3652 | |
| 3653 if (NILP (result)) | |
| 3654 { | |
| 3655 /* If we read extra events attempting to match a function key but end | |
| 3656 up failing, then we release those events back to the command loop | |
| 3657 and fail on the original lookup. The released events will then be | |
| 3658 reprocessed in the context of the first part having failed. */ | |
| 3659 if (!NILP (builder->last_non_munged_event)) | |
| 3660 { | |
| 3661 Lisp_Object event0 = builder->last_non_munged_event; | |
| 3662 | |
| 3663 /* Put the commands back on the event queue. */ | |
| 3664 enqueue_event_chain (XEVENT_NEXT (event0), | |
| 3665 &command_event_queue, | |
| 3666 &command_event_queue_tail); | |
| 3667 | |
| 3668 /* Then remove them from the command builder. */ | |
| 3669 XSET_EVENT_NEXT (event0, Qnil); | |
| 3670 builder->most_current_event = event0; | |
| 3671 builder->last_non_munged_event = Qnil; | |
| 3672 } | |
| 3673 } | |
| 3674 | |
| 3675 return result; | |
| 3676 } | |
| 428 | 3677 |
| 3678 /* Every time a command-event (a key, button, or menu selection) is read by | |
| 3679 Fnext_event(), it is stored in the recent_keys_ring, in Vlast_input_event, | |
| 3680 and in Vthis_command_keys. (Eval-events are not stored there.) | |
| 3681 | |
| 3682 Every time a command is invoked, Vlast_command_event is set to the last | |
| 3683 event in the sequence. | |
| 3684 | |
| 3685 This means that Vthis_command_keys is really about "input read since the | |
| 3686 last command was executed" rather than about "what keys invoked this | |
| 3687 command." This is a little counterintuitive, but that's the way it | |
| 3688 has always worked. | |
| 3689 | |
| 3690 As an extra kink, the function read-key-sequence resets/updates the | |
| 3691 last-command-event and this-command-keys. It doesn't append to the | |
| 3692 command-keys as read-char does. Such are the pitfalls of having to | |
| 3693 maintain compatibility with a program for which the only specification | |
| 3694 is the code itself. | |
| 3695 | |
| 3696 (We could implement recent_keys_ring and Vthis_command_keys as the same | |
| 3697 data structure.) | |
| 3698 */ | |
| 3699 | |
| 3700 DEFUN ("recent-keys", Frecent_keys, 0, 1, 0, /* | |
| 3701 Return a vector of recent keyboard or mouse button events read. | |
| 3702 If NUMBER is non-nil, not more than NUMBER events will be returned. | |
| 3703 Change number of events stored using `set-recent-keys-ring-size'. | |
| 3704 | |
| 3705 This copies the event objects into a new vector; it is safe to keep and | |
| 3706 modify them. | |
| 3707 */ | |
| 3708 (number)) | |
| 3709 { | |
| 3710 struct gcpro gcpro1; | |
| 3711 Lisp_Object val = Qnil; | |
| 3712 int nwanted; | |
| 3713 int start, nkeys, i, j; | |
| 3714 GCPRO1 (val); | |
| 3715 | |
| 3716 if (NILP (number)) | |
| 3717 nwanted = recent_keys_ring_size; | |
| 3718 else | |
| 3719 { | |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
3720 check_integer_range (number, Qzero, |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
3721 make_integer (ARRAY_DIMENSION_LIMIT)); |
| 428 | 3722 nwanted = XINT (number); |
| 3723 } | |
| 3724 | |
| 3725 /* Create the keys ring vector, if none present. */ | |
| 3726 if (NILP (Vrecent_keys_ring)) | |
| 3727 { | |
| 3728 Vrecent_keys_ring = make_vector (recent_keys_ring_size, Qnil); | |
| 3729 /* And return nothing in particular. */ | |
| 446 | 3730 RETURN_UNGCPRO (make_vector (0, Qnil)); |
| 428 | 3731 } |
| 3732 | |
| 3733 if (NILP (XVECTOR_DATA (Vrecent_keys_ring)[recent_keys_ring_index])) | |
| 3734 /* This means the vector has not yet wrapped */ | |
| 3735 { | |
| 3736 nkeys = recent_keys_ring_index; | |
| 3737 start = 0; | |
| 3738 } | |
| 3739 else | |
| 3740 { | |
| 3741 nkeys = recent_keys_ring_size; | |
| 3742 start = ((recent_keys_ring_index == nkeys) ? 0 : recent_keys_ring_index); | |
| 3743 } | |
| 3744 | |
| 3745 if (nwanted < nkeys) | |
| 3746 { | |
| 3747 start += nkeys - nwanted; | |
| 3748 if (start >= recent_keys_ring_size) | |
| 3749 start -= recent_keys_ring_size; | |
| 3750 nkeys = nwanted; | |
| 3751 } | |
| 3752 else | |
| 3753 nwanted = nkeys; | |
| 3754 | |
| 3755 val = make_vector (nwanted, Qnil); | |
| 3756 | |
| 3757 for (i = 0, j = start; i < nkeys; i++) | |
| 3758 { | |
| 3759 Lisp_Object e = XVECTOR_DATA (Vrecent_keys_ring)[j]; | |
| 3760 | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
4976
diff
changeset
|
3761 assert (!NILP (e)); |
| 428 | 3762 XVECTOR_DATA (val)[i] = Fcopy_event (e, Qnil); |
| 3763 if (++j >= recent_keys_ring_size) | |
| 3764 j = 0; | |
| 3765 } | |
| 3766 UNGCPRO; | |
| 3767 return val; | |
| 3768 } | |
| 3769 | |
| 3770 | |
| 3771 DEFUN ("recent-keys-ring-size", Frecent_keys_ring_size, 0, 0, 0, /* | |
| 3772 The maximum number of events `recent-keys' can return. | |
| 3773 */ | |
| 3774 ()) | |
| 3775 { | |
| 3776 return make_int (recent_keys_ring_size); | |
| 3777 } | |
| 3778 | |
| 3779 DEFUN ("set-recent-keys-ring-size", Fset_recent_keys_ring_size, 1, 1, 0, /* | |
| 3780 Set the maximum number of events to be stored internally. | |
| 3781 */ | |
| 3782 (size)) | |
| 3783 { | |
| 3784 Lisp_Object new_vector = Qnil; | |
| 3785 int i, j, nkeys, start, min; | |
| 3786 struct gcpro gcpro1; | |
| 3787 | |
| 3788 CHECK_INT (size); | |
| 3789 if (XINT (size) <= 0) | |
| 563 | 3790 invalid_argument ("Recent keys ring size must be positive", size); |
| 428 | 3791 if (XINT (size) == recent_keys_ring_size) |
| 3792 return size; | |
| 3793 | |
| 446 | 3794 GCPRO1 (new_vector); |
| 428 | 3795 new_vector = make_vector (XINT (size), Qnil); |
| 3796 | |
| 3797 if (NILP (Vrecent_keys_ring)) | |
| 3798 { | |
| 3799 Vrecent_keys_ring = new_vector; | |
| 446 | 3800 RETURN_UNGCPRO (size); |
| 428 | 3801 } |
| 3802 | |
| 3803 if (NILP (XVECTOR_DATA (Vrecent_keys_ring)[recent_keys_ring_index])) | |
| 3804 /* This means the vector has not yet wrapped */ | |
| 3805 { | |
| 3806 nkeys = recent_keys_ring_index; | |
| 3807 start = 0; | |
| 3808 } | |
| 3809 else | |
| 3810 { | |
| 3811 nkeys = recent_keys_ring_size; | |
| 3812 start = ((recent_keys_ring_index == nkeys) ? 0 : recent_keys_ring_index); | |
| 3813 } | |
| 3814 | |
| 3815 if (XINT (size) > nkeys) | |
| 3816 min = nkeys; | |
| 3817 else | |
| 3818 min = XINT (size); | |
| 3819 | |
| 3820 for (i = 0, j = start; i < min; i++) | |
| 3821 { | |
| 3822 XVECTOR_DATA (new_vector)[i] = XVECTOR_DATA (Vrecent_keys_ring)[j]; | |
| 3823 if (++j >= recent_keys_ring_size) | |
| 3824 j = 0; | |
| 3825 } | |
| 3826 recent_keys_ring_size = XINT (size); | |
| 3827 recent_keys_ring_index = (i < recent_keys_ring_size) ? i : 0; | |
| 3828 | |
| 3829 Vrecent_keys_ring = new_vector; | |
| 3830 | |
| 3831 UNGCPRO; | |
| 3832 return size; | |
| 3833 } | |
| 3834 | |
| 3835 /* Vthis_command_keys having value Qnil means that the next time | |
| 3836 push_this_command_keys is called, it should start over. | |
| 3837 The times at which the command-keys are reset | |
| 3838 (instead of merely being augmented) are pretty counterintuitive. | |
| 3839 (More specifically: | |
| 3840 | |
| 3841 -- We do not reset this-command-keys when we finish reading a | |
| 3842 command. This is because some commands (e.g. C-u) act | |
| 3843 like command prefixes; they signal this by setting prefix-arg | |
| 3844 to non-nil. | |
| 3845 -- Therefore, we reset this-command-keys when we finish | |
| 3846 executing a command, unless prefix-arg is set. | |
| 3847 -- However, if we ever do a non-local exit out of a command | |
| 3848 loop (e.g. an error in a command), we need to reset | |
| 3849 this-command-keys. We do this by calling reset_this_command_keys() | |
| 3850 from cmdloop.c, whenever an error causes an invocation of the | |
| 3851 default error handler, and whenever there's a throw to top-level.) | |
| 3852 */ | |
| 3853 | |
| 3854 void | |
| 3855 reset_this_command_keys (Lisp_Object console, int clear_echo_area_p) | |
| 3856 { | |
| 757 | 3857 if (!NILP (console)) |
| 3858 { | |
| 3859 /* console is nil if we just deleted the console as a result of C-x 5 | |
| 3860 0. Unfortunately things are currently in a messy situation where | |
| 3861 some stuff is console-local and other stuff isn't, so we need to | |
| 3862 do everything that's not console-local. */ | |
| 3863 struct command_builder *command_builder = | |
| 3864 XCOMMAND_BUILDER (XCONSOLE (console)->command_builder); | |
| 3865 | |
| 3866 reset_key_echo (command_builder, clear_echo_area_p); | |
| 3867 reset_current_events (command_builder); | |
| 3868 } | |
| 3869 else | |
| 3870 reset_key_echo (0, clear_echo_area_p); | |
| 428 | 3871 |
| 3872 deallocate_event_chain (Vthis_command_keys); | |
| 3873 Vthis_command_keys = Qnil; | |
| 3874 Vthis_command_keys_tail = Qnil; | |
| 3875 } | |
| 3876 | |
| 3877 static void | |
| 3878 push_this_command_keys (Lisp_Object event) | |
| 3879 { | |
| 3025 | 3880 Lisp_Object new_ = Fmake_event (Qnil, Qnil); |
| 3881 | |
| 3882 Fcopy_event (event, new_); | |
| 3883 enqueue_event (new_, &Vthis_command_keys, &Vthis_command_keys_tail); | |
| 428 | 3884 } |
| 3885 | |
| 3886 /* The following two functions are used in call-interactively, | |
| 3887 for the @ and e specifications. We used to just use | |
| 3888 `current-mouse-event' (i.e. the last mouse event in this-command-keys), | |
| 3889 but FSF does it more generally so we follow their lead. */ | |
| 3890 | |
| 3891 Lisp_Object | |
| 3892 extract_this_command_keys_nth_mouse_event (int n) | |
| 3893 { | |
| 3894 Lisp_Object event; | |
| 3895 | |
| 3896 EVENT_CHAIN_LOOP (event, Vthis_command_keys) | |
| 3897 { | |
| 3898 if (EVENTP (event) | |
| 3899 && (XEVENT_TYPE (event) == button_press_event | |
| 3900 || XEVENT_TYPE (event) == button_release_event | |
| 3901 || XEVENT_TYPE (event) == misc_user_event)) | |
| 3902 { | |
| 3903 if (!n) | |
| 3904 { | |
| 2500 | 3905 /* must copy to avoid an ABORT() in next_event_internal() */ |
| 428 | 3906 if (!NILP (XEVENT_NEXT (event))) |
| 3907 return Fcopy_event (event, Qnil); | |
| 3908 else | |
| 3909 return event; | |
| 3910 } | |
| 3911 n--; | |
| 3912 } | |
| 3913 } | |
| 3914 | |
| 3915 return Qnil; | |
| 3916 } | |
| 3917 | |
| 3918 Lisp_Object | |
| 3919 extract_vector_nth_mouse_event (Lisp_Object vector, int n) | |
| 3920 { | |
| 3921 int i; | |
| 3922 int len = XVECTOR_LENGTH (vector); | |
| 3923 | |
| 3924 for (i = 0; i < len; i++) | |
| 3925 { | |
| 3926 Lisp_Object event = XVECTOR_DATA (vector)[i]; | |
| 3927 if (EVENTP (event)) | |
| 3928 switch (XEVENT_TYPE (event)) | |
| 3929 { | |
| 3930 case button_press_event : | |
| 3931 case button_release_event : | |
| 3932 case misc_user_event : | |
| 3933 if (n == 0) | |
| 3934 return event; | |
| 3935 n--; | |
| 3936 break; | |
| 3937 default: | |
| 3938 continue; | |
| 3939 } | |
| 3940 } | |
| 3941 | |
| 3942 return Qnil; | |
| 3943 } | |
| 3944 | |
| 3945 static void | |
| 3946 push_recent_keys (Lisp_Object event) | |
| 3947 { | |
| 3948 Lisp_Object e; | |
| 3949 | |
| 3950 if (NILP (Vrecent_keys_ring)) | |
| 3951 Vrecent_keys_ring = make_vector (recent_keys_ring_size, Qnil); | |
| 3952 | |
| 3953 e = XVECTOR_DATA (Vrecent_keys_ring) [recent_keys_ring_index]; | |
| 3954 | |
| 3955 if (NILP (e)) | |
| 3956 { | |
| 3957 e = Fmake_event (Qnil, Qnil); | |
| 3958 XVECTOR_DATA (Vrecent_keys_ring) [recent_keys_ring_index] = e; | |
| 3959 } | |
| 3960 Fcopy_event (event, e); | |
| 3961 if (++recent_keys_ring_index == recent_keys_ring_size) | |
| 3962 recent_keys_ring_index = 0; | |
| 3963 } | |
| 3964 | |
| 3965 | |
| 3966 static Lisp_Object | |
| 3967 current_events_into_vector (struct command_builder *command_builder) | |
| 3968 { | |
| 3969 Lisp_Object vector; | |
| 3970 Lisp_Object event; | |
| 3971 int n = event_chain_count (command_builder->current_events); | |
| 3972 | |
| 3973 /* Copy the vector and the events in it. */ | |
| 3974 /* No need to copy the events, since they're already copies, and | |
| 3975 nobody other than the command-builder has pointers to them */ | |
| 3976 vector = make_vector (n, Qnil); | |
| 3977 n = 0; | |
| 3978 EVENT_CHAIN_LOOP (event, command_builder->current_events) | |
| 3979 XVECTOR_DATA (vector)[n++] = event; | |
| 3980 reset_command_builder_event_chain (command_builder); | |
| 3981 return vector; | |
| 3982 } | |
| 3983 | |
| 3984 | |
| 3985 /* | |
| 3986 Given the current state of the command builder and a new command event | |
| 3987 that has just been dispatched: | |
| 3988 | |
| 3989 -- add the event to the event chain forming the current command | |
| 3990 (doing meta-translation as necessary) | |
| 3991 -- return the binding of this event chain; this will be one of: | |
| 3992 -- nil (there is no binding) | |
| 3993 -- a keymap (part of a command has been specified) | |
| 3994 -- a command (anything that satisfies `commandp'; this includes | |
| 3995 some symbols, lists, subrs, strings, vectors, and | |
| 3996 compiled-function objects) | |
| 3997 */ | |
| 3998 static Lisp_Object | |
| 3999 lookup_command_event (struct command_builder *command_builder, | |
| 4000 Lisp_Object event, int allow_misc_user_events_p) | |
| 4001 { | |
| 4002 /* This function can GC */ | |
| 4003 struct frame *f = selected_frame (); | |
| 4004 /* Clear output from previous command execution */ | |
| 4005 if (!EQ (Qcommand, echo_area_status (f)) | |
| 4006 /* but don't let mouse-up clear what mouse-down just printed */ | |
| 4007 && (XEVENT (event)->event_type != button_release_event)) | |
| 4008 clear_echo_area (f, Qnil, 0); | |
| 4009 | |
| 4010 /* Add the given event to the command builder. | |
| 4011 Extra hack: this also updates the recent_keys_ring and Vthis_command_keys | |
| 4012 vectors to translate "ESC x" to "M-x" (for any "x" of course). | |
| 4013 */ | |
| 4014 { | |
| 4015 Lisp_Object recent = command_builder->most_current_event; | |
| 4016 | |
| 4017 if (EVENTP (recent) | |
| 1204 | 4018 && event_matches_key_specifier_p (recent, Vmeta_prefix_char)) |
| 428 | 4019 { |
| 440 | 4020 Lisp_Event *e; |
| 428 | 4021 /* When we see a sequence like "ESC x", pretend we really saw "M-x". |
| 4022 DoubleThink the recent-keys and this-command-keys as well. */ | |
| 4023 | |
| 4024 /* Modify the previous most-recently-pushed event on the command | |
| 4025 builder to be a copy of this one with the meta-bit set instead of | |
| 4026 pushing a new event. | |
| 4027 */ | |
| 4028 Fcopy_event (event, recent); | |
| 4029 e = XEVENT (recent); | |
| 934 | 4030 if (EVENT_TYPE (e) == key_press_event) |
| 1204 | 4031 SET_EVENT_KEY_MODIFIERS (e, EVENT_KEY_MODIFIERS (e) | |
| 4032 XEMACS_MOD_META); | |
| 934 | 4033 else if (EVENT_TYPE (e) == button_press_event |
| 4034 || EVENT_TYPE (e) == button_release_event) | |
| 1204 | 4035 SET_EVENT_BUTTON_MODIFIERS (e, EVENT_BUTTON_MODIFIERS (e) | |
| 4036 XEMACS_MOD_META); | |
| 428 | 4037 else |
| 2500 | 4038 ABORT (); |
| 428 | 4039 |
| 4040 { | |
| 4041 int tckn = event_chain_count (Vthis_command_keys); | |
| 4042 if (tckn >= 2) | |
| 4043 /* ??? very strange if it's < 2. */ | |
| 4044 this_command_keys_replace_suffix | |
| 4045 (event_chain_nth (Vthis_command_keys, tckn - 2), | |
| 4046 Fcopy_event (recent, Qnil)); | |
| 4047 } | |
| 4048 | |
| 4049 regenerate_echo_keys_from_this_command_keys (command_builder); | |
| 4050 } | |
| 4051 else | |
| 771 | 4052 command_builder_append_event (command_builder, event); |
| 428 | 4053 } |
| 4054 | |
| 4055 { | |
| 771 | 4056 Lisp_Object leaf = |
| 4057 command_builder_find_leaf_and_update_global_state | |
| 4058 (command_builder, | |
| 4059 allow_misc_user_events_p); | |
| 428 | 4060 struct gcpro gcpro1; |
| 4061 GCPRO1 (leaf); | |
| 4062 | |
| 4063 if (KEYMAPP (leaf)) | |
| 4064 { | |
| 442 | 4065 #if defined (HAVE_X_WINDOWS) && defined (LWLIB_MENUBARS_LUCID) |
| 4066 if (!x_kludge_lw_menu_active ()) | |
| 4067 #else | |
| 4068 if (1) | |
| 4069 #endif | |
| 428 | 4070 { |
| 4071 Lisp_Object prompt = Fkeymap_prompt (leaf, Qt); | |
| 4072 if (STRINGP (prompt)) | |
| 4073 { | |
| 4074 /* Append keymap prompt to key echo buffer */ | |
| 4075 int buf_index = command_builder->echo_buf_index; | |
| 4076 Bytecount len = XSTRING_LENGTH (prompt); | |
| 4077 | |
| 4078 if (len + buf_index + 1 <= command_builder->echo_buf_length) | |
| 4079 { | |
| 867 | 4080 Ibyte *echo = command_builder->echo_buf + buf_index; |
| 428 | 4081 memcpy (echo, XSTRING_DATA (prompt), len); |
| 4082 echo[len] = 0; | |
| 4083 } | |
| 4084 maybe_echo_keys (command_builder, 1); | |
| 4085 } | |
| 4086 else | |
| 4087 maybe_echo_keys (command_builder, 0); | |
| 4088 } | |
| 853 | 4089 /* #### i don't trust this at all. --ben */ |
| 4090 #if 0 | |
| 442 | 4091 else if (!NILP (Vquit_flag)) |
| 4092 { | |
| 4093 /* if quit happened during menu acceleration, pretend we read it */ | |
| 4094 struct console *con = XCONSOLE (Fselected_console ()); | |
| 1204 | 4095 |
| 4096 enqueue_command_event (Fcopy_event (CONSOLE_QUIT_EVENT (con), | |
| 4097 Qnil)); | |
| 442 | 4098 Vquit_flag = Qnil; |
| 4099 } | |
| 853 | 4100 #endif |
| 428 | 4101 } |
| 4102 else if (!NILP (leaf)) | |
| 4103 { | |
| 4104 if (EQ (Qcommand, echo_area_status (f)) | |
| 4105 && command_builder->echo_buf_index > 0) | |
| 4106 { | |
| 4107 /* If we had been echoing keys, echo the last one (without | |
| 4108 the trailing dash) and redisplay before executing the | |
| 4109 command. */ | |
| 4110 command_builder->echo_buf[command_builder->echo_buf_index] = 0; | |
| 4111 maybe_echo_keys (command_builder, 1); | |
| 4112 Fsit_for (Qzero, Qt); | |
| 4113 } | |
| 4114 } | |
| 4115 RETURN_UNGCPRO (leaf); | |
| 4116 } | |
| 4117 } | |
| 4118 | |
| 479 | 4119 static int |
| 4932 | 4120 is_scrollbar_event (Lisp_Object USED_IF_SCROLLBARS (event)) |
| 479 | 4121 { |
| 516 | 4122 #ifdef HAVE_SCROLLBARS |
| 479 | 4123 Lisp_Object fun; |
| 4124 | |
| 934 | 4125 if (XEVENT_TYPE (event) != misc_user_event) |
| 4126 return 0; | |
| 1204 | 4127 fun = XEVENT_MISC_USER_FUNCTION (event); |
| 479 | 4128 |
| 4129 return (EQ (fun, Qscrollbar_line_up) || | |
| 4130 EQ (fun, Qscrollbar_line_down) || | |
| 4131 EQ (fun, Qscrollbar_page_up) || | |
| 4132 EQ (fun, Qscrollbar_page_down) || | |
| 4133 EQ (fun, Qscrollbar_to_top) || | |
| 4134 EQ (fun, Qscrollbar_to_bottom) || | |
| 4135 EQ (fun, Qscrollbar_vertical_drag) || | |
| 4136 EQ (fun, Qscrollbar_char_left) || | |
| 4137 EQ (fun, Qscrollbar_char_right) || | |
| 4138 EQ (fun, Qscrollbar_page_left) || | |
| 4139 EQ (fun, Qscrollbar_page_right) || | |
| 4140 EQ (fun, Qscrollbar_to_left) || | |
| 4141 EQ (fun, Qscrollbar_to_right) || | |
| 4142 EQ (fun, Qscrollbar_horizontal_drag)); | |
| 516 | 4143 #else |
| 4144 return 0; | |
| 4145 #endif /* HAVE_SCROLLBARS */ | |
| 479 | 4146 } |
| 4147 | |
| 428 | 4148 static void |
| 4149 execute_command_event (struct command_builder *command_builder, | |
| 4150 Lisp_Object event) | |
| 4151 { | |
| 4152 /* This function can GC */ | |
| 4153 struct console *con = XCONSOLE (command_builder->console); | |
| 4154 struct gcpro gcpro1; | |
| 4155 | |
| 4156 GCPRO1 (event); /* event may be freshly created */ | |
| 444 | 4157 |
| 479 | 4158 /* #### This call to is_scrollbar_event() isn't quite right, but |
| 4159 fixing properly it requires more work than can go into 21.4. | |
| 4160 (We really need to split out menu, scrollbar, dialog, and other | |
| 4161 types of events from misc-user, and put the remaining ones in a | |
| 4162 new `user-eval' type that behaves like an eval event but is a | |
| 4163 user event and thus has all of its semantics -- e.g. being | |
| 4164 delayed during `accept-process-output' and similar wait states.) | |
| 4165 | |
| 4166 The real issue here is that "user events" and "command events" | |
| 4167 are not the same thing, but are very much confused in | |
| 4168 event-stream.c. User events are, essentially, any event that | |
| 4169 should be delayed by accept-process-output, should terminate a | |
| 4170 sit-for, etc. -- basically, any event that needs to be processed | |
| 4171 synchronously with key and mouse events. Command events are | |
| 4172 those that participate in command building; scrollbar events | |
| 4173 clearly don't belong because they should be transparent in a | |
| 4174 sequence like C-x @ h <scrollbar-drag> x, which used to cause a | |
| 4175 crash before checks similar to the is_scrollbar_event() call were | |
| 4176 added. Do other events belong with scrollbar events? I'm not | |
| 4177 sure; we need to categorize all misc-user events and see what | |
| 4178 their semantics are. | |
| 4179 | |
| 4180 (You might ask, why do scrollbar events need to be user events? | |
| 4181 That's a good question. The answer seems to be that they can | |
| 4182 change point, and having this happen asynchronously would be a | |
| 4183 very bad idea. According to the "proper" functioning of | |
| 4184 scrollbars, this should not happen, but XEmacs does not allow | |
| 4185 point to go outside of the window.) | |
| 4186 | |
| 4187 Scrollbar events and similar non-command events should obviously | |
| 4188 not be recorded in this-command-keys, so we need to check for | |
| 4189 this in next-event. | |
| 4190 | |
| 4191 #### We call reset_current_events() twice in this function -- | |
| 4192 #### here, and later as a result of reset_this_command_keys(). | |
| 4193 #### This is almost certainly wrong; need to figure out what's | |
| 4194 #### correct. | |
| 4195 | |
| 4196 #### We need to figure out what's really correct w.r.t. scrollbar | |
| 4197 #### events. With these new fixes in, it actually works to do | |
| 4198 #### C-x <scrollbar-drag> 5 2, but the key echo gets messed up | |
| 4199 #### (starts over at 5). We really need to be special-casing | |
| 4200 #### scrollbar events at a lower level, and not really passing | |
| 4201 #### them through the command builder at all. (e.g. do scrollbar | |
| 4202 #### events belong in macros??? doubtful; probably only the | |
| 4203 #### point movement, if any, belongs, special-cased as a | |
| 4204 #### pseudo-issued M-x goto-char command). #### Need more work | |
| 4205 #### here. Do this when separating out scrollbar events. | |
| 4206 */ | |
| 4207 | |
| 4208 if (!is_scrollbar_event (event)) | |
| 444 | 4209 reset_current_events (command_builder); |
| 428 | 4210 |
| 4211 switch (XEVENT (event)->event_type) | |
| 4212 { | |
| 4213 case key_press_event: | |
| 4214 Vcurrent_mouse_event = Qnil; | |
| 4215 break; | |
| 4216 case button_press_event: | |
| 4217 case button_release_event: | |
| 4218 case misc_user_event: | |
| 4219 Vcurrent_mouse_event = Fcopy_event (event, Qnil); | |
| 4220 break; | |
| 4221 default: break; | |
| 4222 } | |
| 4223 | |
| 4224 /* Store the last-command-event. The semantics of this is that it | |
| 4225 is the last event most recently involved in command-lookup. */ | |
| 4226 if (!EVENTP (Vlast_command_event)) | |
| 4227 Vlast_command_event = Fmake_event (Qnil, Qnil); | |
| 4228 if (XEVENT (Vlast_command_event)->event_type == dead_event) | |
| 4229 { | |
| 4230 Vlast_command_event = Fmake_event (Qnil, Qnil); | |
| 563 | 4231 invalid_state ("Someone deallocated the last-command-event!", Qunbound); |
| 428 | 4232 } |
| 4233 | |
| 4234 if (! EQ (event, Vlast_command_event)) | |
| 4235 Fcopy_event (event, Vlast_command_event); | |
| 4236 | |
| 4237 /* Note that last-command-char will never have its high-bit set, in | |
| 4238 an effort to sidestep the ambiguity between M-x and oslash. */ | |
| 4239 Vlast_command_char = Fevent_to_character (Vlast_command_event, | |
| 2862 | 4240 Qnil, Qnil, Qnil); |
| 428 | 4241 |
| 4242 /* Actually call the command, with all sorts of hair to preserve or clear | |
| 4243 the echo-area and region as appropriate and call the pre- and post- | |
| 4244 command-hooks. */ | |
| 4245 { | |
| 4246 int old_kbd_macro = con->kbd_macro_end; | |
| 4247 struct window *w = XWINDOW (Fselected_window (Qnil)); | |
| 4248 | |
| 4249 /* We're executing a new command, so the old value is irrelevant. */ | |
| 4250 zmacs_region_stays = 0; | |
| 4251 | |
| 4252 /* If the previous command tried to force a specific window-start, | |
| 4253 reset the flag in case this command moves point far away from | |
| 4254 that position. Also, reset the window's buffer's change | |
| 4255 information so that we don't trigger an incremental update. */ | |
| 4256 if (w->force_start) | |
| 4257 { | |
| 4258 w->force_start = 0; | |
| 4259 buffer_reset_changes (XBUFFER (w->buffer)); | |
| 4260 } | |
| 4261 | |
| 4262 pre_command_hook (); | |
| 4263 | |
| 934 | 4264 if (XEVENT_TYPE (event) == misc_user_event) |
| 4265 { | |
| 1204 | 4266 call1 (XEVENT_MISC_USER_FUNCTION (event), |
| 4267 XEVENT_MISC_USER_OBJECT (event)); | |
| 934 | 4268 } |
| 428 | 4269 else |
| 4270 { | |
| 4271 Fcommand_execute (Vthis_command, Qnil, Qnil); | |
| 4272 } | |
| 4273 | |
| 4274 post_command_hook (); | |
| 4275 | |
| 757 | 4276 /* Console might have been deleted by command */ |
| 4277 if (CONSOLE_LIVE_P (con) && !NILP (con->prefix_arg)) | |
| 428 | 4278 { |
| 4279 /* Commands that set the prefix arg don't update last-command, don't | |
| 4280 reset the echoing state, and don't go into keyboard macros unless | |
| 444 | 4281 followed by another command. Also don't quit here. */ |
| 4282 int speccount = specpdl_depth (); | |
| 4283 specbind (Qinhibit_quit, Qt); | |
| 428 | 4284 maybe_echo_keys (command_builder, 0); |
| 771 | 4285 unbind_to (speccount); |
| 428 | 4286 |
| 4287 /* If we're recording a keyboard macro, and the last command | |
| 4288 executed set a prefix argument, then decrement the pointer to | |
| 4289 the "last character really in the macro" to be just before this | |
| 4290 command. This is so that the ^U in "^U ^X )" doesn't go onto | |
| 4291 the end of macro. */ | |
| 4292 if (!NILP (con->defining_kbd_macro)) | |
| 4293 con->kbd_macro_end = old_kbd_macro; | |
| 4294 } | |
| 4295 else | |
| 4296 { | |
| 4297 /* Start a new command next time */ | |
| 4298 Vlast_command = Vthis_command; | |
| 442 | 4299 Vlast_command_properties = Vthis_command_properties; |
| 4300 Vthis_command_properties = Qnil; | |
| 4301 | |
| 428 | 4302 /* Emacs 18 doesn't unconditionally clear the echoed keystrokes, |
| 4303 so we don't either */ | |
| 479 | 4304 |
| 4305 if (!is_scrollbar_event (event)) | |
| 771 | 4306 reset_this_command_keys (CONSOLE_LIVE_P (con) ? wrap_console (con) |
| 757 | 4307 : Qnil, 0); |
| 428 | 4308 } |
| 4309 } | |
| 4310 | |
| 4311 UNGCPRO; | |
| 4312 } | |
| 4313 | |
| 4314 /* Run the pre command hook. */ | |
| 4315 | |
| 4316 static void | |
| 4317 pre_command_hook (void) | |
| 4318 { | |
| 4319 last_point_position = BUF_PT (current_buffer); | |
| 793 | 4320 last_point_position_buffer = wrap_buffer (current_buffer); |
| 428 | 4321 /* This function can GC */ |
| 853 | 4322 safe_run_hook_trapping_problems |
| 1333 | 4323 (Qcommand, Qpre_command_hook, |
| 4324 INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION); | |
| 442 | 4325 |
| 4326 /* This is a kludge, but necessary; see simple.el */ | |
| 4327 call0 (Qhandle_pre_motion_command); | |
| 428 | 4328 } |
| 4329 | |
| 4330 /* Run the post command hook. */ | |
| 4331 | |
| 4332 static void | |
| 4333 post_command_hook (void) | |
| 4334 { | |
| 4335 /* This function can GC */ | |
| 4336 /* Turn off region highlighting unless this command requested that | |
| 4337 it be left on, or we're in the minibuffer. We don't turn it off | |
| 4338 when we're in the minibuffer so that things like M-x write-region | |
| 4339 still work! | |
| 4340 | |
| 4341 This could be done via a function on the post-command-hook, but | |
| 4342 we don't want the user to accidentally remove it. | |
| 4343 */ | |
| 4344 | |
| 4345 Lisp_Object win = Fselected_window (Qnil); | |
| 4346 | |
| 4347 /* If the last command deleted the frame, `win' might be nil. | |
| 4348 It seems safest to do nothing in this case. */ | |
| 442 | 4349 /* Note: Someone added the following comment and put #if 0's around |
| 4350 this code, not realizing that doing this invites a crash in the | |
| 4351 line after. */ | |
| 440 | 4352 /* #### This doesn't really fix the problem, |
| 428 | 4353 if delete-frame is called by some hook */ |
| 4354 if (NILP (win)) | |
| 4355 return; | |
| 442 | 4356 |
| 4357 /* This is a kludge, but necessary; see simple.el */ | |
| 4358 call0 (Qhandle_post_motion_command); | |
| 428 | 4359 |
| 4360 if (! zmacs_region_stays | |
| 4361 && (!MINI_WINDOW_P (XWINDOW (win)) | |
| 4362 || EQ (zmacs_region_buffer (), WINDOW_BUFFER (XWINDOW (win))))) | |
| 4363 zmacs_deactivate_region (); | |
| 4364 else | |
| 4365 zmacs_update_region (); | |
| 4366 | |
| 853 | 4367 safe_run_hook_trapping_problems |
| 1333 | 4368 (Qcommand, Qpost_command_hook, |
|
4718
a27de91ae83c
Don't prevent display objects from being deleted for `post-command-hook'.
Mike Sperber <sperber@deinprogramm.de>
parents:
4677
diff
changeset
|
4369 0); |
| 853 | 4370 |
| 4371 #if 0 /* FSF Emacs */ | |
| 4372 if (!NILP (current_buffer->mark_active)) | |
| 4373 { | |
| 4374 if (!NILP (Vdeactivate_mark) && !NILP (Vtransient_mark_mode)) | |
| 4375 { | |
| 4376 current_buffer->mark_active = Qnil; | |
| 4377 run_hook (intern ("deactivate-mark-hook")); | |
| 4378 } | |
| 4379 else if (current_buffer != prev_buffer || | |
| 4380 BUF_MODIFF (current_buffer) != prev_modiff) | |
| 4381 run_hook (intern ("activate-mark-hook")); | |
| 4382 } | |
| 4383 #endif /* FSF Emacs */ | |
| 428 | 4384 |
| 4385 /* #### Kludge!!! This is necessary to make sure that things | |
| 4386 are properly positioned even if post-command-hook moves point. | |
| 4387 #### There should be a cleaner way of handling this. */ | |
| 4388 call0 (Qauto_show_make_point_visible); | |
| 4389 } | |
| 4390 | |
| 4391 | |
| 4392 DEFUN ("dispatch-event", Fdispatch_event, 1, 1, 0, /* | |
| 444 | 4393 Given an event object EVENT as returned by `next-event', execute it. |
| 428 | 4394 |
| 4395 Key-press, button-press, and button-release events get accumulated | |
| 4396 until a complete key sequence (see `read-key-sequence') is reached, | |
| 4397 at which point the sequence is looked up in the current keymaps and | |
| 4398 acted upon. | |
| 4399 | |
| 4400 Mouse motion events cause the low-level handling function stored in | |
| 4401 `mouse-motion-handler' to be called. (There are very few circumstances | |
| 4402 under which you should change this handler. Use `mode-motion-hook' | |
| 4403 instead.) | |
| 4404 | |
| 4405 Menu, timeout, and eval events cause the associated function or handler | |
| 4406 to be called. | |
| 4407 | |
| 4408 Process events cause the subprocess's output to be read and acted upon | |
| 4409 appropriately (see `start-process'). | |
| 4410 | |
| 4411 Magic events are handled as necessary. | |
| 4412 */ | |
| 4413 (event)) | |
| 4414 { | |
| 4415 /* This function can GC */ | |
| 4416 struct command_builder *command_builder; | |
| 440 | 4417 Lisp_Event *ev; |
| 428 | 4418 Lisp_Object console; |
| 4419 Lisp_Object channel; | |
| 1292 | 4420 PROFILE_DECLARE (); |
| 428 | 4421 |
| 4422 CHECK_LIVE_EVENT (event); | |
| 4423 ev = XEVENT (event); | |
| 4424 | |
| 4425 /* events on dead channels get silently eaten */ | |
| 4426 channel = EVENT_CHANNEL (ev); | |
| 4427 if (object_dead_p (channel)) | |
| 4428 return Qnil; | |
| 4429 | |
| 1292 | 4430 PROFILE_RECORD_ENTERING_SECTION (Qdispatch_event); |
| 4431 | |
| 428 | 4432 /* Some events don't have channels (e.g. eval events). */ |
| 4433 console = CDFW_CONSOLE (channel); | |
| 4434 if (NILP (console)) | |
| 4435 console = Vselected_console; | |
| 4436 else if (!EQ (console, Vselected_console)) | |
| 4437 Fselect_console (console); | |
| 4438 | |
| 4439 command_builder = XCOMMAND_BUILDER (XCONSOLE (console)->command_builder); | |
| 934 | 4440 switch (XEVENT_TYPE (event)) |
| 428 | 4441 { |
| 4442 case button_press_event: | |
| 4443 case button_release_event: | |
| 4444 case key_press_event: | |
| 4445 { | |
| 4446 Lisp_Object leaf = lookup_command_event (command_builder, event, 1); | |
| 4447 | |
| 4448 if (KEYMAPP (leaf)) | |
| 4449 /* Incomplete key sequence */ | |
| 4450 break; | |
| 4451 if (NILP (leaf)) | |
| 4452 { | |
| 4453 /* At this point, we know that the sequence is not bound to a | |
| 4454 command. Normally, we beep and print a message informing the | |
| 4455 user of this. But we do not beep or print a message when: | |
| 4456 | |
| 4457 o the last event in this sequence is a mouse-up event; or | |
| 4458 o the last event in this sequence is a mouse-down event and | |
| 4459 there is a binding for the mouse-up version. | |
| 4460 | |
| 4461 That is, if the sequence ``C-x button1'' is typed, and is not | |
| 4462 bound to a command, but the sequence ``C-x button1up'' is bound | |
| 4463 to a command, we do not complain about the ``C-x button1'' | |
| 4464 sequence. If neither ``C-x button1'' nor ``C-x button1up'' is | |
| 4465 bound to a command, then we complain about the ``C-x button1'' | |
| 4466 sequence, but later will *not* complain about the | |
| 4467 ``C-x button1up'' sequence, which would be redundant. | |
| 4468 | |
| 4469 This is pretty hairy, but I think it's the most intuitive | |
| 4470 behavior. | |
| 4471 */ | |
| 4472 Lisp_Object terminal = command_builder->most_current_event; | |
| 4473 | |
| 4474 if (XEVENT_TYPE (terminal) == button_press_event) | |
| 4475 { | |
| 4476 int no_bitching; | |
| 4477 /* Temporarily pretend the last event was an "up" instead of a | |
| 4478 "down", and look up its binding. */ | |
| 4479 XEVENT_TYPE (terminal) = button_release_event; | |
| 4480 /* If the "up" version is bound, don't complain. */ | |
| 4481 no_bitching | |
| 771 | 4482 = !NILP (command_builder_find_leaf_and_update_global_state |
| 4483 (command_builder, 0)); | |
| 428 | 4484 /* Undo the temporary changes we just made. */ |
| 4485 XEVENT_TYPE (terminal) = button_press_event; | |
| 4486 if (no_bitching) | |
| 4487 { | |
| 4488 /* Pretend this press was not seen (treat as a prefix) */ | |
| 4489 if (EQ (command_builder->current_events, terminal)) | |
| 4490 { | |
| 4491 reset_current_events (command_builder); | |
| 4492 } | |
| 4493 else | |
| 4494 { | |
| 4495 Lisp_Object eve; | |
| 4496 | |
| 4497 EVENT_CHAIN_LOOP (eve, command_builder->current_events) | |
| 4498 if (EQ (XEVENT_NEXT (eve), terminal)) | |
| 4499 break; | |
| 4500 | |
| 4501 Fdeallocate_event (command_builder-> | |
| 4502 most_current_event); | |
| 4503 XSET_EVENT_NEXT (eve, Qnil); | |
| 4504 command_builder->most_current_event = eve; | |
| 4505 } | |
| 4506 maybe_echo_keys (command_builder, 1); | |
| 4507 break; | |
| 4508 } | |
| 4509 } | |
| 4510 | |
| 4511 /* Complain that the typed sequence is not defined, if this is the | |
| 4512 kind of sequence that warrants a complaint. */ | |
| 4513 XCONSOLE (console)->defining_kbd_macro = Qnil; | |
| 4514 XCONSOLE (console)->prefix_arg = Qnil; | |
| 4515 /* Don't complain about undefined button-release events */ | |
| 4516 if (XEVENT_TYPE (terminal) != button_release_event) | |
| 4517 { | |
| 4518 Lisp_Object keys = current_events_into_vector (command_builder); | |
| 4519 struct gcpro gcpro1; | |
| 4520 | |
| 4521 /* Run the pre-command-hook before barfing about an undefined | |
| 4522 key. */ | |
| 4523 Vthis_command = Qnil; | |
| 4524 GCPRO1 (keys); | |
| 4525 pre_command_hook (); | |
| 4526 UNGCPRO; | |
| 4527 /* The post-command-hook doesn't run. */ | |
| 4528 Fsignal (Qundefined_keystroke_sequence, list1 (keys)); | |
| 4529 } | |
| 4530 /* Reset the command builder for reading the next sequence. */ | |
| 4531 reset_this_command_keys (console, 1); | |
| 4532 } | |
| 4533 else /* key sequence is bound to a command */ | |
| 4534 { | |
| 430 | 4535 int magic_undo = 0; |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
4536 Elemcount magic_undo_count = 20; |
| 430 | 4537 |
| 428 | 4538 Vthis_command = leaf; |
| 430 | 4539 |
| 428 | 4540 /* Don't push an undo boundary if the command set the prefix arg, |
| 4541 or if we are executing a keyboard macro, or if in the | |
| 4542 minibuffer. If the command we are about to execute is | |
| 4543 self-insert, it's tricky: up to 20 consecutive self-inserts may | |
| 4544 be done without an undo boundary. This counter is reset as | |
| 4545 soon as a command other than self-insert-command is executed. | |
| 430 | 4546 |
| 442 | 4547 Programmers can also use the `self-insert-defer-undo' |
| 4548 property to install that behavior on functions other | |
| 430 | 4549 than `self-insert-command', or to change the magic |
| 442 | 4550 number 20 to something else. #### DOCUMENT THIS! */ |
| 430 | 4551 |
| 4552 if (SYMBOLP (leaf)) | |
| 4553 { | |
| 4554 Lisp_Object prop = Fget (leaf, Qself_insert_defer_undo, Qnil); | |
| 4555 if (NATNUMP (prop)) | |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
4556 { |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
4557 magic_undo = 1; |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
4558 if (INTP (prop)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
4559 { |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
4560 magic_undo_count = XINT (prop); |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
4561 } |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
4562 #ifdef HAVE_BIGNUM |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
4563 else if (BIGNUMP (prop) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
4564 && bignum_fits_emacs_int_p (XBIGNUM_DATA (prop))) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
4565 { |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
4566 magic_undo_count |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
4567 = bignum_to_emacs_int (XBIGNUM_DATA (prop)); |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
4568 } |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
4569 #endif |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
4570 } |
| 430 | 4571 else if (!NILP (prop)) |
| 4572 magic_undo = 1; | |
| 4573 else if (EQ (leaf, Qself_insert_command)) | |
| 4574 magic_undo = 1; | |
| 4575 } | |
| 4576 | |
| 4577 if (!magic_undo) | |
| 428 | 4578 command_builder->self_insert_countdown = 0; |
| 4579 if (NILP (XCONSOLE (console)->prefix_arg) | |
| 4580 && NILP (Vexecuting_macro) | |
| 4581 && command_builder->self_insert_countdown == 0) | |
| 4582 Fundo_boundary (); | |
| 4583 | |
| 430 | 4584 if (magic_undo) |
| 428 | 4585 { |
| 4586 if (--command_builder->self_insert_countdown < 0) | |
| 430 | 4587 command_builder->self_insert_countdown = magic_undo_count; |
| 428 | 4588 } |
| 4589 execute_command_event | |
| 4590 (command_builder, | |
| 444 | 4591 internal_equal (event, command_builder->most_current_event, 0) |
| 428 | 4592 ? event |
| 4593 /* Use the translated event that was most recently seen. | |
| 4594 This way, last-command-event becomes f1 instead of | |
| 4595 the P from ESC O P. But we must copy it, else we'll | |
| 4596 lose when the command-builder events are deallocated. */ | |
| 444 | 4597 : Fcopy_event (command_builder->most_current_event, Qnil)); |
| 428 | 4598 } |
| 4599 break; | |
| 4600 } | |
| 4601 case misc_user_event: | |
| 4602 { | |
| 4603 /* Jamie said: | |
| 4604 | |
| 4605 We could just always use the menu item entry, whatever it is, but | |
| 4606 this might break some Lisp code that expects `this-command' to | |
| 4607 always contain a symbol. So only store it if this is a simple | |
| 4608 `call-interactively' sort of menu item. | |
| 4609 | |
| 4610 But this is bogus. `this-command' could be a string or vector | |
| 4611 anyway (for keyboard macros). There's even one instance | |
| 4612 (in pending-del.el) of `this-command' getting set to a cons | |
| 4613 (a lambda expression). So in the `eval' case I'll just | |
| 4614 convert it into a lambda expression. | |
| 4615 */ | |
| 1204 | 4616 if (EQ (XEVENT_MISC_USER_FUNCTION (event), Qcall_interactively) |
| 4617 && SYMBOLP (XEVENT_MISC_USER_OBJECT (event))) | |
| 4618 Vthis_command = XEVENT_MISC_USER_OBJECT (event); | |
| 4619 else if (EQ (XEVENT_MISC_USER_FUNCTION (event), Qeval)) | |
| 934 | 4620 Vthis_command = |
| 1204 | 4621 Fcons (Qlambda, Fcons (Qnil, XEVENT_MISC_USER_OBJECT (event))); |
| 4622 else if (SYMBOLP (XEVENT_MISC_USER_FUNCTION (event))) | |
| 934 | 4623 /* A scrollbar command or the like. */ |
| 1204 | 4624 Vthis_command = XEVENT_MISC_USER_FUNCTION (event); |
| 428 | 4625 else |
| 4626 /* Huh? */ | |
| 4627 Vthis_command = Qnil; | |
| 4628 | |
| 4629 /* clear the echo area */ | |
| 4630 reset_key_echo (command_builder, 1); | |
| 4631 | |
| 4632 command_builder->self_insert_countdown = 0; | |
| 4633 if (NILP (XCONSOLE (console)->prefix_arg) | |
| 4634 && NILP (Vexecuting_macro) | |
| 4635 && !EQ (minibuf_window, Fselected_window (Qnil))) | |
| 4636 Fundo_boundary (); | |
| 4637 execute_command_event (command_builder, event); | |
| 4638 break; | |
| 4639 } | |
| 4640 default: | |
| 4641 execute_internal_event (event); | |
| 4642 break; | |
| 4643 } | |
| 1292 | 4644 |
| 4645 PROFILE_RECORD_EXITING_SECTION (Qdispatch_event); | |
| 428 | 4646 return Qnil; |
| 4647 } | |
| 4648 | |
| 4649 DEFUN ("read-key-sequence", Fread_key_sequence, 1, 3, 0, /* | |
| 4650 Read a sequence of keystrokes or mouse clicks. | |
| 4651 Returns a vector of the event objects read. The vector and the event | |
| 444 | 4652 objects it contains are freshly created (and so will not be side-effected |
| 428 | 4653 by subsequent calls to this function). |
| 4654 | |
| 4655 The sequence read is sufficient to specify a non-prefix command starting | |
| 4656 from the current local and global keymaps. A C-g typed while in this | |
| 4657 function is treated like any other character, and `quit-flag' is not set. | |
| 4658 | |
| 4659 First arg PROMPT is a prompt string. If nil, do not prompt specially. | |
| 444 | 4660 |
| 4661 Second optional arg CONTINUE-ECHO non-nil means this key echoes as a | |
| 4662 continuation of the previous key. | |
| 4663 | |
| 4664 Third optional arg DONT-DOWNCASE-LAST non-nil means do not convert the | |
| 4665 last event to lower case. (Normally any upper case event is converted | |
| 4666 to lower case if the original event is undefined and the lower case | |
| 4667 equivalent is defined.) This argument is provided mostly for FSF | |
| 4668 compatibility; the equivalent effect can be achieved more generally by | |
| 4669 binding `retry-undefined-key-binding-unshifted' to nil around the call | |
| 4670 to `read-key-sequence'. | |
| 428 | 4671 |
| 4672 If the user selects a menu item while we are prompting for a key-sequence, | |
| 4673 the returned value will be a vector of a single menu-selection event. | |
| 4674 An error will be signalled if you pass this value to `lookup-key' or a | |
| 4675 related function. | |
| 4676 | |
| 4677 `read-key-sequence' checks `function-key-map' for function key | |
| 444 | 4678 sequences, where they wouldn't conflict with ordinary bindings. |
| 4679 See `function-key-map' for more details. | |
| 428 | 4680 */ |
| 4681 (prompt, continue_echo, dont_downcase_last)) | |
| 4682 { | |
| 4683 /* This function can GC */ | |
| 4684 struct console *con = XCONSOLE (Vselected_console); /* #### correct? | |
| 4685 Probably not -- see | |
| 4686 comment in | |
| 4687 next-event */ | |
| 4688 struct command_builder *command_builder = | |
| 4689 XCOMMAND_BUILDER (con->command_builder); | |
| 4690 Lisp_Object result; | |
| 4691 Lisp_Object event = Fmake_event (Qnil, Qnil); | |
| 4692 int speccount = specpdl_depth (); | |
| 4693 struct gcpro gcpro1; | |
| 4694 GCPRO1 (event); | |
| 4695 | |
| 707 | 4696 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); |
| 428 | 4697 if (!NILP (prompt)) |
| 4698 CHECK_STRING (prompt); | |
| 4699 /* else prompt = Fkeymap_prompt (current_buffer->keymap); may GC */ | |
| 4700 QUIT; | |
| 4701 | |
| 4702 if (NILP (continue_echo)) | |
| 771 | 4703 reset_this_command_keys (wrap_console (con), 1); |
| 428 | 4704 |
| 4705 if (!NILP (dont_downcase_last)) | |
| 4706 specbind (Qretry_undefined_key_binding_unshifted, Qnil); | |
| 4707 | |
| 4708 for (;;) | |
| 4709 { | |
| 4710 Fnext_event (event, prompt); | |
| 4711 /* restore the selected-console damage */ | |
| 4712 con = event_console_or_selected (event); | |
| 4713 command_builder = XCOMMAND_BUILDER (con->command_builder); | |
| 4714 if (! command_event_p (event)) | |
| 4715 execute_internal_event (event); | |
| 4716 else | |
| 4717 { | |
| 934 | 4718 if (XEVENT_TYPE (event) == misc_user_event) |
| 428 | 4719 reset_current_events (command_builder); |
| 4720 result = lookup_command_event (command_builder, event, 1); | |
| 4721 if (!KEYMAPP (result)) | |
| 4722 { | |
| 4723 result = current_events_into_vector (command_builder); | |
| 4724 reset_key_echo (command_builder, 0); | |
| 4725 break; | |
| 4726 } | |
| 4727 prompt = Qnil; | |
| 4728 } | |
| 4729 } | |
| 4730 | |
| 4731 Fdeallocate_event (event); | |
| 771 | 4732 RETURN_UNGCPRO (unbind_to_1 (speccount, result)); |
| 428 | 4733 } |
| 4734 | |
| 4735 DEFUN ("this-command-keys", Fthis_command_keys, 0, 0, 0, /* | |
| 4736 Return a vector of the keyboard or mouse button events that were used | |
| 4737 to invoke this command. This copies the vector and the events; it is safe | |
| 4738 to keep and modify them. | |
| 4739 */ | |
| 4740 ()) | |
| 4741 { | |
| 4742 Lisp_Object event; | |
| 4743 Lisp_Object result; | |
| 4744 int len; | |
| 4745 | |
| 4746 if (NILP (Vthis_command_keys)) | |
| 4747 return make_vector (0, Qnil); | |
| 4748 | |
| 4749 len = event_chain_count (Vthis_command_keys); | |
| 4750 | |
| 4751 result = make_vector (len, Qnil); | |
| 4752 len = 0; | |
| 4753 EVENT_CHAIN_LOOP (event, Vthis_command_keys) | |
| 4754 XVECTOR_DATA (result)[len++] = Fcopy_event (event, Qnil); | |
| 4755 return result; | |
| 4756 } | |
| 4757 | |
| 4758 DEFUN ("reset-this-command-lengths", Freset_this_command_lengths, 0, 0, 0, /* | |
| 4759 Used for complicated reasons in `universal-argument-other-key'. | |
| 4760 | |
| 4761 `universal-argument-other-key' rereads the event just typed. | |
| 4762 It then gets translated through `function-key-map'. | |
| 4763 The translated event gets included in the echo area and in | |
| 4764 the value of `this-command-keys' in addition to the raw original event. | |
| 4765 That is not right. | |
| 4766 | |
| 4767 Calling this function directs the translated event to replace | |
| 4768 the original event, so that only one version of the event actually | |
| 430 | 4769 appears in the echo area and in the value of `this-command-keys'. |
| 428 | 4770 */ |
| 4771 ()) | |
| 4772 { | |
| 4773 /* #### I don't understand this at all, so currently it does nothing. | |
| 4774 If there is ever a problem, maybe someone should investigate. */ | |
| 4775 return Qnil; | |
| 4776 } | |
| 4777 | |
| 4778 | |
| 4779 static void | |
| 4780 dribble_out_event (Lisp_Object event) | |
| 4781 { | |
| 4782 if (NILP (Vdribble_file)) | |
| 4783 return; | |
| 4784 | |
| 934 | 4785 if (XEVENT_TYPE (event) == key_press_event && |
| 1204 | 4786 !XEVENT_KEY_MODIFIERS (event)) |
| 934 | 4787 { |
| 1204 | 4788 Lisp_Object keysym = XEVENT_KEY_KEYSYM (event); |
| 4789 if (CHARP (XEVENT_KEY_KEYSYM (event))) | |
| 428 | 4790 { |
| 867 | 4791 Ichar ch = XCHAR (keysym); |
| 4792 Ibyte str[MAX_ICHAR_LEN]; | |
| 4793 Bytecount len = set_itext_ichar (str, ch); | |
| 428 | 4794 Lstream_write (XLSTREAM (Vdribble_file), str, len); |
| 4795 } | |
| 826 | 4796 else if (string_char_length (XSYMBOL (keysym)->name) == 1) |
| 428 | 4797 /* one-char key events are printed with just the key name */ |
| 4798 Fprinc (keysym, Vdribble_file); | |
| 4799 else if (EQ (keysym, Qreturn)) | |
| 4800 Lstream_putc (XLSTREAM (Vdribble_file), '\n'); | |
| 4801 else if (EQ (keysym, Qspace)) | |
| 4802 Lstream_putc (XLSTREAM (Vdribble_file), ' '); | |
| 4803 else | |
| 4804 Fprinc (event, Vdribble_file); | |
| 4805 } | |
| 4806 else | |
| 4807 Fprinc (event, Vdribble_file); | |
| 4808 Lstream_flush (XLSTREAM (Vdribble_file)); | |
| 4809 } | |
| 4810 | |
| 4811 DEFUN ("open-dribble-file", Fopen_dribble_file, 1, 1, | |
| 4812 "FOpen dribble file: ", /* | |
| 444 | 4813 Start writing all keyboard characters to a dribble file called FILENAME. |
| 4814 If FILENAME is nil, close any open dribble file. | |
| 428 | 4815 */ |
| 444 | 4816 (filename)) |
| 428 | 4817 { |
| 4818 /* This function can GC */ | |
| 4819 /* XEmacs change: always close existing dribble file. */ | |
| 4820 /* FSFmacs uses FILE *'s here. With lstreams, that's unnecessary. */ | |
| 4821 if (!NILP (Vdribble_file)) | |
| 4822 { | |
| 4823 Lstream_close (XLSTREAM (Vdribble_file)); | |
| 4824 Vdribble_file = Qnil; | |
| 4825 } | |
| 444 | 4826 if (!NILP (filename)) |
| 428 | 4827 { |
| 4828 int fd; | |
| 4829 | |
| 444 | 4830 filename = Fexpand_file_name (filename, Qnil); |
| 771 | 4831 fd = qxe_open (XSTRING_DATA (filename), |
| 4832 O_WRONLY | O_TRUNC | O_CREAT | OPEN_BINARY, | |
| 4833 CREAT_MODE); | |
| 428 | 4834 if (fd < 0) |
| 563 | 4835 report_file_error ("Unable to create dribble file", filename); |
| 428 | 4836 Vdribble_file = make_filedesc_output_stream (fd, 0, 0, LSTR_CLOSING); |
| 4837 #ifdef MULE | |
| 4838 Vdribble_file = | |
| 771 | 4839 make_coding_output_stream |
| 4840 (XLSTREAM (Vdribble_file), | |
| 800 | 4841 Qescape_quoted, CODING_ENCODE, 0); |
| 428 | 4842 #endif |
| 4843 } | |
| 4844 return Qnil; | |
| 4845 } | |
| 4846 | |
| 4847 | |
| 442 | 4848 |
| 4849 DEFUN ("current-event-timestamp", Fcurrent_event_timestamp, 0, 1, 0, /* | |
| 4850 Return the current event timestamp of the window system associated with CONSOLE. | |
| 4851 CONSOLE defaults to the selected console if omitted. | |
| 4852 */ | |
| 4853 (console)) | |
| 4854 { | |
| 4855 struct console *c = decode_console (console); | |
| 4856 int tiempo = event_stream_current_event_timestamp (c); | |
| 4857 | |
| 4858 /* This junk is so that timestamps don't get to be negative, but contain | |
| 4859 as many bits as this particular emacs will allow. | |
| 4860 */ | |
| 2039 | 4861 return make_int (EMACS_INT_MAX & tiempo); |
| 442 | 4862 } |
| 4863 | |
| 4864 | |
| 428 | 4865 /************************************************************************/ |
| 4866 /* initialization */ | |
| 4867 /************************************************************************/ | |
| 4868 | |
| 4869 void | |
| 4870 syms_of_event_stream (void) | |
| 4871 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
4872 INIT_LISP_OBJECT (command_builder); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
4873 INIT_LISP_OBJECT (timeout); |
| 442 | 4874 |
| 563 | 4875 DEFSYMBOL (Qdisabled); |
| 4876 DEFSYMBOL (Qcommand_event_p); | |
| 4877 | |
| 4878 DEFERROR_STANDARD (Qundefined_keystroke_sequence, Qsyntax_error); | |
| 4879 DEFERROR_STANDARD (Qinvalid_key_binding, Qinvalid_state); | |
| 428 | 4880 |
| 4881 DEFSUBR (Frecent_keys); | |
| 4882 DEFSUBR (Frecent_keys_ring_size); | |
| 4883 DEFSUBR (Fset_recent_keys_ring_size); | |
| 4884 DEFSUBR (Finput_pending_p); | |
| 4885 DEFSUBR (Fenqueue_eval_event); | |
| 4886 DEFSUBR (Fnext_event); | |
| 4887 DEFSUBR (Fnext_command_event); | |
| 4888 DEFSUBR (Fdiscard_input); | |
| 4889 DEFSUBR (Fsit_for); | |
| 4890 DEFSUBR (Fsleep_for); | |
| 4891 DEFSUBR (Faccept_process_output); | |
| 4892 DEFSUBR (Fadd_timeout); | |
| 4893 DEFSUBR (Fdisable_timeout); | |
| 4894 DEFSUBR (Fadd_async_timeout); | |
| 4895 DEFSUBR (Fdisable_async_timeout); | |
| 4896 DEFSUBR (Fdispatch_event); | |
| 442 | 4897 DEFSUBR (Fdispatch_non_command_events); |
| 428 | 4898 DEFSUBR (Fread_key_sequence); |
| 4899 DEFSUBR (Fthis_command_keys); | |
| 4900 DEFSUBR (Freset_this_command_lengths); | |
| 4901 DEFSUBR (Fopen_dribble_file); | |
| 442 | 4902 DEFSUBR (Fcurrent_event_timestamp); |
| 428 | 4903 |
| 563 | 4904 DEFSYMBOL (Qpre_command_hook); |
| 4905 DEFSYMBOL (Qpost_command_hook); | |
| 4906 DEFSYMBOL (Qunread_command_events); | |
| 4907 DEFSYMBOL (Qunread_command_event); | |
| 4908 DEFSYMBOL (Qpre_idle_hook); | |
| 4909 DEFSYMBOL (Qhandle_pre_motion_command); | |
| 4910 DEFSYMBOL (Qhandle_post_motion_command); | |
| 4911 DEFSYMBOL (Qretry_undefined_key_binding_unshifted); | |
| 4912 DEFSYMBOL (Qauto_show_make_point_visible); | |
| 4913 | |
| 4914 DEFSYMBOL (Qself_insert_defer_undo); | |
| 4915 DEFSYMBOL (Qcancel_mode_internal); | |
| 1292 | 4916 |
| 4917 DEFSYMBOL (Qnext_event); | |
| 4918 DEFSYMBOL (Qdispatch_event); | |
|
5139
a48ef26d87ee
Clean up prototypes for Lisp variables/symbols. Put decls for them with
Ben Wing <ben@xemacs.org>
parents:
5050
diff
changeset
|
4919 |
|
a48ef26d87ee
Clean up prototypes for Lisp variables/symbols. Put decls for them with
Ben Wing <ben@xemacs.org>
parents:
5050
diff
changeset
|
4920 DEFSYMBOL (Qsans_modifiers); |
| 428 | 4921 } |
| 4922 | |
| 4923 void | |
| 4924 reinit_vars_of_event_stream (void) | |
| 4925 { | |
| 4926 recent_keys_ring_index = 0; | |
| 4927 recent_keys_ring_size = 100; | |
| 4928 num_input_chars = 0; | |
| 4929 the_low_level_timeout_blocktype = | |
| 4930 Blocktype_new (struct low_level_timeout_blocktype); | |
| 4931 something_happened = 0; | |
| 1268 | 4932 recursive_sit_for = 0; |
| 4933 in_modal_loop = 0; | |
| 428 | 4934 } |
| 4935 | |
| 4936 void | |
| 4937 vars_of_event_stream (void) | |
| 4938 { | |
| 4939 Vrecent_keys_ring = Qnil; | |
| 4940 staticpro (&Vrecent_keys_ring); | |
| 4941 | |
| 4942 Vthis_command_keys = Qnil; | |
| 4943 staticpro (&Vthis_command_keys); | |
| 4944 Vthis_command_keys_tail = Qnil; | |
| 1204 | 4945 dump_add_root_lisp_object (&Vthis_command_keys_tail); |
| 428 | 4946 |
| 4947 command_event_queue = Qnil; | |
| 4948 staticpro (&command_event_queue); | |
| 4949 command_event_queue_tail = Qnil; | |
| 1204 | 4950 dump_add_root_lisp_object (&command_event_queue_tail); |
| 4951 | |
| 4952 dispatch_event_queue = Qnil; | |
| 4953 staticpro (&dispatch_event_queue); | |
| 4954 dispatch_event_queue_tail = Qnil; | |
| 4955 dump_add_root_lisp_object (&dispatch_event_queue_tail); | |
| 428 | 4956 |
| 4957 Vlast_selected_frame = Qnil; | |
| 4958 staticpro (&Vlast_selected_frame); | |
| 4959 | |
| 4960 pending_timeout_list = Qnil; | |
| 4961 staticpro (&pending_timeout_list); | |
| 4962 | |
| 4963 pending_async_timeout_list = Qnil; | |
| 4964 staticpro (&pending_async_timeout_list); | |
| 4965 | |
| 4966 last_point_position_buffer = Qnil; | |
| 4967 staticpro (&last_point_position_buffer); | |
| 4968 | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
4969 QSnext_event_internal = build_ascstring ("next_event_internal()"); |
| 1292 | 4970 staticpro (&QSnext_event_internal); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
4971 QSexecute_internal_event = build_ascstring ("execute_internal_event()"); |
| 1292 | 4972 staticpro (&QSexecute_internal_event); |
| 4973 | |
| 428 | 4974 DEFVAR_LISP ("echo-keystrokes", &Vecho_keystrokes /* |
| 4975 *Nonzero means echo unfinished commands after this many seconds of pause. | |
| 4976 */ ); | |
| 4977 Vecho_keystrokes = make_int (1); | |
| 4978 | |
| 4979 DEFVAR_INT ("auto-save-interval", &auto_save_interval /* | |
| 4980 *Number of keyboard input characters between auto-saves. | |
| 4981 Zero means disable autosaving due to number of characters typed. | |
| 4982 See also the variable `auto-save-timeout'. | |
| 4983 */ ); | |
| 4984 auto_save_interval = 300; | |
| 4985 | |
| 4986 DEFVAR_LISP ("pre-command-hook", &Vpre_command_hook /* | |
| 4987 Function or functions to run before every command. | |
| 4988 This may examine the `this-command' variable to find out what command | |
| 4989 is about to be run, or may change it to cause a different command to run. | |
| 853 | 4990 Errors while running the hook are caught and turned into warnings. |
| 428 | 4991 */ ); |
| 4992 Vpre_command_hook = Qnil; | |
| 4993 | |
| 4994 DEFVAR_LISP ("post-command-hook", &Vpost_command_hook /* | |
| 4995 Function or functions to run after every command. | |
| 4996 This may examine the `this-command' variable to find out what command | |
| 4997 was just executed. | |
| 4998 */ ); | |
| 4999 Vpost_command_hook = Qnil; | |
| 5000 | |
| 5001 DEFVAR_LISP ("pre-idle-hook", &Vpre_idle_hook /* | |
| 5002 Normal hook run when XEmacs it about to be idle. | |
| 5003 This occurs whenever it is going to block, waiting for an event. | |
| 5004 This generally happens as a result of a call to `next-event', | |
| 5005 `next-command-event', `sit-for', `sleep-for', `accept-process-output', | |
| 853 | 5006 or `get-selection'. Errors while running the hook are caught and |
| 5007 turned into warnings. | |
| 428 | 5008 */ ); |
| 5009 Vpre_idle_hook = Qnil; | |
| 5010 | |
| 5011 DEFVAR_BOOL ("focus-follows-mouse", &focus_follows_mouse /* | |
| 5012 *Variable to control XEmacs behavior with respect to focus changing. | |
| 5013 If this variable is set to t, then XEmacs will not gratuitously change | |
| 5014 the keyboard focus. XEmacs cannot in general detect when this mode is | |
| 5015 used by the window manager, so it is up to the user to set it. | |
| 5016 */ ); | |
| 5017 focus_follows_mouse = 0; | |
| 5018 | |
| 5019 DEFVAR_LISP ("last-command-event", &Vlast_command_event /* | |
| 5020 Last keyboard or mouse button event that was part of a command. This | |
| 5021 variable is off limits: you may not set its value or modify the event that | |
| 5022 is its value, as it is destructively modified by `read-key-sequence'. If | |
| 5023 you want to keep a pointer to this value, you must use `copy-event'. | |
| 5024 */ ); | |
| 5025 Vlast_command_event = Qnil; | |
| 5026 | |
| 5027 DEFVAR_LISP ("last-command-char", &Vlast_command_char /* | |
| 5028 If the value of `last-command-event' is a keyboard event, then | |
| 5029 this is the nearest ASCII equivalent to it. This is the value that | |
| 5030 `self-insert-command' will put in the buffer. Remember that there is | |
| 5031 NOT a 1:1 mapping between keyboard events and ASCII characters: the set | |
| 5032 of keyboard events is much larger, so writing code that examines this | |
| 5033 variable to determine what key has been typed is bad practice, unless | |
| 5034 you are certain that it will be one of a small set of characters. | |
| 5035 */ ); | |
| 5036 Vlast_command_char = Qnil; | |
| 5037 | |
| 5038 DEFVAR_LISP ("last-input-event", &Vlast_input_event /* | |
| 5039 Last keyboard or mouse button event received. This variable is off | |
| 5040 limits: you may not set its value or modify the event that is its value, as | |
| 5041 it is destructively modified by `next-event'. If you want to keep a pointer | |
| 5042 to this value, you must use `copy-event'. | |
| 5043 */ ); | |
| 5044 Vlast_input_event = Qnil; | |
| 5045 | |
| 5046 DEFVAR_LISP ("current-mouse-event", &Vcurrent_mouse_event /* | |
| 5047 The mouse-button event which invoked this command, or nil. | |
| 5048 This is usually what `(interactive "e")' returns. | |
| 5049 */ ); | |
| 5050 Vcurrent_mouse_event = Qnil; | |
| 5051 | |
| 5052 DEFVAR_LISP ("last-input-char", &Vlast_input_char /* | |
| 5053 If the value of `last-input-event' is a keyboard event, then | |
| 5054 this is the nearest ASCII equivalent to it. Remember that there is | |
| 5055 NOT a 1:1 mapping between keyboard events and ASCII characters: the set | |
| 5056 of keyboard events is much larger, so writing code that examines this | |
| 5057 variable to determine what key has been typed is bad practice, unless | |
| 5058 you are certain that it will be one of a small set of characters. | |
| 5059 */ ); | |
| 5060 Vlast_input_char = Qnil; | |
| 5061 | |
| 5062 DEFVAR_LISP ("last-input-time", &Vlast_input_time /* | |
| 5063 The time (in seconds since Jan 1, 1970) of the last-command-event, | |
| 5064 represented as a cons of two 16-bit integers. This is destructively | |
| 5065 modified, so copy it if you want to keep it. | |
| 5066 */ ); | |
| 5067 Vlast_input_time = Qnil; | |
| 5068 | |
| 5069 DEFVAR_LISP ("last-command-event-time", &Vlast_command_event_time /* | |
| 5070 The time (in seconds since Jan 1, 1970) of the last-command-event, | |
| 5071 represented as a list of three integers. The first integer contains | |
| 5072 the most significant 16 bits of the number of seconds, and the second | |
| 5073 integer contains the least significant 16 bits. The third integer | |
| 5074 contains the remainder number of microseconds, if the current system | |
| 5075 supports microsecond clock resolution. This list is destructively | |
| 5076 modified, so copy it if you want to keep it. | |
| 5077 */ ); | |
| 5078 Vlast_command_event_time = Qnil; | |
| 5079 | |
| 5080 DEFVAR_LISP ("unread-command-events", &Vunread_command_events /* | |
| 5081 List of event objects to be read as next command input events. | |
| 5082 This can be used to simulate the receipt of events from the user. | |
| 5083 Normally this is nil. | |
| 5084 Events are removed from the front of this list. | |
| 5085 */ ); | |
| 5086 Vunread_command_events = Qnil; | |
| 5087 | |
| 5088 DEFVAR_LISP ("unread-command-event", &Vunread_command_event /* | |
| 5089 Obsolete. Use `unread-command-events' instead. | |
| 5090 */ ); | |
| 5091 Vunread_command_event = Qnil; | |
| 5092 | |
| 5093 DEFVAR_LISP ("last-command", &Vlast_command /* | |
| 5094 The last command executed. Normally a symbol with a function definition, | |
| 5095 but can be whatever was found in the keymap, or whatever the variable | |
| 5096 `this-command' was set to by that command. | |
| 5097 */ ); | |
| 5098 Vlast_command = Qnil; | |
| 5099 | |
| 5100 DEFVAR_LISP ("this-command", &Vthis_command /* | |
| 5101 The command now being executed. | |
| 5102 The command can set this variable; whatever is put here | |
| 5103 will be in `last-command' during the following command. | |
| 5104 */ ); | |
| 5105 Vthis_command = Qnil; | |
| 5106 | |
| 442 | 5107 DEFVAR_LISP ("last-command-properties", &Vlast_command_properties /* |
| 5108 Value of `this-command-properties' for the last command. | |
| 5109 Used by commands to help synchronize consecutive commands, in preference | |
| 5110 to looking at `last-command' directly. | |
| 5111 */ ); | |
| 5112 Vlast_command_properties = Qnil; | |
| 5113 | |
| 5114 DEFVAR_LISP ("this-command-properties", &Vthis_command_properties /* | |
| 5115 Properties set by the current command. | |
| 5116 At the beginning of each command, the current value of this variable is | |
| 5117 copied to `last-command-properties', and then it is set to nil. Use `putf' | |
| 5118 to add properties to this variable. Commands should use this to communicate | |
| 5119 with pre/post-command hooks, subsequent commands, wrapping commands, etc. | |
| 5120 in preference to looking at and/or setting `this-command'. | |
| 5121 */ ); | |
| 5122 Vthis_command_properties = Qnil; | |
| 5123 | |
| 428 | 5124 DEFVAR_LISP ("help-char", &Vhelp_char /* |
| 5125 Character to recognize as meaning Help. | |
| 5126 When it is read, do `(eval help-form)', and display result if it's a string. | |
| 5127 If the value of `help-form' is nil, this char can be read normally. | |
| 5128 This can be any form recognized as a single key specifier. | |
| 5129 The help-char cannot be a negative number in XEmacs. | |
| 5130 */ ); | |
| 5131 Vhelp_char = make_char (8); /* C-h */ | |
| 5132 | |
| 5133 DEFVAR_LISP ("help-form", &Vhelp_form /* | |
| 5134 Form to execute when character help-char is read. | |
| 5135 If the form returns a string, that string is displayed. | |
| 5136 If `help-form' is nil, the help char is not recognized. | |
| 5137 */ ); | |
| 5138 Vhelp_form = Qnil; | |
| 5139 | |
| 5140 DEFVAR_LISP ("prefix-help-command", &Vprefix_help_command /* | |
| 5141 Command to run when `help-char' character follows a prefix key. | |
| 5142 This command is used only when there is no actual binding | |
| 5143 for that character after that prefix key. | |
| 5144 */ ); | |
| 5145 Vprefix_help_command = Qnil; | |
| 5146 | |
| 5147 DEFVAR_CONST_LISP ("keyboard-translate-table", &Vkeyboard_translate_table /* | |
| 5148 Hash table used as translate table for keyboard input. | |
| 5149 Use `keyboard-translate' to portably add entries to this table. | |
| 5150 Each key-press event is looked up in this table as follows: | |
| 5151 | |
| 5152 -- If an entry maps a symbol to a symbol, then a key-press event whose | |
| 5153 keysym is the former symbol (with any modifiers at all) gets its | |
| 5154 keysym changed and its modifiers left alone. This is useful for | |
| 5155 dealing with non-standard X keyboards, such as the grievous damage | |
| 5156 that Sun has inflicted upon the world. | |
| 442 | 5157 -- If an entry maps a symbol to a character, then a key-press event |
| 5158 whose keysym is the former symbol (with any modifiers at all) gets | |
| 5159 changed into a key-press event matching the latter character, and the | |
| 5160 resulting modifiers are the union of the original and new modifiers. | |
| 428 | 5161 -- If an entry maps a character to a character, then a key-press event |
| 5162 matching the former character gets converted to a key-press event | |
| 5163 matching the latter character. This is useful on ASCII terminals | |
| 5164 for (e.g.) making C-\\ look like C-s, to get around flow-control | |
| 5165 problems. | |
| 5166 -- If an entry maps a character to a symbol, then a key-press event | |
| 5167 matching the character gets converted to a key-press event whose | |
| 5168 keysym is the given symbol and which has no modifiers. | |
| 442 | 5169 |
| 5170 Here's an example: This makes typing parens and braces easier by rerouting | |
| 5171 their positions to eliminate the need to use the Shift key. | |
| 5172 | |
| 5173 (keyboard-translate ?[ ?() | |
| 5174 (keyboard-translate ?] ?)) | |
| 5175 (keyboard-translate ?{ ?[) | |
| 5176 (keyboard-translate ?} ?]) | |
| 5177 (keyboard-translate 'f11 ?{) | |
| 5178 (keyboard-translate 'f12 ?}) | |
| 428 | 5179 */ ); |
| 5180 | |
| 5181 DEFVAR_LISP ("retry-undefined-key-binding-unshifted", | |
| 5182 &Vretry_undefined_key_binding_unshifted /* | |
| 5183 If a key-sequence which ends with a shifted keystroke is undefined | |
| 5184 and this variable is non-nil then the command lookup is retried again | |
| 5185 with the last key unshifted. (e.g. C-X C-F would be retried as C-X C-f.) | |
| 5186 If lookup still fails, a normal error is signalled. In general, | |
| 5187 you should *bind* this, not set it. | |
| 5188 */ ); | |
| 5189 Vretry_undefined_key_binding_unshifted = Qt; | |
| 5190 | |
| 442 | 5191 DEFVAR_BOOL ("modifier-keys-are-sticky", &modifier_keys_are_sticky /* |
| 5192 *Non-nil makes modifier keys sticky. | |
| 5193 This means that you can release the modifier key before pressing down | |
| 5194 the key that you wish to be modified. Although this is non-standard | |
| 5195 behavior, it is recommended because it reduces the strain on your hand, | |
| 5196 thus reducing the incidence of the dreaded Emacs-pinky syndrome. | |
| 444 | 5197 |
| 5198 Modifier keys are sticky within the inverval specified by | |
| 5199 `modifier-keys-sticky-time'. | |
| 442 | 5200 */ ); |
| 5201 modifier_keys_are_sticky = 0; | |
| 5202 | |
| 444 | 5203 DEFVAR_LISP ("modifier-keys-sticky-time", &Vmodifier_keys_sticky_time /* |
| 5204 *Modifier keys are sticky within this many milliseconds. | |
| 5205 If you don't want modifier keys sticking to be bounded, set this to | |
| 5206 non-integer value. | |
| 5207 | |
| 5208 This variable has no effect when `modifier-keys-are-sticky' is nil. | |
| 5209 Currently only implemented under X Window System. | |
| 5210 */ ); | |
| 5211 Vmodifier_keys_sticky_time = make_int (500); | |
| 5212 | |
| 428 | 5213 Vcontrolling_terminal = Qnil; |
| 5214 staticpro (&Vcontrolling_terminal); | |
| 5215 | |
| 5216 Vdribble_file = Qnil; | |
| 5217 staticpro (&Vdribble_file); | |
| 5218 | |
| 5219 #ifdef DEBUG_XEMACS | |
| 5220 DEFVAR_INT ("debug-emacs-events", &debug_emacs_events /* | |
| 5221 If non-zero, display debug information about Emacs events that XEmacs sees. | |
| 5222 Information is displayed on stderr. | |
| 5223 | |
| 5224 Before the event, the source of the event is displayed in parentheses, | |
| 5225 and is one of the following: | |
| 5226 | |
| 5227 \(real) A real event from the window system or | |
| 5228 terminal driver, as far as XEmacs can tell. | |
| 5229 | |
| 5230 \(keyboard macro) An event generated from a keyboard macro. | |
| 5231 | |
| 5232 \(unread-command-events) An event taken from `unread-command-events'. | |
| 5233 | |
| 5234 \(unread-command-event) An event taken from `unread-command-event'. | |
| 5235 | |
| 5236 \(command event queue) An event taken from an internal queue. | |
| 5237 Events end up on this queue when | |
| 5238 `enqueue-eval-event' is called or when | |
| 5239 user or eval events are received while | |
| 5240 XEmacs is blocking (e.g. in `sit-for', | |
| 5241 `sleep-for', or `accept-process-output', | |
| 5242 or while waiting for the reply to an | |
| 5243 X selection). | |
| 5244 | |
| 5245 \(->keyboard-translate-table) The result of an event translated through | |
| 5246 keyboard-translate-table. Note that in | |
| 5247 this case, two events are printed even | |
| 5248 though only one is really generated. | |
| 5249 | |
| 5250 \(SIGINT) A faked C-g resulting when XEmacs receives | |
| 5251 a SIGINT (e.g. C-c was pressed in XEmacs' | |
| 5252 controlling terminal or the signal was | |
| 5253 explicitly sent to the XEmacs process). | |
| 5254 */ ); | |
| 5255 debug_emacs_events = 0; | |
| 5256 #endif | |
| 5257 | |
| 2828 | 5258 DEFVAR_BOOL ("inhibit-input-event-recording", |
| 5259 &inhibit_input_event_recording /* | |
| 428 | 5260 Non-nil inhibits recording of input-events to recent-keys ring. |
| 5261 */ ); | |
| 5262 inhibit_input_event_recording = 0; | |
| 771 | 5263 |
| 428 | 5264 Vkeyboard_translate_table = |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5143
diff
changeset
|
5265 make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, Qequal); |
| 2828 | 5266 |
| 5267 DEFVAR_BOOL ("try-alternate-layouts-for-commands", | |
| 5268 &try_alternate_layouts_for_commands /* | |
| 5269 Non-nil means that if looking up a command from a sequence of keys typed by | |
| 5270 the user would otherwise fail, try it again with some other keyboard | |
| 5271 layout. On X11, the only alternative to the default mapping is American | |
| 5272 QWERTY; on Windows, other mappings may be available, depending on things | |
| 5273 like the default language environment for the current user, for the system, | |
| 5274 &c. | |
| 5275 | |
| 5276 With a Russian keyboard layout on X11, for example, this means that | |
| 5277 C-Cyrillic_che C-Cyrillic_a, if you haven't given that sequence a binding | |
| 5278 yourself, will invoke `find-file.' This is because `Cyrillic_che' is | |
| 5279 physically where `x' is, and `Cyrillic_a' is where `f' is, on an American | |
| 5280 Qwerty layout, and, of course, C-x C-f is a default emacs binding for that | |
| 5281 command. | |
| 5282 */ ); | |
| 5283 try_alternate_layouts_for_commands = 1; | |
| 428 | 5284 } |
| 5285 | |
| 5286 void | |
| 5287 init_event_stream (void) | |
| 5288 { | |
| 814 | 5289 /* Normally we don't initialize the event stream when running a bare |
| 5290 temacs (the check for initialized) because it may do various things | |
| 5291 (e.g. under Xt) that we don't want any traces of in a dumped xemacs. | |
| 5292 However, sometimes we need to process events in a bare temacs (in | |
| 5293 particular, when make-docfile.el is executed); so we initialize as | |
| 5294 necessary in check_event_stream_ok(). */ | |
| 428 | 5295 if (initialized) |
| 5296 { | |
| 5297 #ifdef HAVE_UNIXOID_EVENT_LOOP | |
| 5298 init_event_unixoid (); | |
| 5299 #endif | |
| 5300 #ifdef HAVE_X_WINDOWS | |
| 5301 if (!strcmp (display_use, "x")) | |
| 5302 init_event_Xt_late (); | |
| 5303 else | |
| 5304 #endif | |
| 462 | 5305 #ifdef HAVE_GTK |
| 5306 if (!strcmp (display_use, "gtk")) | |
| 5307 init_event_gtk_late (); | |
| 5308 else | |
| 5309 #endif | |
| 428 | 5310 #ifdef HAVE_MS_WINDOWS |
| 5311 if (!strcmp (display_use, "mswindows")) | |
| 5312 init_event_mswindows_late (); | |
| 5313 else | |
| 5314 #endif | |
| 5315 { | |
| 5316 /* For TTY's, use the Xt event loop if we can; it allows | |
| 5317 us to later open an X connection. */ | |
| 5318 #if defined (HAVE_MS_WINDOWS) && (!defined (HAVE_TTY) \ | |
| 5319 || (defined (HAVE_MSG_SELECT) \ | |
| 5320 && !defined (DEBUG_TTY_EVENT_STREAM))) | |
| 5321 init_event_mswindows_late (); | |
| 5322 #elif defined (HAVE_X_WINDOWS) && !defined (DEBUG_TTY_EVENT_STREAM) | |
| 5323 init_event_Xt_late (); | |
| 5324 #elif defined (HAVE_TTY) | |
| 5325 init_event_tty_late (); | |
| 5326 #endif | |
| 5327 } | |
| 5328 init_interrupts_late (); | |
| 5329 } | |
| 5330 } | |
| 5331 | |
| 5332 | |
| 5333 /* | |
| 853 | 5334 #### this comment is at least 8 years old and some may no longer apply. |
| 5335 | |
| 428 | 5336 useful testcases for v18/v19 compatibility: |
| 5337 | |
| 5338 (defun foo () | |
| 5339 (interactive) | |
| 5340 (setq unread-command-event (character-to-event ?A (allocate-event))) | |
| 5341 (setq x (list (read-char) | |
| 5342 ; (read-key-sequence "") ; try it with and without this | |
| 5343 last-command-char last-input-char | |
| 5344 (recent-keys) (this-command-keys)))) | |
| 5345 (global-set-key "\^Q" 'foo) | |
| 5346 | |
| 5347 without the read-key-sequence: | |
| 444 | 5348 ^Q ==> (?A ?\^Q ?A [... ^Q] [^Q]) |
| 5349 ^U^U^Q ==> (?A ?\^Q ?A [... ^U ^U ^Q] [^U ^U ^Q]) | |
| 5350 ^U^U^U^G^Q ==> (?A ?\^Q ?A [... ^U ^U ^U ^G ^Q] [^Q]) | |
| 428 | 5351 |
| 5352 with the read-key-sequence: | |
| 444 | 5353 ^Qb ==> (?A [b] ?\^Q ?b [... ^Q b] [b]) |
| 5354 ^U^U^Qb ==> (?A [b] ?\^Q ?b [... ^U ^U ^Q b] [b]) | |
| 5355 ^U^U^U^G^Qb ==> (?A [b] ?\^Q ?b [... ^U ^U ^U ^G ^Q b] [b]) | |
| 428 | 5356 |
| 5357 ;the evi-mode command "4dlj.j.j.j.j.j." is also a good testcase (gag) | |
| 5358 | |
| 5359 ;(setq x (list (read-char) quit-flag))^J^G | |
| 5360 ;(let ((inhibit-quit t)) (setq x (list (read-char) quit-flag)))^J^G | |
| 5361 ;for BOTH, x should get set to (7 t), but no result should be printed. | |
| 444 | 5362 ;; #### According to the doc of quit-flag, second test should return |
| 5363 ;; (?\^G nil). Accidentaly XEmacs returns correct value. However, | |
| 5364 ;; XEmacs 21.1.12 and 21.2.36 both fails on first test. | |
| 428 | 5365 |
| 5366 ;also do this: make two frames, one viewing "*scratch*", the other "foo". | |
| 5367 ;in *scratch*, type (sit-for 20)^J | |
| 5368 ;wait a couple of seconds, move cursor to foo, type "a" | |
| 5369 ;a should be inserted in foo. Cursor highlighting should not change in | |
| 5370 ;the meantime. | |
| 5371 | |
| 5372 ;do it with sleep-for. move cursor into foo, then back into *scratch* | |
| 5373 ;before typing. | |
| 5374 ;repeat also with (accept-process-output nil 20) | |
| 5375 | |
| 5376 ;make sure ^G aborts sit-for, sleep-for and accept-process-output: | |
| 5377 | |
| 5378 (defun tst () | |
| 5379 (list (condition-case c | |
| 5380 (sleep-for 20) | |
| 5381 (quit c)) | |
| 5382 (read-char))) | |
| 5383 | |
| 444 | 5384 (tst)^Ja^G ==> ((quit) ?a) with no signal |
| 5385 (tst)^J^Ga ==> ((quit) ?a) with no signal | |
| 5386 (tst)^Jabc^G ==> ((quit) ?a) with no signal, and "bc" inserted in buffer | |
| 428 | 5387 |
| 5388 ; with sit-for only do the 2nd test. | |
| 5389 ; Do all 3 tests with (accept-process-output nil 20) | |
| 5390 | |
| 5391 Do this: | |
| 5392 (setq enable-recursive-minibuffers t | |
| 5393 minibuffer-max-depth nil) | |
| 5394 ESC ESC ESC ESC - there are now two minibuffers active | |
| 5395 C-g C-g C-g - there should be active 0, not 1 | |
| 5396 Similarly: | |
| 5397 C-x C-f ~ / ? - wait for "Making completion list..." to display | |
| 5398 C-g - wait for "Quit" to display | |
| 5399 C-g - minibuffer should not be active | |
| 5400 however C-g before "Quit" is displayed should leave minibuffer active. | |
| 5401 | |
| 5402 ;do it all in both v18 and v19 and make sure all results are the same. | |
| 5403 ;all of these cases matter a lot, but some in quite subtle ways. | |
| 5404 */ | |
| 5405 | |
| 5406 /* | |
| 5407 Additional test cases for accept-process-output, sleep-for, sit-for. | |
| 5408 Be sure you do all of the above checking for C-g and focus, too! | |
| 5409 | |
| 5410 ; Make sure that timer handlers are run during, not after sit-for: | |
| 5411 (defun timer-check () | |
| 5412 (add-timeout 2 '(lambda (ignore) (message "timer ran")) nil) | |
| 5413 (sit-for 5) | |
| 5414 (message "after sit-for")) | |
| 5415 | |
| 5416 ; The first message should appear after 2 seconds, and the final message | |
| 5417 ; 3 seconds after that. | |
| 5418 ; repeat above test with (sleep-for 5) and (accept-process-output nil 5) | |
| 5419 | |
| 5420 | |
| 5421 | |
| 5422 ; Make sure that process filters are run during, not after sit-for. | |
| 5423 (defun fubar () | |
| 5424 (message "sit-for = %s" (sit-for 30))) | |
| 5425 (add-hook 'post-command-hook 'fubar) | |
| 5426 | |
| 5427 ; Now type M-x shell RET | |
| 5428 ; wait for the shell prompt then send: ls RET | |
| 5429 ; the output of ls should fill immediately, and not wait 30 seconds. | |
| 5430 | |
| 5431 ; repeat above test with (sleep-for 30) and (accept-process-output nil 30) | |
| 5432 | |
| 5433 | |
| 5434 | |
| 5435 ; Make sure that recursive invocations return immediately: | |
| 5436 (defmacro test-diff-time (start end) | |
| 5437 `(+ (* (- (car ,end) (car ,start)) 65536.0) | |
| 5438 (- (cadr ,end) (cadr ,start)) | |
| 5439 (/ (- (caddr ,end) (caddr ,start)) 1000000.0))) | |
| 5440 | |
| 5441 (defun testee (ignore) | |
| 5442 (sit-for 10)) | |
| 5443 | |
| 5444 (defun test-them () | |
| 5445 (let ((start (current-time)) | |
| 5446 end) | |
| 5447 (add-timeout 2 'testee nil) | |
| 5448 (sit-for 5) | |
| 5449 (add-timeout 2 'testee nil) | |
| 5450 (sleep-for 5) | |
| 5451 (add-timeout 2 'testee nil) | |
| 5452 (accept-process-output nil 5) | |
| 5453 (setq end (current-time)) | |
| 5454 (test-diff-time start end))) | |
| 5455 | |
| 5456 (test-them) should sit for 15 seconds. | |
| 5457 Repeat with testee set to sleep-for and accept-process-output. | |
| 5458 These should each delay 36 seconds. | |
| 5459 | |
| 5460 */ |