Add some GT code points.
[chise/xemacs-chise.git.1] / src / events.c
1 /* Events: printing them, converting them to and from characters.
2    Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc.
3    Copyright (C) 1994, 1995 Board of Trustees, University of Illinois.
4
5 This file is part of XEmacs.
6
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
10 later version.
11
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING.  If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA.  */
21
22 /* Synched up with: Not in FSF. */
23
24 /* This file has been Mule-ized. */
25
26 #include <config.h>
27 #include "lisp.h"
28 #include "buffer.h"
29 #include "console.h"
30 #include "console-tty.h" /* for stuff in character_to_event */
31 #include "device.h"
32 #include "console-x.h"  /* for x_event_name prototype */
33 #include "console-gtk.h" /* for gtk_event_name prototype */
34 #include "extents.h"    /* Just for the EXTENTP abort check... */
35 #include "events.h"
36 #include "frame.h"
37 #include "glyphs.h"
38 #include "keymap.h" /* for key_desc_list_to_event() */
39 #include "redisplay.h"
40 #include "window.h"
41 #include "events-mod.h"
42
43 /* Where old events go when they are explicitly deallocated.
44    The event chain here is cut loose before GC, so these will be freed
45    eventually.
46  */
47 static Lisp_Object Vevent_resource;
48
49 Lisp_Object Qeventp;
50 Lisp_Object Qevent_live_p;
51 Lisp_Object Qkey_press_event_p;
52 Lisp_Object Qbutton_event_p;
53 Lisp_Object Qmouse_event_p;
54 Lisp_Object Qprocess_event_p;
55
56 Lisp_Object Qkey_press, Qbutton_press, Qbutton_release, Qmisc_user;
57 Lisp_Object Qascii_character;
58
59 EXFUN (Fevent_x_pixel, 1);
60 EXFUN (Fevent_y_pixel, 1);
61
62 /* #### Ad-hoc hack.  Should be part of define_lrecord_implementation */
63 void
64 clear_event_resource (void)
65 {
66   Vevent_resource = Qnil;
67 }
68
69 /* Make sure we lose quickly if we try to use this event */
70 static void
71 deinitialize_event (Lisp_Object ev)
72 {
73   int i;
74   Lisp_Event *event = XEVENT (ev);
75
76   for (i = 0; i < (int) (sizeof (Lisp_Event) / sizeof (int)); i++)
77     ((int *) event) [i] = 0xdeadbeef;
78   event->event_type = dead_event;
79   event->channel = Qnil;
80   set_lheader_implementation (&event->lheader, &lrecord_event);
81   XSET_EVENT_NEXT (ev, Qnil);
82 }
83
84 /* Set everything to zero or nil so that it's predictable. */
85 void
86 zero_event (Lisp_Event *e)
87 {
88   xzero (*e);
89   set_lheader_implementation (&e->lheader, &lrecord_event);
90   e->event_type = empty_event;
91   e->next = Qnil;
92   e->channel = Qnil;
93 }
94
95 static Lisp_Object
96 mark_event (Lisp_Object obj)
97 {
98   Lisp_Event *event = XEVENT (obj);
99
100   switch (event->event_type)
101     {
102     case key_press_event:
103       mark_object (event->event.key.keysym);
104       break;
105     case process_event:
106       mark_object (event->event.process.process);
107       break;
108     case timeout_event:
109       mark_object (event->event.timeout.function);
110       mark_object (event->event.timeout.object);
111       break;
112     case eval_event:
113     case misc_user_event:
114       mark_object (event->event.eval.function);
115       mark_object (event->event.eval.object);
116       break;
117     case magic_eval_event:
118       mark_object (event->event.magic_eval.object);
119       break;
120     case button_press_event:
121     case button_release_event:
122     case pointer_motion_event:
123     case magic_event:
124     case empty_event:
125     case dead_event:
126       break;
127     default:
128       abort ();
129     }
130   mark_object (event->channel);
131   return event->next;
132 }
133
134 static void
135 print_event_1 (const char *str, Lisp_Object obj, Lisp_Object printcharfun)
136 {
137   char buf[255];
138   write_c_string (str, printcharfun);
139   format_event_object (buf, XEVENT (obj), 0);
140   write_c_string (buf, printcharfun);
141 }
142
143 static void
144 print_event (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
145 {
146   if (print_readably)
147     error ("Printing unreadable object #<event>");
148
149   switch (XEVENT (obj)->event_type)
150     {
151     case key_press_event:
152       print_event_1 ("#<keypress-event ", obj, printcharfun);
153       break;
154     case button_press_event:
155       print_event_1 ("#<buttondown-event ", obj, printcharfun);
156       break;
157     case button_release_event:
158       print_event_1 ("#<buttonup-event ", obj, printcharfun);
159       break;
160     case magic_event:
161     case magic_eval_event:
162       print_event_1 ("#<magic-event ", obj, printcharfun);
163       break;
164     case pointer_motion_event:
165       {
166         char buf[64];
167         Lisp_Object Vx, Vy;
168         Vx = Fevent_x_pixel (obj);
169         assert (INTP (Vx));
170         Vy = Fevent_y_pixel (obj);
171         assert (INTP (Vy));
172         sprintf (buf, "#<motion-event %ld, %ld", (long) XINT (Vx), (long) XINT (Vy));
173         write_c_string (buf, printcharfun);
174         break;
175       }
176     case process_event:
177         write_c_string ("#<process-event ", printcharfun);
178         print_internal (XEVENT (obj)->event.process.process, printcharfun, 1);
179         break;
180     case timeout_event:
181         write_c_string ("#<timeout-event ", printcharfun);
182         print_internal (XEVENT (obj)->event.timeout.object, printcharfun, 1);
183         break;
184     case empty_event:
185         write_c_string ("#<empty-event", printcharfun);
186         break;
187     case misc_user_event:
188         write_c_string ("#<misc-user-event (", printcharfun);
189         print_internal (XEVENT (obj)->event.misc.function, printcharfun, 1);
190         write_c_string (" ", printcharfun);
191         print_internal (XEVENT (obj)->event.misc.object, printcharfun, 1);
192         write_c_string (")", printcharfun);
193         break;
194     case eval_event:
195         write_c_string ("#<eval-event (", printcharfun);
196         print_internal (XEVENT (obj)->event.eval.function, printcharfun, 1);
197         write_c_string (" ", printcharfun);
198         print_internal (XEVENT (obj)->event.eval.object, printcharfun, 1);
199         write_c_string (")", printcharfun);
200         break;
201     case dead_event:
202         write_c_string ("#<DEALLOCATED-EVENT", printcharfun);
203         break;
204     default:
205         write_c_string ("#<UNKNOWN-EVENT-TYPE", printcharfun);
206         break;
207       }
208   write_c_string (">", printcharfun);
209 }
210
211 static int
212 event_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
213 {
214   Lisp_Event *e1 = XEVENT (obj1);
215   Lisp_Event *e2 = XEVENT (obj2);
216
217   if (e1->event_type != e2->event_type) return 0;
218   if (!EQ (e1->channel, e2->channel)) return 0;
219 /*  if (e1->timestamp != e2->timestamp) return 0; */
220   switch (e1->event_type)
221     {
222     default: abort ();
223
224     case process_event:
225       return EQ (e1->event.process.process, e2->event.process.process);
226
227     case timeout_event:
228       return (internal_equal (e1->event.timeout.function,
229                               e2->event.timeout.function, 0) &&
230               internal_equal (e1->event.timeout.object,
231                               e2->event.timeout.object, 0));
232
233     case key_press_event:
234       return (EQ (e1->event.key.keysym, e2->event.key.keysym) &&
235               (e1->event.key.modifiers == e2->event.key.modifiers));
236
237     case button_press_event:
238     case button_release_event:
239       return (e1->event.button.button    == e2->event.button.button &&
240               e1->event.button.modifiers == e2->event.button.modifiers);
241
242     case pointer_motion_event:
243       return (e1->event.motion.x == e2->event.motion.x &&
244               e1->event.motion.y == e2->event.motion.y);
245
246     case misc_user_event:
247       return (internal_equal (e1->event.eval.function,
248                               e2->event.eval.function, 0) &&
249               internal_equal (e1->event.eval.object,
250                               e2->event.eval.object, 0) &&
251               /* is this really needed for equality
252                  or is x and y also important? */
253               e1->event.misc.button    == e2->event.misc.button &&
254               e1->event.misc.modifiers == e2->event.misc.modifiers);
255
256     case eval_event:
257       return (internal_equal (e1->event.eval.function,
258                               e2->event.eval.function, 0) &&
259               internal_equal (e1->event.eval.object,
260                               e2->event.eval.object, 0));
261
262     case magic_eval_event:
263       return (e1->event.magic_eval.internal_function ==
264               e2->event.magic_eval.internal_function &&
265               internal_equal (e1->event.magic_eval.object,
266                               e2->event.magic_eval.object, 0));
267
268     case magic_event:
269       {
270         struct console *con = XCONSOLE (CDFW_CONSOLE (e1->channel));
271
272 #ifdef HAVE_GTK
273         if (CONSOLE_GTK_P (con))
274           return (!memcmp (&e1->event.magic.underlying_gdk_event,
275                            &e2->event.magic.underlying_gdk_event,
276                            sizeof (GdkEvent)));
277 #endif
278 #ifdef HAVE_X_WINDOWS
279         if (CONSOLE_X_P (con))
280           return (e1->event.magic.underlying_x_event.xany.serial ==
281                   e2->event.magic.underlying_x_event.xany.serial);
282 #endif
283 #ifdef HAVE_TTY
284         if (CONSOLE_TTY_P (con))
285           return (e1->event.magic.underlying_tty_event ==
286                   e2->event.magic.underlying_tty_event);
287 #endif
288 #ifdef HAVE_MS_WINDOWS
289         if (CONSOLE_MSWINDOWS_P (con))
290           return (!memcmp(&e1->event.magic.underlying_mswindows_event,
291                           &e2->event.magic.underlying_mswindows_event,
292                           sizeof (union magic_data)));
293 #endif
294         abort ();
295         return 1; /* not reached */
296       }
297
298     case empty_event:      /* Empty and deallocated events are equal. */
299     case dead_event:
300       return 1;
301     }
302 }
303
304 static unsigned long
305 event_hash (Lisp_Object obj, int depth)
306 {
307   Lisp_Event *e = XEVENT (obj);
308   unsigned long hash;
309
310   hash = HASH2 (e->event_type, LISP_HASH (e->channel));
311   switch (e->event_type)
312     {
313     case process_event:
314       return HASH2 (hash, LISP_HASH (e->event.process.process));
315
316     case timeout_event:
317       return HASH3 (hash, internal_hash (e->event.timeout.function, depth + 1),
318                     internal_hash (e->event.timeout.object, depth + 1));
319
320     case key_press_event:
321       return HASH3 (hash, LISP_HASH (e->event.key.keysym),
322                     e->event.key.modifiers);
323
324     case button_press_event:
325     case button_release_event:
326       return HASH3 (hash, e->event.button.button, e->event.button.modifiers);
327
328     case pointer_motion_event:
329       return HASH3 (hash, e->event.motion.x, e->event.motion.y);
330
331     case misc_user_event:
332       return HASH5 (hash, internal_hash (e->event.misc.function, depth + 1),
333                     internal_hash (e->event.misc.object, depth + 1),
334                     e->event.misc.button, e->event.misc.modifiers);
335
336     case eval_event:
337       return HASH3 (hash, internal_hash (e->event.eval.function, depth + 1),
338                     internal_hash (e->event.eval.object, depth + 1));
339
340     case magic_eval_event:
341       return HASH3 (hash,
342                     (unsigned long) e->event.magic_eval.internal_function,
343                     internal_hash (e->event.magic_eval.object, depth + 1));
344
345     case magic_event:
346       {
347         struct console *con = XCONSOLE (CDFW_CONSOLE (EVENT_CHANNEL (e)));
348 #ifdef HAVE_GTK
349         if (CONSOLE_GTK_P (con))
350           return HASH2 (hash, e->event.magic.underlying_gdk_event.type);
351 #endif
352 #ifdef HAVE_X_WINDOWS
353         if (CONSOLE_X_P (con))
354           return HASH2 (hash, e->event.magic.underlying_x_event.xany.serial);
355 #endif
356 #ifdef HAVE_TTY
357         if (CONSOLE_TTY_P (con))
358           return HASH2 (hash, e->event.magic.underlying_tty_event);
359 #endif
360 #ifdef HAVE_MS_WINDOWS
361         if (CONSOLE_MSWINDOWS_P (con))
362           return HASH2 (hash, e->event.magic.underlying_mswindows_event);
363 #endif
364         abort ();
365         return 0;
366       }
367
368     case empty_event:
369     case dead_event:
370       return hash;
371
372     default:
373       abort ();
374     }
375
376   return 0; /* unreached */
377 }
378
379 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("event", event,
380                                      mark_event, print_event, 0, event_equal,
381                                      event_hash, 0, Lisp_Event);
382
383 \f
384 DEFUN ("make-event", Fmake_event, 0, 2, 0, /*
385 Return a new event of type TYPE, with properties described by PLIST.
386
387 TYPE is a symbol, either `empty', `key-press', `button-press',
388  `button-release', `misc-user' or `motion'.  If TYPE is nil, it
389  defaults to `empty'.
390
391 PLIST is a property list, the properties being compatible to those
392  returned by `event-properties'.  The following properties are
393  allowed:
394
395  channel        -- The event channel, a frame or a console.  For
396                    button-press, button-release, misc-user and motion events,
397                    this must be a frame.  For key-press events, it must be
398                    a console.  If channel is unspecified, it will be set to
399                    the selected frame or selected console, as appropriate.
400  key            -- The event key, a symbol or character.  Allowed only for
401                    keypress events.
402  button         -- The event button, integer 1, 2 or 3.  Allowed for
403                    button-press, button-release and misc-user events.
404  modifiers      -- The event modifiers, a list of modifier symbols.  Allowed
405                    for key-press, button-press, button-release, motion and
406                    misc-user events.
407  function       -- Function. Allowed for misc-user events only.
408  object         -- An object, function's parameter. Allowed for misc-user
409                    events only.
410  x              -- The event X coordinate, an integer.  This is relative
411                    to the left of CHANNEL's root window.  Allowed for
412                    motion, button-press, button-release and misc-user events.
413  y              -- The event Y coordinate, an integer.  This is relative
414                    to the top of CHANNEL's root window.  Allowed for
415                    motion, button-press, button-release and misc-user events.
416  timestamp      -- The event timestamp, a non-negative integer.  Allowed for
417                    all types of events.  If unspecified, it will be set to 0
418                    by default.
419
420 For event type `empty', PLIST must be nil.
421  `button-release', or `motion'.  If TYPE is left out, it defaults to
422  `empty'.
423 PLIST is a list of properties, as returned by `event-properties'.  Not
424  all properties are allowed for all kinds of events, and some are
425  required.
426
427 WARNING: the event object returned may be a reused one; see the function
428  `deallocate-event'.
429 */
430        (type, plist))
431 {
432   Lisp_Object event = Qnil;
433   Lisp_Event *e;
434   EMACS_INT coord_x = 0, coord_y = 0;
435   struct gcpro gcpro1;
436
437   GCPRO1 (event);
438
439   if (NILP (type))
440     type = Qempty;
441
442   if (!NILP (Vevent_resource))
443     {
444       event = Vevent_resource;
445       Vevent_resource = XEVENT_NEXT (event);
446     }
447   else
448     {
449       event = allocate_event ();
450     }
451   e = XEVENT (event);
452   zero_event (e);
453
454   if (EQ (type, Qempty))
455     {
456       /* For empty event, we return immediately, without processing
457          PLIST.  In fact, processing PLIST would be wrong, because the
458          sanitizing process would fill in the properties
459          (e.g. CHANNEL), which we don't want in empty events.  */
460       e->event_type = empty_event;
461       if (!NILP (plist))
462         syntax_error ("Cannot set properties of empty event", plist);
463       UNGCPRO;
464       return event;
465     }
466   else if (EQ (type, Qkey_press))
467     {
468       e->event_type = key_press_event;
469       e->event.key.keysym = Qunbound;
470     }
471   else if (EQ (type, Qbutton_press))
472     e->event_type = button_press_event;
473   else if (EQ (type, Qbutton_release))
474     e->event_type = button_release_event;
475   else if (EQ (type, Qmotion))
476     e->event_type = pointer_motion_event;
477   else if (EQ (type, Qmisc_user))
478     {
479       e->event_type = misc_user_event;
480       e->event.eval.function = e->event.eval.object = Qnil;
481     }
482   else
483     {
484       /* Not allowed: Qprocess, Qtimeout, Qmagic, Qeval, Qmagic_eval.  */
485       invalid_argument ("Invalid event type", type);
486     }
487
488   EVENT_CHANNEL (e) = Qnil;
489
490   plist = Fcopy_sequence (plist);
491   Fcanonicalize_plist (plist, Qnil);
492
493 #define WRONG_EVENT_TYPE_FOR_PROPERTY(event_type, prop) \
494   syntax_error_2 ("Invalid property for event type", prop, event_type)
495
496   {
497     EXTERNAL_PROPERTY_LIST_LOOP_3 (keyword, value, plist)
498       {
499         if (EQ (keyword, Qchannel))
500           {
501             if (e->event_type == key_press_event)
502               {
503                 if (!CONSOLEP (value))
504                   value = wrong_type_argument (Qconsolep, value);
505               }
506             else
507               {
508                 if (!FRAMEP (value))
509                   value = wrong_type_argument (Qframep, value);
510               }
511             EVENT_CHANNEL (e) = value;
512           }
513         else if (EQ (keyword, Qkey))
514           {
515             switch (e->event_type)
516               {
517               case key_press_event:
518                 if (!SYMBOLP (value) && !CHARP (value))
519                   syntax_error ("Invalid event key", value);
520                 e->event.key.keysym = value;
521                 break;
522               default:
523                 WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
524                 break;
525               }
526           }
527         else if (EQ (keyword, Qbutton))
528           {
529             CHECK_NATNUM (value);
530             check_int_range (XINT (value), 0, 7);
531
532             switch (e->event_type)
533               {
534               case button_press_event:
535               case button_release_event:
536                 e->event.button.button = XINT (value);
537                 break;
538               case misc_user_event:
539                 e->event.misc.button = XINT (value);
540                 break;
541               default:
542                 WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
543                 break;
544               }
545           }
546         else if (EQ (keyword, Qmodifiers))
547           {
548             int modifiers = 0;
549
550             EXTERNAL_LIST_LOOP_2 (sym, value)
551               {
552                 if      (EQ (sym, Qcontrol)) modifiers |= XEMACS_MOD_CONTROL;
553                 else if (EQ (sym, Qmeta))    modifiers |= XEMACS_MOD_META;
554                 else if (EQ (sym, Qsuper))   modifiers |= XEMACS_MOD_SUPER;
555                 else if (EQ (sym, Qhyper))   modifiers |= XEMACS_MOD_HYPER;
556                 else if (EQ (sym, Qalt))     modifiers |= XEMACS_MOD_ALT;
557                 else if (EQ (sym, Qsymbol))  modifiers |= XEMACS_MOD_ALT;
558                 else if (EQ (sym, Qshift))   modifiers |= XEMACS_MOD_SHIFT;
559                 else if (EQ (sym, Qbutton1))   modifiers |= XEMACS_MOD_BUTTON1;
560                 else if (EQ (sym, Qbutton2))   modifiers |= XEMACS_MOD_BUTTON2;
561                 else if (EQ (sym, Qbutton3))   modifiers |= XEMACS_MOD_BUTTON3;
562                 else if (EQ (sym, Qbutton4))   modifiers |= XEMACS_MOD_BUTTON4;
563                 else if (EQ (sym, Qbutton5))   modifiers |= XEMACS_MOD_BUTTON5;
564                 else
565                   syntax_error ("Invalid key modifier", sym);
566               }
567
568             switch (e->event_type)
569               {
570               case key_press_event:
571                 e->event.key.modifiers = modifiers;
572                 break;
573               case button_press_event:
574               case button_release_event:
575                 e->event.button.modifiers = modifiers;
576                 break;
577               case pointer_motion_event:
578                 e->event.motion.modifiers = modifiers;
579                 break;
580               case misc_user_event:
581                 e->event.misc.modifiers = modifiers;
582                 break;
583               default:
584                 WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
585                 break;
586               }
587           }
588         else if (EQ (keyword, Qx))
589           {
590             switch (e->event_type)
591               {
592               case pointer_motion_event:
593               case button_press_event:
594               case button_release_event:
595               case misc_user_event:
596                 /* Allow negative values, so we can specify toolbar
597                    positions.  */
598                 CHECK_INT (value);
599                 coord_x = XINT (value);
600                 break;
601               default:
602                 WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
603                 break;
604               }
605           }
606         else if (EQ (keyword, Qy))
607           {
608             switch (e->event_type)
609               {
610               case pointer_motion_event:
611               case button_press_event:
612               case button_release_event:
613               case misc_user_event:
614                 /* Allow negative values; see above. */
615                 CHECK_INT (value);
616                 coord_y = XINT (value);
617                 break;
618               default:
619                 WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
620                 break;
621               }
622           }
623         else if (EQ (keyword, Qtimestamp))
624           {
625             CHECK_NATNUM (value);
626             e->timestamp = XINT (value);
627           }
628         else if (EQ (keyword, Qfunction))
629           {
630             switch (e->event_type)
631               {
632               case misc_user_event:
633                 e->event.eval.function = value;
634                 break;
635               default:
636                 WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
637                 break;
638               }
639           }
640         else if (EQ (keyword, Qobject))
641           {
642             switch (e->event_type)
643               {
644               case misc_user_event:
645                 e->event.eval.object = value;
646                 break;
647               default:
648                 WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword);
649                 break;
650               }
651           }
652         else
653           syntax_error_2 ("Invalid property", keyword, value);
654       }
655   }
656
657   /* Insert the channel, if missing. */
658   if (NILP (EVENT_CHANNEL (e)))
659     {
660       if (e->event_type == key_press_event)
661         EVENT_CHANNEL (e) = Vselected_console;
662       else
663         EVENT_CHANNEL (e) = Fselected_frame (Qnil);
664     }
665
666   /* Fevent_properties, Fevent_x_pixel, etc. work with pixels relative
667      to the frame, so we must adjust accordingly.  */
668   if (FRAMEP (EVENT_CHANNEL (e)))
669     {
670       coord_x += FRAME_REAL_LEFT_TOOLBAR_WIDTH (XFRAME (EVENT_CHANNEL (e)));
671       coord_y += FRAME_REAL_TOP_TOOLBAR_HEIGHT (XFRAME (EVENT_CHANNEL (e)));
672
673       switch (e->event_type)
674         {
675         case pointer_motion_event:
676           e->event.motion.x = coord_x;
677           e->event.motion.y = coord_y;
678           break;
679         case button_press_event:
680         case button_release_event:
681           e->event.button.x = coord_x;
682           e->event.button.y = coord_y;
683           break;
684         case misc_user_event:
685           e->event.misc.x = coord_x;
686           e->event.misc.y = coord_y;
687           break;
688         default:
689           abort();
690         }
691     }
692
693   /* Finally, do some more validation.  */
694   switch (e->event_type)
695     {
696     case key_press_event:
697       if (UNBOUNDP (e->event.key.keysym))
698         syntax_error ("A key must be specified to make a keypress event",
699                       plist);
700       break;
701     case button_press_event:
702       if (!e->event.button.button)
703         syntax_error
704           ("A button must be specified to make a button-press event",
705            plist);
706       break;
707     case button_release_event:
708       if (!e->event.button.button)
709         syntax_error
710           ("A button must be specified to make a button-release event",
711            plist);
712       break;
713     case misc_user_event:
714       if (NILP (e->event.misc.function))
715         syntax_error ("A function must be specified to make a misc-user event",
716                       plist);
717       break;
718     default:
719       break;
720     }
721
722   UNGCPRO;
723   return event;
724 }
725
726 DEFUN ("deallocate-event", Fdeallocate_event, 1, 1, 0, /*
727 Allow the given event structure to be reused.
728 You MUST NOT use this event object after calling this function with it.
729 You will lose.  It is not necessary to call this function, as event
730 objects are garbage-collected like all other objects; however, it may
731 be more efficient to explicitly deallocate events when you are sure
732 that it is safe to do so.
733 */
734        (event))
735 {
736   CHECK_EVENT (event);
737
738   if (XEVENT_TYPE (event) == dead_event)
739     error ("this event is already deallocated!");
740
741   assert (XEVENT_TYPE (event) <= last_event_type);
742
743 #if 0
744   {
745     int i, len;
746
747     if (EQ (event, Vlast_command_event) ||
748         EQ (event, Vlast_input_event)   ||
749         EQ (event, Vunread_command_event))
750       abort ();
751
752     len = XVECTOR_LENGTH (Vthis_command_keys);
753     for (i = 0; i < len; i++)
754       if (EQ (event, XVECTOR_DATA (Vthis_command_keys) [i]))
755         abort ();
756     if (!NILP (Vrecent_keys_ring))
757       {
758         int recent_ring_len = XVECTOR_LENGTH (Vrecent_keys_ring);
759         for (i = 0; i < recent_ring_len; i++)
760           if (EQ (event, XVECTOR_DATA (Vrecent_keys_ring) [i]))
761             abort ();
762       }
763   }
764 #endif /* 0 */
765
766   assert (!EQ (event, Vevent_resource));
767   deinitialize_event (event);
768 #ifndef ALLOC_NO_POOLS
769   XSET_EVENT_NEXT (event, Vevent_resource);
770   Vevent_resource = event;
771 #endif
772   return Qnil;
773 }
774
775 DEFUN ("copy-event", Fcopy_event, 1, 2, 0, /*
776 Make a copy of the event object EVENT1.
777 If a second event argument EVENT2 is given, EVENT1 is copied into
778 EVENT2 and EVENT2 is returned.  If EVENT2 is not supplied (or is nil)
779 then a new event will be made as with `make-event'.  See also the
780 function `deallocate-event'.
781 */
782        (event1, event2))
783 {
784   CHECK_LIVE_EVENT (event1);
785   if (NILP (event2))
786     event2 = Fmake_event (Qnil, Qnil);
787   else
788     {
789       CHECK_LIVE_EVENT (event2);
790       if (EQ (event1, event2))
791         return signal_simple_continuable_error_2
792           ("copy-event called with `eq' events", event1, event2);
793     }
794
795   assert (XEVENT_TYPE (event1) <= last_event_type);
796   assert (XEVENT_TYPE (event2) <= last_event_type);
797
798   {
799     Lisp_Event *ev2 = XEVENT (event2);
800     Lisp_Event *ev1 = XEVENT (event1);
801
802     ev2->event_type = ev1->event_type;
803     ev2->channel    = ev1->channel;
804     ev2->timestamp  = ev1->timestamp;
805     ev2->event      = ev1->event;
806
807     return event2;
808   }
809 }
810
811 \f
812
813 /* Given a chain of events (or possibly nil), deallocate them all. */
814
815 void
816 deallocate_event_chain (Lisp_Object event_chain)
817 {
818   while (!NILP (event_chain))
819     {
820       Lisp_Object next = XEVENT_NEXT (event_chain);
821       Fdeallocate_event (event_chain);
822       event_chain = next;
823     }
824 }
825
826 /* Return the last event in a chain.
827    NOTE: You cannot pass nil as a value here!  The routine will
828    abort if you do. */
829
830 Lisp_Object
831 event_chain_tail (Lisp_Object event_chain)
832 {
833   while (1)
834     {
835       Lisp_Object next = XEVENT_NEXT (event_chain);
836       if (NILP (next))
837         return event_chain;
838       event_chain = next;
839     }
840 }
841
842 /* Enqueue a single event onto the end of a chain of events.
843    HEAD points to the first event in the chain, TAIL to the last event.
844    If the chain is empty, both values should be nil. */
845
846 void
847 enqueue_event (Lisp_Object event, Lisp_Object *head, Lisp_Object *tail)
848 {
849   assert (NILP (XEVENT_NEXT (event)));
850   assert (!EQ (*tail, event));
851
852   if (!NILP (*tail))
853     XSET_EVENT_NEXT (*tail, event);
854   else
855    *head = event;
856   *tail = event;
857
858   assert (!EQ (event, XEVENT_NEXT (event)));
859 }
860
861 /* Remove an event off the head of a chain of events and return it.
862    HEAD points to the first event in the chain, TAIL to the last event. */
863
864 Lisp_Object
865 dequeue_event (Lisp_Object *head, Lisp_Object *tail)
866 {
867   Lisp_Object event;
868
869   event = *head;
870   *head = XEVENT_NEXT (event);
871   XSET_EVENT_NEXT (event, Qnil);
872   if (NILP (*head))
873     *tail = Qnil;
874   return event;
875 }
876
877 /* Enqueue a chain of events (or possibly nil) onto the end of another
878    chain of events.  HEAD points to the first event in the chain being
879    queued onto, TAIL to the last event.  If the chain is empty, both values
880    should be nil. */
881
882 void
883 enqueue_event_chain (Lisp_Object event_chain, Lisp_Object *head,
884                      Lisp_Object *tail)
885 {
886   if (NILP (event_chain))
887     return;
888
889   if (NILP (*head))
890     {
891       *head = event_chain;
892       *tail = event_chain;
893     }
894   else
895     {
896       XSET_EVENT_NEXT (*tail, event_chain);
897       *tail = event_chain_tail (event_chain);
898     }
899 }
900
901 /* Return the number of events (possibly 0) on an event chain. */
902
903 int
904 event_chain_count (Lisp_Object event_chain)
905 {
906   Lisp_Object event;
907   int n = 0;
908
909   EVENT_CHAIN_LOOP (event, event_chain)
910     n++;
911
912   return n;
913 }
914
915 /* Find the event before EVENT in an event chain.  This aborts
916    if the event is not in the chain. */
917
918 Lisp_Object
919 event_chain_find_previous (Lisp_Object event_chain, Lisp_Object event)
920 {
921   Lisp_Object previous = Qnil;
922
923   while (!NILP (event_chain))
924     {
925       if (EQ (event_chain, event))
926         return previous;
927       previous = event_chain;
928       event_chain = XEVENT_NEXT (event_chain);
929     }
930
931   abort ();
932   return Qnil;
933 }
934
935 Lisp_Object
936 event_chain_nth (Lisp_Object event_chain, int n)
937 {
938   Lisp_Object event;
939   EVENT_CHAIN_LOOP (event, event_chain)
940     {
941       if (!n)
942         return event;
943       n--;
944     }
945   return Qnil;
946 }
947
948 Lisp_Object
949 copy_event_chain (Lisp_Object event_chain)
950 {
951   Lisp_Object new_chain = Qnil;
952   Lisp_Object new_chain_tail = Qnil;
953   Lisp_Object event;
954
955   EVENT_CHAIN_LOOP (event, event_chain)
956     {
957       Lisp_Object copy = Fcopy_event (event, Qnil);
958       enqueue_event (copy, &new_chain, &new_chain_tail);
959     }
960
961   return new_chain;
962 }
963
964 \f
965
966 Lisp_Object QKbackspace, QKtab, QKlinefeed, QKreturn, QKescape,
967  QKspace, QKdelete;
968
969 int
970 command_event_p (Lisp_Object event)
971 {
972   switch (XEVENT_TYPE (event))
973     {
974     case key_press_event:
975     case button_press_event:
976     case button_release_event:
977     case misc_user_event:
978       return 1;
979     default:
980       return 0;
981     }
982 }
983
984
985 void
986 character_to_event (Emchar c, Lisp_Event *event, struct console *con,
987                     int use_console_meta_flag, int do_backspace_mapping)
988 {
989   Lisp_Object k = Qnil;
990   int m = 0;
991   if (event->event_type == dead_event)
992     error ("character-to-event called with a deallocated event!");
993
994 #ifndef MULE
995   c &= 255;
996 #endif
997   if (c > 127 && c <= 255)
998     {
999       int meta_flag = 1;
1000       if (use_console_meta_flag && CONSOLE_TTY_P (con))
1001         meta_flag = TTY_FLAGS (con).meta_key;
1002       switch (meta_flag)
1003         {
1004         case 0: /* ignore top bit; it's parity */
1005           c -= 128;
1006           break;
1007         case 1: /* top bit is meta */
1008           c -= 128;
1009           m = XEMACS_MOD_META;
1010           break;
1011         default: /* this is a real character */
1012           break;
1013         }
1014     }
1015   if (c < ' ') c += '@', m |= XEMACS_MOD_CONTROL;
1016   if (m & XEMACS_MOD_CONTROL)
1017     {
1018       switch (c)
1019         {
1020         case 'I': k = QKtab;      m &= ~XEMACS_MOD_CONTROL; break;
1021         case 'J': k = QKlinefeed; m &= ~XEMACS_MOD_CONTROL; break;
1022         case 'M': k = QKreturn;   m &= ~XEMACS_MOD_CONTROL; break;
1023         case '[': k = QKescape;   m &= ~XEMACS_MOD_CONTROL; break;
1024         default:
1025 #if defined(HAVE_TTY)
1026           if (do_backspace_mapping &&
1027               CHARP (con->tty_erase_char) &&
1028               c - '@' == XCHAR (con->tty_erase_char))
1029             {
1030               k = QKbackspace;
1031               m &= ~XEMACS_MOD_CONTROL;
1032             }
1033 #endif /* defined(HAVE_TTY) && !defined(CYGWIN) */
1034           break;
1035         }
1036       if (c >= 'A' && c <= 'Z') c -= 'A'-'a';
1037     }
1038 #if defined(HAVE_TTY)
1039   else if (do_backspace_mapping &&
1040            CHARP (con->tty_erase_char) && c == XCHAR (con->tty_erase_char))
1041     k = QKbackspace;
1042 #endif /* defined(HAVE_TTY) && !defined(CYGWIN) */
1043   else if (c == 127)
1044     k = QKdelete;
1045   else if (c == ' ')
1046     k = QKspace;
1047
1048   event->event_type          = key_press_event;
1049   event->timestamp           = 0; /* #### */
1050   event->channel             = make_console (con);
1051   event->event.key.keysym    = (!NILP (k) ? k : make_char (c));
1052   event->event.key.modifiers = m;
1053 }
1054
1055 /* This variable controls what character name -> character code mapping
1056    we are using.  Window-system-specific code sets this to some symbol,
1057    and we use that symbol as the plist key to convert keysyms into 8-bit
1058    codes.  In this way one can have several character sets predefined and
1059    switch them by changing this.
1060
1061    #### This is utterly bogus and should be removed.
1062  */
1063 Lisp_Object Vcharacter_set_property;
1064
1065 Emchar
1066 event_to_character (Lisp_Event *event,
1067                     int allow_extra_modifiers,
1068                     int allow_meta,
1069                     int allow_non_ascii)
1070 {
1071   Emchar c = 0;
1072   Lisp_Object code;
1073
1074   if (event->event_type != key_press_event)
1075     {
1076       assert (event->event_type != dead_event);
1077       return -1;
1078     }
1079   if (!allow_extra_modifiers &&
1080       event->event.key.modifiers & (XEMACS_MOD_SUPER|XEMACS_MOD_HYPER|XEMACS_MOD_ALT))
1081     return -1;
1082   if (CHAR_OR_CHAR_INTP (event->event.key.keysym))
1083     c = XCHAR_OR_CHAR_INT (event->event.key.keysym);
1084   else if (!SYMBOLP (event->event.key.keysym))
1085     abort ();
1086   else if (allow_non_ascii && !NILP (Vcharacter_set_property)
1087            /* Allow window-system-specific extensibility of
1088               keysym->code mapping */
1089            && CHAR_OR_CHAR_INTP (code = Fget (event->event.key.keysym,
1090                                               Vcharacter_set_property,
1091                                               Qnil)))
1092     c = XCHAR_OR_CHAR_INT (code);
1093   else if (CHAR_OR_CHAR_INTP (code = Fget (event->event.key.keysym,
1094                                            Qascii_character, Qnil)))
1095     c = XCHAR_OR_CHAR_INT (code);
1096   else
1097     return -1;
1098
1099   if (event->event.key.modifiers & XEMACS_MOD_CONTROL)
1100     {
1101       if (c >= 'a' && c <= 'z')
1102         c -= ('a' - 'A');
1103       else
1104         /* reject Control-Shift- keys */
1105         if (c >= 'A' && c <= 'Z' && !allow_extra_modifiers)
1106           return -1;
1107
1108       if (c >= '@' && c <= '_')
1109         c -= '@';
1110       else if (c == ' ')  /* C-space and C-@ are the same. */
1111         c = 0;
1112       else
1113         /* reject keys that can't take Control- modifiers */
1114         if (! allow_extra_modifiers) return -1;
1115     }
1116
1117   if (event->event.key.modifiers & XEMACS_MOD_META)
1118     {
1119       if (! allow_meta) return -1;
1120       if (c & 0200) return -1;          /* don't allow M-oslash (overlap) */
1121 #ifdef MULE
1122       if (c >= 256) return -1;
1123 #endif
1124       c |= 0200;
1125     }
1126   return c;
1127 }
1128
1129 DEFUN ("event-to-character", Fevent_to_character, 1, 4, 0, /*
1130 Return the closest ASCII approximation to the given event object.
1131 If the event isn't a keypress, this returns nil.
1132 If the ALLOW-EXTRA-MODIFIERS argument is non-nil, then this is lenient in
1133  its translation; it will ignore modifier keys other than control and meta,
1134  and will ignore the shift modifier on those characters which have no
1135  shifted ASCII equivalent (Control-Shift-A for example, will be mapped to
1136  the same ASCII code as Control-A).
1137 If the ALLOW-META argument is non-nil, then the Meta modifier will be
1138  represented by turning on the high bit of the byte returned; otherwise, nil
1139  will be returned for events containing the Meta modifier.
1140 If the ALLOW-NON-ASCII argument is non-nil, then characters which are
1141  present in the prevailing character set (see the `character-set-property'
1142  variable) will be returned as their code in that character set, instead of
1143  the return value being restricted to ASCII.
1144 Note that specifying both ALLOW-META and ALLOW-NON-ASCII is ambiguous, as
1145  both use the high bit; `M-x' and `oslash' will be indistinguishable.
1146 */
1147      (event, allow_extra_modifiers, allow_meta, allow_non_ascii))
1148 {
1149   Emchar c;
1150   CHECK_LIVE_EVENT (event);
1151   c = event_to_character (XEVENT (event),
1152                           !NILP (allow_extra_modifiers),
1153                           !NILP (allow_meta),
1154                           !NILP (allow_non_ascii));
1155   return c < 0 ? Qnil : make_char (c);
1156 }
1157
1158 DEFUN ("character-to-event", Fcharacter_to_event, 1, 4, 0, /*
1159 Convert KEY-DESCRIPTION into an event structure, replete with bucky bits.
1160
1161 KEY-DESCRIPTION is the first argument, and the event to fill in is the
1162 second.  This function contains knowledge about what various kinds of
1163 arguments ``mean'' -- for example, the number 9 is converted to the
1164 character ``Tab'', not the distinct character ``Control-I''.
1165
1166 KEY-DESCRIPTION can be an integer, a character, a symbol such as 'clear,
1167 or a list such as '(control backspace).
1168
1169 If the optional second argument EVENT is an event, it is modified and
1170 returned; otherwise, a new event object is created and returned.
1171
1172 Optional third arg CONSOLE is the console to store in the event, and
1173 defaults to the selected console.
1174
1175 If KEY-DESCRIPTION is an integer or character, the high bit may be
1176 interpreted as the meta key. (This is done for backward compatibility
1177 in lots of places.)  If USE-CONSOLE-META-FLAG is nil, this will always
1178 be the case.  If USE-CONSOLE-META-FLAG is non-nil, the `meta' flag for
1179 CONSOLE affects whether the high bit is interpreted as a meta
1180 key. (See `set-input-mode'.)  If you don't want this silly meta
1181 interpretation done, you should pass in a list containing the
1182 character.
1183
1184 Beware that character-to-event and event-to-character are not strictly
1185 inverse functions, since events contain much more information than the
1186 Lisp character object type can encode.
1187 */
1188        (keystroke, event, console, use_console_meta_flag))
1189 {
1190   struct console *con = decode_console (console);
1191   if (NILP (event))
1192     event = Fmake_event (Qnil, Qnil);
1193   else
1194     CHECK_LIVE_EVENT (event);
1195   if (CONSP (keystroke) || SYMBOLP (keystroke))
1196     key_desc_list_to_event (keystroke, event, 1);
1197   else
1198     {
1199       CHECK_CHAR_COERCE_INT (keystroke);
1200       character_to_event (XCHAR (keystroke), XEVENT (event), con,
1201                           !NILP (use_console_meta_flag), 1);
1202     }
1203   return event;
1204 }
1205
1206 void
1207 nth_of_key_sequence_as_event (Lisp_Object seq, int n, Lisp_Object event)
1208 {
1209   assert (STRINGP (seq) || VECTORP (seq));
1210   assert (n < XINT (Flength (seq)));
1211
1212   if (STRINGP (seq))
1213     {
1214       Emchar ch = string_char (XSTRING (seq), n);
1215       Fcharacter_to_event (make_char (ch), event, Qnil, Qnil);
1216     }
1217   else
1218     {
1219       Lisp_Object keystroke = XVECTOR_DATA (seq)[n];
1220       if (EVENTP (keystroke))
1221         Fcopy_event (keystroke, event);
1222       else
1223         Fcharacter_to_event (keystroke, event, Qnil, Qnil);
1224     }
1225 }
1226
1227 Lisp_Object
1228 key_sequence_to_event_chain (Lisp_Object seq)
1229 {
1230   int len = XINT (Flength (seq));
1231   int i;
1232   Lisp_Object head = Qnil, tail = Qnil;
1233
1234   for (i = 0; i < len; i++)
1235     {
1236       Lisp_Object event = Fmake_event (Qnil, Qnil);
1237       nth_of_key_sequence_as_event (seq, i, event);
1238       enqueue_event (event, &head, &tail);
1239     }
1240
1241   return head;
1242 }
1243
1244 void
1245 format_event_object (char *buf, Lisp_Event *event, int brief)
1246 {
1247   int mouse_p = 0;
1248   int mod = 0;
1249   Lisp_Object key;
1250
1251   switch (event->event_type)
1252     {
1253     case key_press_event:
1254       {
1255         mod = event->event.key.modifiers;
1256         key = event->event.key.keysym;
1257         /* Hack. */
1258         if (! brief && CHARP (key) &&
1259             mod & (XEMACS_MOD_CONTROL | XEMACS_MOD_META | XEMACS_MOD_SUPER | XEMACS_MOD_HYPER))
1260         {
1261           int k = XCHAR (key);
1262           if (k >= 'a' && k <= 'z')
1263             key = make_char (k - ('a' - 'A'));
1264           else if (k >= 'A' && k <= 'Z')
1265             mod |= XEMACS_MOD_SHIFT;
1266         }
1267         break;
1268       }
1269     case button_release_event:
1270       mouse_p++;
1271       /* Fall through */
1272     case button_press_event:
1273       {
1274         mouse_p++;
1275         mod = event->event.button.modifiers;
1276         key = make_char (event->event.button.button + '0');
1277         break;
1278       }
1279     case magic_event:
1280       {
1281         const char *name = NULL;
1282
1283 #ifdef HAVE_GTK
1284         {
1285           Lisp_Object console = CDFW_CONSOLE (EVENT_CHANNEL (event));
1286           if (CONSOLE_GTK_P (XCONSOLE (console)))
1287             name = gtk_event_name (event->event.magic.underlying_gdk_event.type);
1288         }
1289 #endif
1290 #ifdef HAVE_X_WINDOWS
1291         {
1292           Lisp_Object console = CDFW_CONSOLE (EVENT_CHANNEL (event));
1293           if (CONSOLE_X_P (XCONSOLE (console)))
1294             name = x_event_name (event->event.magic.underlying_x_event.type);
1295         }
1296 #endif /* HAVE_X_WINDOWS */
1297         if (name) strcpy (buf, name);
1298         else strcpy (buf, "???");
1299         return;
1300       }
1301     case magic_eval_event:      strcpy (buf, "magic-eval"); return;
1302     case pointer_motion_event:  strcpy (buf, "motion");     return;
1303     case misc_user_event:       strcpy (buf, "misc-user");  return;
1304     case eval_event:            strcpy (buf, "eval");       return;
1305     case process_event:         strcpy (buf, "process");    return;
1306     case timeout_event:         strcpy (buf, "timeout");    return;
1307     case empty_event:           strcpy (buf, "empty");      return;
1308     case dead_event:            strcpy (buf, "DEAD-EVENT"); return;
1309     default:
1310       abort ();
1311       return;
1312     }
1313 #define modprint1(x)  do { strcpy (buf, (x)); buf += sizeof (x)-1; } while (0)
1314 #define modprint(x,y) do { if (brief) modprint1 (y); else modprint1 (x); } while (0)
1315   if (mod & XEMACS_MOD_CONTROL) modprint ("control-", "C-");
1316   if (mod & XEMACS_MOD_META)    modprint ("meta-",    "M-");
1317   if (mod & XEMACS_MOD_SUPER)   modprint ("super-",   "S-");
1318   if (mod & XEMACS_MOD_HYPER)   modprint ("hyper-",   "H-");
1319   if (mod & XEMACS_MOD_ALT)     modprint ("alt-",     "A-");
1320   if (mod & XEMACS_MOD_SHIFT)   modprint ("shift-",   "Sh-");
1321   if (mouse_p)
1322     {
1323       modprint1 ("button");
1324       --mouse_p;
1325     }
1326
1327 #undef modprint
1328 #undef modprint1
1329
1330   if (CHARP (key))
1331     {
1332       buf += set_charptr_emchar ((Bufbyte *) buf, XCHAR (key));
1333       *buf = 0;
1334     }
1335   else if (SYMBOLP (key))
1336     {
1337       const char *str = 0;
1338       if (brief)
1339         {
1340           if      (EQ (key, QKlinefeed))  str = "LFD";
1341           else if (EQ (key, QKtab))       str = "TAB";
1342           else if (EQ (key, QKreturn))    str = "RET";
1343           else if (EQ (key, QKescape))    str = "ESC";
1344           else if (EQ (key, QKdelete))    str = "DEL";
1345           else if (EQ (key, QKspace))     str = "SPC";
1346           else if (EQ (key, QKbackspace)) str = "BS";
1347         }
1348       if (str)
1349         {
1350           int i = strlen (str);
1351           memcpy (buf, str, i+1);
1352           str += i;
1353         }
1354       else
1355         {
1356           Lisp_String *name = XSYMBOL (key)->name;
1357           memcpy (buf, string_data (name), string_length (name) + 1);
1358           str += string_length (name);
1359         }
1360     }
1361   else
1362     abort ();
1363   if (mouse_p)
1364     strncpy (buf, "up", 4);
1365 }
1366
1367 DEFUN ("eventp", Feventp, 1, 1, 0, /*
1368 True if OBJECT is an event object.
1369 */
1370        (object))
1371 {
1372   return EVENTP (object) ? Qt : Qnil;
1373 }
1374
1375 DEFUN ("event-live-p", Fevent_live_p, 1, 1, 0, /*
1376 True if OBJECT is an event object that has not been deallocated.
1377 */
1378        (object))
1379 {
1380   return EVENTP (object) && XEVENT (object)->event_type != dead_event ?
1381     Qt : Qnil;
1382 }
1383
1384 #if 0 /* debugging functions */
1385
1386 xxDEFUN ("event-next", Fevent_next, 1, 1, 0, /*
1387 Return the event object's `next' event, or nil if it has none.
1388 The `next-event' field is changed by calling `set-next-event'.
1389 */
1390          (event))
1391 {
1392   Lisp_Event *e;
1393   CHECK_LIVE_EVENT (event);
1394
1395   return XEVENT_NEXT (event);
1396 }
1397
1398 xxDEFUN ("set-event-next", Fset_event_next, 2, 2, 0, /*
1399 Set the `next event' of EVENT to NEXT-EVENT.
1400 NEXT-EVENT must be an event object or nil.
1401 */
1402          (event, next_event))
1403 {
1404   Lisp_Object ev;
1405
1406   CHECK_LIVE_EVENT (event);
1407   if (NILP (next_event))
1408     {
1409       XSET_EVENT_NEXT (event, Qnil);
1410       return Qnil;
1411     }
1412
1413   CHECK_LIVE_EVENT (next_event);
1414
1415   EVENT_CHAIN_LOOP (ev, XEVENT_NEXT (event))
1416     {
1417       QUIT;
1418       if (EQ (ev, event))
1419         signal_error (Qerror,
1420                       list3 (build_string ("Cyclic event-next"),
1421                              event,
1422                              next_event));
1423     }
1424   XSET_EVENT_NEXT (event, next_event);
1425   return next_event;
1426 }
1427
1428 #endif /* 0 */
1429
1430 DEFUN ("event-type", Fevent_type, 1, 1, 0, /*
1431 Return the type of EVENT.
1432 This will be a symbol; one of
1433
1434 key-press       A key was pressed.
1435 button-press    A mouse button was pressed.
1436 button-release  A mouse button was released.
1437 misc-user       Some other user action happened; typically, this is
1438                 a menu selection or scrollbar action.
1439 motion          The mouse moved.
1440 process         Input is available from a subprocess.
1441 timeout         A timeout has expired.
1442 eval            This causes a specified action to occur when dispatched.
1443 magic           Some window-system-specific event has occurred.
1444 empty           The event has been allocated but not assigned.
1445
1446 */
1447        (event))
1448 {
1449   CHECK_LIVE_EVENT (event);
1450   switch (XEVENT (event)->event_type)
1451     {
1452     case key_press_event:       return Qkey_press;
1453     case button_press_event:    return Qbutton_press;
1454     case button_release_event:  return Qbutton_release;
1455     case misc_user_event:       return Qmisc_user;
1456     case pointer_motion_event:  return Qmotion;
1457     case process_event:         return Qprocess;
1458     case timeout_event:         return Qtimeout;
1459     case eval_event:            return Qeval;
1460     case magic_event:
1461     case magic_eval_event:
1462       return Qmagic;
1463
1464     case empty_event:
1465       return Qempty;
1466
1467     default:
1468       abort ();
1469       return Qnil;
1470     }
1471 }
1472
1473 DEFUN ("event-timestamp", Fevent_timestamp, 1, 1, 0, /*
1474 Return the timestamp of the event object EVENT.
1475 Timestamps are measured in milliseconds since the start of the window system.
1476 They are NOT related to any current time measurement.
1477 They should be compared with `event-timestamp<'.
1478 See also `current-event-timestamp'.
1479 */
1480        (event))
1481 {
1482   CHECK_LIVE_EVENT (event);
1483   /* This junk is so that timestamps don't get to be negative, but contain
1484      as many bits as this particular emacs will allow.
1485    */
1486   return make_int (((1L << (VALBITS - 1)) - 1) &
1487                       XEVENT (event)->timestamp);
1488 }
1489
1490 #define TIMESTAMP_HALFSPACE (1L << (VALBITS - 2))
1491
1492 DEFUN ("event-timestamp<", Fevent_timestamp_lessp, 2, 2, 0, /*
1493 Return true if timestamp TIME1 is earlier than timestamp TIME2.
1494 This correctly handles timestamp wrap.
1495 See also `event-timestamp' and `current-event-timestamp'.
1496 */
1497        (time1, time2))
1498 {
1499   EMACS_INT t1, t2;
1500
1501   CHECK_NATNUM (time1);
1502   CHECK_NATNUM (time2);
1503   t1 = XINT (time1);
1504   t2 = XINT (time2);
1505
1506   if (t1 < t2)
1507     return t2 - t1 < TIMESTAMP_HALFSPACE ? Qt : Qnil;
1508   else
1509     return t1 - t2 < TIMESTAMP_HALFSPACE ? Qnil : Qt;
1510 }
1511
1512 #define CHECK_EVENT_TYPE(e,t1,sym) do {         \
1513   CHECK_LIVE_EVENT (e);                         \
1514   if (XEVENT(e)->event_type != (t1))            \
1515     e = wrong_type_argument (sym,e);            \
1516 } while (0)
1517
1518 #define CHECK_EVENT_TYPE2(e,t1,t2,sym) do {             \
1519   CHECK_LIVE_EVENT (e);                                 \
1520   {                                                     \
1521     emacs_event_type CET_type = XEVENT (e)->event_type; \
1522     if (CET_type != (t1) &&                             \
1523         CET_type != (t2))                               \
1524       e = wrong_type_argument (sym,e);                  \
1525   }                                                     \
1526 } while (0)
1527
1528 #define CHECK_EVENT_TYPE3(e,t1,t2,t3,sym) do {          \
1529   CHECK_LIVE_EVENT (e);                                 \
1530   {                                                     \
1531     emacs_event_type CET_type = XEVENT (e)->event_type; \
1532     if (CET_type != (t1) &&                             \
1533         CET_type != (t2) &&                             \
1534         CET_type != (t3))                               \
1535       e = wrong_type_argument (sym,e);                  \
1536   }                                                     \
1537 } while (0)
1538
1539 DEFUN ("event-key", Fevent_key, 1, 1, 0, /*
1540 Return the Keysym of the key-press event EVENT.
1541 This will be a character if the event is associated with one, else a symbol.
1542 */
1543        (event))
1544 {
1545   CHECK_EVENT_TYPE (event, key_press_event, Qkey_press_event_p);
1546   return XEVENT (event)->event.key.keysym;
1547 }
1548
1549 DEFUN ("event-button", Fevent_button, 1, 1, 0, /*
1550 Return the button-number of the button-press or button-release event EVENT.
1551 */
1552        (event))
1553 {
1554
1555   CHECK_EVENT_TYPE3 (event, button_press_event, button_release_event,
1556                      misc_user_event, Qbutton_event_p);
1557 #ifdef HAVE_WINDOW_SYSTEM
1558   if ( XEVENT (event)->event_type == misc_user_event)
1559     return make_int (XEVENT (event)->event.misc.button);
1560   else
1561     return make_int (XEVENT (event)->event.button.button);
1562 #else /* !HAVE_WINDOW_SYSTEM */
1563   return Qzero;
1564 #endif /* !HAVE_WINDOW_SYSTEM */
1565
1566 }
1567
1568 DEFUN ("event-modifier-bits", Fevent_modifier_bits, 1, 1, 0, /*
1569 Return a number representing the modifier keys and buttons which were down
1570 when the given mouse or keyboard event was produced.
1571 See also the function `event-modifiers'.
1572 */
1573        (event))
1574 {
1575  again:
1576   CHECK_LIVE_EVENT (event);
1577   switch (XEVENT (event)->event_type)
1578     {
1579     case key_press_event:
1580       return make_int (XEVENT (event)->event.key.modifiers);
1581     case button_press_event:
1582     case button_release_event:
1583       return make_int (XEVENT (event)->event.button.modifiers);
1584     case pointer_motion_event:
1585       return make_int (XEVENT (event)->event.motion.modifiers);
1586     case misc_user_event:
1587       return make_int (XEVENT (event)->event.misc.modifiers);
1588     default:
1589       event = wrong_type_argument (intern ("key-or-mouse-event-p"), event);
1590       goto again;
1591     }
1592 }
1593
1594 DEFUN ("event-modifiers", Fevent_modifiers, 1, 1, 0, /*
1595 Return a list of symbols, the names of the modifier keys and buttons
1596 which were down when the given mouse or keyboard event was produced.
1597 See also the function `event-modifier-bits'.
1598
1599 The possible symbols in the list are
1600
1601 `shift':     The Shift key.  Will not appear, in general, on key events
1602              where the keysym is an ASCII character, because using Shift
1603              on such a character converts it into another character rather
1604              than actually just adding a Shift modifier.
1605
1606 `control':   The Control key.
1607
1608 `meta':      The Meta key.  On PC's and PC-style keyboards, this is generally
1609              labelled \"Alt\"; Meta is a holdover from early Lisp Machines and
1610              such, propagated through the X Window System.  On Sun keyboards,
1611              this key is labelled with a diamond.
1612
1613 `alt':       The \"Alt\" key.  Alt is in quotes because this does not refer
1614              to what it obviously should refer to, namely the Alt key on PC
1615              keyboards.  Instead, it refers to the key labelled Alt on Sun
1616              keyboards, and to no key at all on PC keyboards.
1617
1618 `super':     The Super key.  Most keyboards don't have any such key, but
1619              under X Windows using `xmodmap' you can assign any key (such as
1620              an underused right-shift, right-control, or right-alt key) to
1621              this key modifier.  No support currently exists under MS Windows
1622              for generating these modifiers.
1623
1624 `hyper':     The Hyper key.  Works just like the Super key.
1625
1626 `button1':   The mouse buttons.  This means that the specified button was held
1627 `button2':   down at the time the event occurred.  NOTE: For button-press
1628 `button3':   events, the button that was just pressed down does NOT appear in
1629 `button4':   the modifiers.
1630 `button5':
1631
1632 Button modifiers are currently ignored when defining and looking up key and
1633 mouse strokes in keymaps.  This could be changed, which would allow a user to
1634 create button-chord actions, use a button as a key modifier and do other
1635 clever things.
1636 */
1637        (event))
1638 {
1639   int mod = XINT (Fevent_modifier_bits (event));
1640   Lisp_Object result = Qnil;
1641   struct gcpro gcpro1;
1642
1643   GCPRO1 (result);
1644   if (mod & XEMACS_MOD_SHIFT)   result = Fcons (Qshift, result);
1645   if (mod & XEMACS_MOD_ALT)     result = Fcons (Qalt, result);
1646   if (mod & XEMACS_MOD_HYPER)   result = Fcons (Qhyper, result);
1647   if (mod & XEMACS_MOD_SUPER)   result = Fcons (Qsuper, result);
1648   if (mod & XEMACS_MOD_META)    result = Fcons (Qmeta, result);
1649   if (mod & XEMACS_MOD_CONTROL) result = Fcons (Qcontrol, result);
1650   if (mod & XEMACS_MOD_BUTTON1) result = Fcons (Qbutton1, result);
1651   if (mod & XEMACS_MOD_BUTTON2) result = Fcons (Qbutton2, result);
1652   if (mod & XEMACS_MOD_BUTTON3) result = Fcons (Qbutton3, result);
1653   if (mod & XEMACS_MOD_BUTTON4) result = Fcons (Qbutton4, result);
1654   if (mod & XEMACS_MOD_BUTTON5) result = Fcons (Qbutton5, result);
1655   RETURN_UNGCPRO (Fnreverse (result));
1656 }
1657
1658 static int
1659 event_x_y_pixel_internal (Lisp_Object event, int *x, int *y, int relative)
1660 {
1661   struct window *w;
1662   struct frame *f;
1663
1664   if (XEVENT (event)->event_type == pointer_motion_event)
1665     {
1666       *x = XEVENT (event)->event.motion.x;
1667       *y = XEVENT (event)->event.motion.y;
1668     }
1669   else if (XEVENT (event)->event_type == button_press_event ||
1670            XEVENT (event)->event_type == button_release_event)
1671     {
1672       *x = XEVENT (event)->event.button.x;
1673       *y = XEVENT (event)->event.button.y;
1674     }
1675   else if (XEVENT (event)->event_type == misc_user_event)
1676     {
1677       *x = XEVENT (event)->event.misc.x;
1678       *y = XEVENT (event)->event.misc.y;
1679     }
1680   else
1681     return 0;
1682
1683   f = XFRAME (EVENT_CHANNEL (XEVENT (event)));
1684
1685   if (relative)
1686     {
1687       w = find_window_by_pixel_pos (*x, *y, f->root_window);
1688
1689       if (!w)
1690         return 1;       /* #### What should really happen here? */
1691
1692       *x -= w->pixel_left;
1693       *y -= w->pixel_top;
1694     }
1695   else
1696     {
1697       *y -= FRAME_REAL_TOP_TOOLBAR_HEIGHT (f) -
1698         FRAME_REAL_TOP_TOOLBAR_BORDER_WIDTH (f);
1699       *x -= FRAME_REAL_LEFT_TOOLBAR_WIDTH (f) -
1700         FRAME_REAL_LEFT_TOOLBAR_BORDER_WIDTH (f);
1701     }
1702
1703   return 1;
1704 }
1705
1706 DEFUN ("event-window-x-pixel", Fevent_window_x_pixel, 1, 1, 0, /*
1707 Return the X position in pixels of mouse event EVENT.
1708 The value returned is relative to the window the event occurred in.
1709 This will signal an error if the event is not a mouse event.
1710 See also `mouse-event-p' and `event-x-pixel'.
1711 */
1712        (event))
1713 {
1714   int x, y;
1715
1716   CHECK_LIVE_EVENT (event);
1717
1718   if (!event_x_y_pixel_internal (event, &x, &y, 1))
1719     return wrong_type_argument (Qmouse_event_p, event);
1720   else
1721     return make_int (x);
1722 }
1723
1724 DEFUN ("event-window-y-pixel", Fevent_window_y_pixel, 1, 1, 0, /*
1725 Return the Y position in pixels of mouse event EVENT.
1726 The value returned is relative to the window the event occurred in.
1727 This will signal an error if the event is not a mouse event.
1728 See also `mouse-event-p' and `event-y-pixel'.
1729 */
1730        (event))
1731 {
1732   int x, y;
1733
1734   CHECK_LIVE_EVENT (event);
1735
1736   if (!event_x_y_pixel_internal (event, &x, &y, 1))
1737     return wrong_type_argument (Qmouse_event_p, event);
1738   else
1739     return make_int (y);
1740 }
1741
1742 DEFUN ("event-x-pixel", Fevent_x_pixel, 1, 1, 0, /*
1743 Return the X position in pixels of mouse event EVENT.
1744 The value returned is relative to the frame the event occurred in.
1745 This will signal an error if the event is not a mouse event.
1746 See also `mouse-event-p' and `event-window-x-pixel'.
1747 */
1748        (event))
1749 {
1750   int x, y;
1751
1752   CHECK_LIVE_EVENT (event);
1753
1754   if (!event_x_y_pixel_internal (event, &x, &y, 0))
1755     return wrong_type_argument (Qmouse_event_p, event);
1756   else
1757     return make_int (x);
1758 }
1759
1760 DEFUN ("event-y-pixel", Fevent_y_pixel, 1, 1, 0, /*
1761 Return the Y position in pixels of mouse event EVENT.
1762 The value returned is relative to the frame the event occurred in.
1763 This will signal an error if the event is not a mouse event.
1764 See also `mouse-event-p' `event-window-y-pixel'.
1765 */
1766        (event))
1767 {
1768   int x, y;
1769
1770   CHECK_LIVE_EVENT (event);
1771
1772   if (!event_x_y_pixel_internal (event, &x, &y, 0))
1773     return wrong_type_argument (Qmouse_event_p, event);
1774   else
1775     return make_int (y);
1776 }
1777
1778 /* Given an event, return a value:
1779
1780      OVER_TOOLBAR:      over one of the 4 frame toolbars
1781      OVER_MODELINE:     over a modeline
1782      OVER_BORDER:       over an internal border
1783      OVER_NOTHING:      over the text area, but not over text
1784      OVER_OUTSIDE:      outside of the frame border
1785      OVER_TEXT:         over text in the text area
1786      OVER_V_DIVIDER:    over windows vertical divider
1787
1788    and return:
1789
1790    The X char position in CHAR_X, if not a null pointer.
1791    The Y char position in CHAR_Y, if not a null pointer.
1792    (These last two values are relative to the window the event is over.)
1793    The window it's over in W, if not a null pointer.
1794    The buffer position it's over in BUFP, if not a null pointer.
1795    The closest buffer position in CLOSEST, if not a null pointer.
1796
1797    OBJ_X, OBJ_Y, OBJ1, and OBJ2 are as in pixel_to_glyph_translation().
1798 */
1799
1800 static int
1801 event_pixel_translation (Lisp_Object event, int *char_x, int *char_y,
1802                          int *obj_x, int *obj_y,
1803                          struct window **w, Bufpos *bufp, Bufpos *closest,
1804                          Charcount *modeline_closest,
1805                          Lisp_Object *obj1, Lisp_Object *obj2)
1806 {
1807   int pix_x = 0;
1808   int pix_y = 0;
1809   int result;
1810   Lisp_Object frame;
1811
1812   int ret_x, ret_y, ret_obj_x, ret_obj_y;
1813   struct window *ret_w;
1814   Bufpos ret_bufp, ret_closest;
1815   Charcount ret_modeline_closest;
1816   Lisp_Object ret_obj1, ret_obj2;
1817
1818   CHECK_LIVE_EVENT (event);
1819   frame = XEVENT (event)->channel;
1820   switch (XEVENT (event)->event_type)
1821     {
1822     case pointer_motion_event :
1823       pix_x = XEVENT (event)->event.motion.x;
1824       pix_y = XEVENT (event)->event.motion.y;
1825       break;
1826     case button_press_event :
1827     case button_release_event :
1828       pix_x = XEVENT (event)->event.button.x;
1829       pix_y = XEVENT (event)->event.button.y;
1830       break;
1831     case misc_user_event :
1832       pix_x = XEVENT (event)->event.misc.x;
1833       pix_y = XEVENT (event)->event.misc.y;
1834       break;
1835     default:
1836       dead_wrong_type_argument (Qmouse_event_p, event);
1837     }
1838
1839   result = pixel_to_glyph_translation (XFRAME (frame), pix_x, pix_y,
1840                                        &ret_x, &ret_y, &ret_obj_x, &ret_obj_y,
1841                                        &ret_w, &ret_bufp, &ret_closest,
1842                                        &ret_modeline_closest,
1843                                        &ret_obj1, &ret_obj2);
1844
1845   if (result == OVER_NOTHING || result == OVER_OUTSIDE)
1846     ret_bufp = 0;
1847   else if (ret_w && NILP (ret_w->buffer))
1848     /* Why does this happen?  (Does it still happen?)
1849        I guess the window has gotten reused as a non-leaf... */
1850     ret_w = 0;
1851
1852   /* #### pixel_to_glyph_translation() sometimes returns garbage...
1853      The word has type Lisp_Type_Record (presumably meaning `extent') but the
1854      pointer points to random memory, often filled with 0, sometimes not.
1855    */
1856   /* #### Chuck, do we still need this crap? */
1857   if (!NILP (ret_obj1) && !(GLYPHP (ret_obj1)
1858 #ifdef HAVE_TOOLBARS
1859                             || TOOLBAR_BUTTONP (ret_obj1)
1860 #endif
1861      ))
1862     abort ();
1863   if (!NILP (ret_obj2) && !(EXTENTP (ret_obj2) || CONSP (ret_obj2)))
1864     abort ();
1865
1866   if (char_x)
1867     *char_x = ret_x;
1868   if (char_y)
1869     *char_y = ret_y;
1870   if (obj_x)
1871     *obj_x = ret_obj_x;
1872   if (obj_y)
1873     *obj_y = ret_obj_y;
1874   if (w)
1875     *w = ret_w;
1876   if (bufp)
1877     *bufp = ret_bufp;
1878   if (closest)
1879     *closest = ret_closest;
1880   if (modeline_closest)
1881     *modeline_closest = ret_modeline_closest;
1882   if (obj1)
1883     *obj1 = ret_obj1;
1884   if (obj2)
1885     *obj2 = ret_obj2;
1886
1887   return result;
1888 }
1889
1890 DEFUN ("event-over-text-area-p", Fevent_over_text_area_p, 1, 1, 0, /*
1891 Return t if the mouse event EVENT occurred over the text area of a window.
1892 The modeline is not considered to be part of the text area.
1893 */
1894        (event))
1895 {
1896   int result = event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1897
1898   return result == OVER_TEXT || result == OVER_NOTHING ? Qt : Qnil;
1899 }
1900
1901 DEFUN ("event-over-modeline-p", Fevent_over_modeline_p, 1, 1, 0, /*
1902 Return t if the mouse event EVENT occurred over the modeline of a window.
1903 */
1904        (event))
1905 {
1906   int result = event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1907
1908   return result == OVER_MODELINE ? Qt : Qnil;
1909 }
1910
1911 DEFUN ("event-over-border-p", Fevent_over_border_p, 1, 1, 0, /*
1912 Return t if the mouse event EVENT occurred over an internal border.
1913 */
1914        (event))
1915 {
1916   int result = event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1917
1918   return result == OVER_BORDER ? Qt : Qnil;
1919 }
1920
1921 DEFUN ("event-over-toolbar-p", Fevent_over_toolbar_p, 1, 1, 0, /*
1922 Return t if the mouse event EVENT occurred over a toolbar.
1923 */
1924        (event))
1925 {
1926   int result = event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1927
1928   return result == OVER_TOOLBAR ? Qt : Qnil;
1929 }
1930
1931 DEFUN ("event-over-vertical-divider-p", Fevent_over_vertical_divider_p, 1, 1, 0, /*
1932 Return t if the mouse event EVENT occurred over a window divider.
1933 */
1934        (event))
1935 {
1936   int result = event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1937
1938   return result == OVER_V_DIVIDER ? Qt : Qnil;
1939 }
1940
1941 struct console *
1942 event_console_or_selected (Lisp_Object event)
1943 {
1944   Lisp_Object channel = EVENT_CHANNEL (XEVENT (event));
1945   Lisp_Object console = CDFW_CONSOLE (channel);
1946
1947   if (NILP (console))
1948     console = Vselected_console;
1949
1950   return XCONSOLE (console);
1951 }
1952
1953 DEFUN ("event-channel", Fevent_channel, 1, 1, 0, /*
1954 Return the channel that the event EVENT occurred on.
1955 This will be a frame, device, console, or nil for some types
1956 of events (e.g. eval events).
1957 */
1958        (event))
1959 {
1960   CHECK_LIVE_EVENT (event);
1961   return EVENT_CHANNEL (XEVENT (event));
1962 }
1963
1964 DEFUN ("event-window", Fevent_window, 1, 1, 0, /*
1965 Return the window over which mouse event EVENT occurred.
1966 This may be nil if the event occurred in the border or over a toolbar.
1967 The modeline is considered to be within the window it describes.
1968 */
1969        (event))
1970 {
1971   struct window *w;
1972
1973   event_pixel_translation (event, 0, 0, 0, 0, &w, 0, 0, 0, 0, 0);
1974
1975   if (!w)
1976     return Qnil;
1977   else
1978     {
1979       Lisp_Object window;
1980
1981       XSETWINDOW (window, w);
1982       return window;
1983     }
1984 }
1985
1986 DEFUN ("event-point", Fevent_point, 1, 1, 0, /*
1987 Return the character position of the mouse event EVENT.
1988 If the event did not occur over a window, or did not occur over text,
1989 then this returns nil.  Otherwise, it returns a position in the buffer
1990 visible in the event's window.
1991 */
1992        (event))
1993 {
1994   Bufpos bufp;
1995   struct window *w;
1996
1997   event_pixel_translation (event, 0, 0, 0, 0, &w, &bufp, 0, 0, 0, 0);
1998
1999   return w && bufp ? make_int (bufp) : Qnil;
2000 }
2001
2002 DEFUN ("event-closest-point", Fevent_closest_point, 1, 1, 0, /*
2003 Return the character position closest to the mouse event EVENT.
2004 If the event did not occur over a window or over text, return the
2005 closest point to the location of the event.  If the Y pixel position
2006 overlaps a window and the X pixel position is to the left of that
2007 window, the closest point is the beginning of the line containing the
2008 Y position.  If the Y pixel position overlaps a window and the X pixel
2009 position is to the right of that window, the closest point is the end
2010 of the line containing the Y position.  If the Y pixel position is
2011 above a window, return 0.  If it is below the last character in a window,
2012 return the value of (window-end).
2013 */
2014        (event))
2015 {
2016   Bufpos bufp;
2017
2018   event_pixel_translation (event, 0, 0, 0, 0, 0, 0, &bufp, 0, 0, 0);
2019
2020   return bufp ? make_int (bufp) : Qnil;
2021 }
2022
2023 DEFUN ("event-x", Fevent_x, 1, 1, 0, /*
2024 Return the X position of the mouse event EVENT in characters.
2025 This is relative to the window the event occurred over.
2026 */
2027        (event))
2028 {
2029   int char_x;
2030
2031   event_pixel_translation (event, &char_x, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2032
2033   return make_int (char_x);
2034 }
2035
2036 DEFUN ("event-y", Fevent_y, 1, 1, 0, /*
2037 Return the Y position of the mouse event EVENT in characters.
2038 This is relative to the window the event occurred over.
2039 */
2040        (event))
2041 {
2042   int char_y;
2043
2044   event_pixel_translation (event, 0, &char_y, 0, 0, 0, 0, 0, 0, 0, 0);
2045
2046   return make_int (char_y);
2047 }
2048
2049 DEFUN ("event-modeline-position", Fevent_modeline_position, 1, 1, 0, /*
2050 Return the character position in the modeline that EVENT occurred over.
2051 EVENT should be a mouse event.  If EVENT did not occur over a modeline,
2052 nil is returned.  You can determine the actual character that the
2053 event occurred over by looking in `generated-modeline-string' at the
2054 returned character position.  Note that `generated-modeline-string'
2055 is buffer-local, and you must use EVENT's buffer when retrieving
2056 `generated-modeline-string' in order to get accurate results.
2057 */
2058        (event))
2059 {
2060   Charcount mbufp;
2061   int where;
2062
2063   where = event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, &mbufp, 0, 0);
2064
2065   return (mbufp < 0 || where != OVER_MODELINE) ? Qnil : make_int (mbufp);
2066 }
2067
2068 DEFUN ("event-glyph", Fevent_glyph, 1, 1, 0, /*
2069 Return the glyph that the mouse event EVENT occurred over, or nil.
2070 */
2071        (event))
2072 {
2073   Lisp_Object glyph;
2074   struct window *w;
2075
2076   event_pixel_translation (event, 0, 0, 0, 0, &w, 0, 0, 0, &glyph, 0);
2077
2078   return w && GLYPHP (glyph) ? glyph : Qnil;
2079 }
2080
2081 DEFUN ("event-glyph-extent", Fevent_glyph_extent, 1, 1, 0, /*
2082 Return the extent of the glyph that the mouse event EVENT occurred over.
2083 If the event did not occur over a glyph, nil is returned.
2084 */
2085        (event))
2086 {
2087   Lisp_Object extent;
2088   struct window *w;
2089
2090   event_pixel_translation (event, 0, 0, 0, 0, &w, 0, 0, 0, 0, &extent);
2091
2092   return w && EXTENTP (extent) ? extent : Qnil;
2093 }
2094
2095 DEFUN ("event-glyph-x-pixel", Fevent_glyph_x_pixel, 1, 1, 0, /*
2096 Return the X pixel position of EVENT relative to the glyph it occurred over.
2097 EVENT should be a mouse event.  If the event did not occur over a glyph,
2098 nil is returned.
2099 */
2100        (event))
2101 {
2102   Lisp_Object extent;
2103   struct window *w;
2104   int obj_x;
2105
2106   event_pixel_translation (event, 0, 0, &obj_x, 0, &w, 0, 0, 0, 0, &extent);
2107
2108   return w && EXTENTP (extent) ? make_int (obj_x) : Qnil;
2109 }
2110
2111 DEFUN ("event-glyph-y-pixel", Fevent_glyph_y_pixel, 1, 1, 0, /*
2112 Return the Y pixel position of EVENT relative to the glyph it occurred over.
2113 EVENT should be a mouse event.  If the event did not occur over a glyph,
2114 nil is returned.
2115 */
2116        (event))
2117 {
2118   Lisp_Object extent;
2119   struct window *w;
2120   int obj_y;
2121
2122   event_pixel_translation (event, 0, 0, 0, &obj_y, &w, 0, 0, 0, 0, &extent);
2123
2124   return w && EXTENTP (extent) ? make_int (obj_y) : Qnil;
2125 }
2126
2127 DEFUN ("event-toolbar-button", Fevent_toolbar_button, 1, 1, 0, /*
2128 Return the toolbar button that the mouse event EVENT occurred over.
2129 If the event did not occur over a toolbar button, nil is returned.
2130 */
2131        (event))
2132 {
2133 #ifdef HAVE_TOOLBARS
2134   Lisp_Object button;
2135
2136   int result = event_pixel_translation (event, 0, 0, 0, 0, 0, 0, 0, 0, &button, 0);
2137
2138   return result == OVER_TOOLBAR && TOOLBAR_BUTTONP (button) ? button : Qnil;
2139 #else
2140   return Qnil;
2141 #endif
2142 }
2143
2144 DEFUN ("event-process", Fevent_process, 1, 1, 0, /*
2145 Return the process of the process-output event EVENT.
2146 */
2147        (event))
2148 {
2149   CHECK_EVENT_TYPE (event, process_event, Qprocess_event_p);
2150   return XEVENT (event)->event.process.process;
2151 }
2152
2153 DEFUN ("event-function", Fevent_function, 1, 1, 0, /*
2154 Return the callback function of EVENT.
2155 EVENT should be a timeout, misc-user, or eval event.
2156 */
2157        (event))
2158 {
2159  again:
2160   CHECK_LIVE_EVENT (event);
2161   switch (XEVENT (event)->event_type)
2162     {
2163     case timeout_event:
2164       return XEVENT (event)->event.timeout.function;
2165     case misc_user_event:
2166       return XEVENT (event)->event.misc.function;
2167     case eval_event:
2168       return XEVENT (event)->event.eval.function;
2169     default:
2170       event = wrong_type_argument (intern ("timeout-or-eval-event-p"), event);
2171       goto again;
2172     }
2173 }
2174
2175 DEFUN ("event-object", Fevent_object, 1, 1, 0, /*
2176 Return the callback function argument of EVENT.
2177 EVENT should be a timeout, misc-user, or eval event.
2178 */
2179        (event))
2180 {
2181  again:
2182   CHECK_LIVE_EVENT (event);
2183   switch (XEVENT (event)->event_type)
2184     {
2185     case timeout_event:
2186       return XEVENT (event)->event.timeout.object;
2187     case misc_user_event:
2188       return XEVENT (event)->event.misc.object;
2189     case eval_event:
2190       return XEVENT (event)->event.eval.object;
2191     default:
2192       event = wrong_type_argument (intern ("timeout-or-eval-event-p"), event);
2193       goto again;
2194     }
2195 }
2196
2197 DEFUN ("event-properties", Fevent_properties, 1, 1, 0, /*
2198 Return a list of all of the properties of EVENT.
2199 This is in the form of a property list (alternating keyword/value pairs).
2200 */
2201        (event))
2202 {
2203   Lisp_Object props = Qnil;
2204   Lisp_Event *e;
2205   struct gcpro gcpro1;
2206
2207   CHECK_LIVE_EVENT (event);
2208   e = XEVENT (event);
2209   GCPRO1 (props);
2210
2211   props = cons3 (Qtimestamp, Fevent_timestamp (event), props);
2212
2213   switch (e->event_type)
2214     {
2215     default: abort ();
2216
2217     case process_event:
2218       props = cons3 (Qprocess, e->event.process.process, props);
2219       break;
2220
2221     case timeout_event:
2222       props = cons3 (Qobject,   Fevent_object   (event), props);
2223       props = cons3 (Qfunction, Fevent_function (event), props);
2224       props = cons3 (Qid, make_int (e->event.timeout.id_number), props);
2225       break;
2226
2227     case key_press_event:
2228       props = cons3 (Qmodifiers, Fevent_modifiers (event), props);
2229       props = cons3 (Qkey,       Fevent_key       (event), props);
2230       break;
2231
2232     case button_press_event:
2233     case button_release_event:
2234       props = cons3 (Qy,         Fevent_y_pixel   (event), props);
2235       props = cons3 (Qx,         Fevent_x_pixel   (event), props);
2236       props = cons3 (Qmodifiers, Fevent_modifiers (event), props);
2237       props = cons3 (Qbutton,    Fevent_button    (event), props);
2238       break;
2239
2240     case pointer_motion_event:
2241       props = cons3 (Qmodifiers, Fevent_modifiers (event), props);
2242       props = cons3 (Qy,         Fevent_y_pixel   (event), props);
2243       props = cons3 (Qx,         Fevent_x_pixel   (event), props);
2244       break;
2245
2246     case misc_user_event:
2247       props = cons3 (Qobject,    Fevent_object  (event), props);
2248       props = cons3 (Qfunction,  Fevent_function (event), props);
2249       props = cons3 (Qy,         Fevent_y_pixel   (event), props);
2250       props = cons3 (Qx,         Fevent_x_pixel   (event), props);
2251       props = cons3 (Qmodifiers, Fevent_modifiers (event), props);
2252       props = cons3 (Qbutton,    Fevent_button    (event), props);
2253       break;
2254
2255     case eval_event:
2256       props = cons3 (Qobject,   Fevent_object   (event), props);
2257       props = cons3 (Qfunction, Fevent_function (event), props);
2258       break;
2259
2260     case magic_eval_event:
2261     case magic_event:
2262       break;
2263
2264     case empty_event:
2265       RETURN_UNGCPRO (Qnil);
2266       break;
2267     }
2268
2269   props = cons3 (Qchannel, Fevent_channel (event), props);
2270   UNGCPRO;
2271
2272   return props;
2273 }
2274
2275 \f
2276 /************************************************************************/
2277 /*                            initialization                            */
2278 /************************************************************************/
2279
2280 void
2281 syms_of_events (void)
2282 {
2283   INIT_LRECORD_IMPLEMENTATION (event);
2284
2285   DEFSUBR (Fcharacter_to_event);
2286   DEFSUBR (Fevent_to_character);
2287
2288   DEFSUBR (Fmake_event);
2289   DEFSUBR (Fdeallocate_event);
2290   DEFSUBR (Fcopy_event);
2291   DEFSUBR (Feventp);
2292   DEFSUBR (Fevent_live_p);
2293   DEFSUBR (Fevent_type);
2294   DEFSUBR (Fevent_properties);
2295
2296   DEFSUBR (Fevent_timestamp);
2297   DEFSUBR (Fevent_timestamp_lessp);
2298   DEFSUBR (Fevent_key);
2299   DEFSUBR (Fevent_button);
2300   DEFSUBR (Fevent_modifier_bits);
2301   DEFSUBR (Fevent_modifiers);
2302   DEFSUBR (Fevent_x_pixel);
2303   DEFSUBR (Fevent_y_pixel);
2304   DEFSUBR (Fevent_window_x_pixel);
2305   DEFSUBR (Fevent_window_y_pixel);
2306   DEFSUBR (Fevent_over_text_area_p);
2307   DEFSUBR (Fevent_over_modeline_p);
2308   DEFSUBR (Fevent_over_border_p);
2309   DEFSUBR (Fevent_over_toolbar_p);
2310   DEFSUBR (Fevent_over_vertical_divider_p);
2311   DEFSUBR (Fevent_channel);
2312   DEFSUBR (Fevent_window);
2313   DEFSUBR (Fevent_point);
2314   DEFSUBR (Fevent_closest_point);
2315   DEFSUBR (Fevent_x);
2316   DEFSUBR (Fevent_y);
2317   DEFSUBR (Fevent_modeline_position);
2318   DEFSUBR (Fevent_glyph);
2319   DEFSUBR (Fevent_glyph_extent);
2320   DEFSUBR (Fevent_glyph_x_pixel);
2321   DEFSUBR (Fevent_glyph_y_pixel);
2322   DEFSUBR (Fevent_toolbar_button);
2323   DEFSUBR (Fevent_process);
2324   DEFSUBR (Fevent_function);
2325   DEFSUBR (Fevent_object);
2326
2327   defsymbol (&Qeventp, "eventp");
2328   defsymbol (&Qevent_live_p, "event-live-p");
2329   defsymbol (&Qkey_press_event_p, "key-press-event-p");
2330   defsymbol (&Qbutton_event_p, "button-event-p");
2331   defsymbol (&Qmouse_event_p, "mouse-event-p");
2332   defsymbol (&Qprocess_event_p, "process-event-p");
2333   defsymbol (&Qkey_press, "key-press");
2334   defsymbol (&Qbutton_press, "button-press");
2335   defsymbol (&Qbutton_release, "button-release");
2336   defsymbol (&Qmisc_user, "misc-user");
2337   defsymbol (&Qascii_character, "ascii-character");
2338
2339   defsymbol (&QKbackspace, "backspace");
2340   defsymbol (&QKtab, "tab");
2341   defsymbol (&QKlinefeed, "linefeed");
2342   defsymbol (&QKreturn, "return");
2343   defsymbol (&QKescape, "escape");
2344   defsymbol (&QKspace, "space");
2345   defsymbol (&QKdelete, "delete");
2346 }
2347
2348
2349 void
2350 reinit_vars_of_events (void)
2351 {
2352   Vevent_resource = Qnil;
2353 }
2354
2355 void
2356 vars_of_events (void)
2357 {
2358   reinit_vars_of_events ();
2359
2360   DEFVAR_LISP ("character-set-property", &Vcharacter_set_property /*
2361 A symbol used to look up the 8-bit character of a keysym.
2362 To convert a keysym symbol to an 8-bit code, as when that key is
2363 bound to self-insert-command, we will look up the property that this
2364 variable names on the property list of the keysym-symbol.  The window-
2365 system-specific code will set up appropriate properties and set this
2366 variable.
2367 */ );
2368   Vcharacter_set_property = Qnil;
2369 }