From xemacs-m  Tue Sep 16 21:03:37 1997
Received: from jagor.srce.hr (hniksic@jagor.srce.hr [161.53.2.130])
	by xemacs.org (8.8.5/8.8.5) with ESMTP id VAA21156
	for <xemacs-beta@xemacs.org>; Tue, 16 Sep 1997 21:02:58 -0500 (CDT)
Received: (from hniksic@localhost)
	by jagor.srce.hr (8.8.7/8.8.6) id EAA13093;
	Wed, 17 Sep 1997 04:02:45 +0200 (MET DST)
To: XEmacs Developers <xemacs-beta@xemacs.org>
Subject: [PATCH] `make-event' accepts arguments
X-Attribution: Hrvoje
X-Face: Mie8:rOV<\c/~z{s.X4A{!?vY7{drJ([U]0O=W/<W*SMo/Mv:58:*_y~ki>xDi&N7XG
        KV^$k0m3Oe/)'e%3=$PCR&3ITUXH,cK>]bci&<qQ>Ff%x_>1`T(+M2Gg/fgndU%k*ft
        [(7._6e0n-V%|%'[c|q:;}td$#INd+;?!-V=c8Pqf}3J
From: Hrvoje Niksic <hniksic@srce.hr>
Date: 17 Sep 1997 04:02:45 +0200
Message-ID: <kigk9gg8zp6.fsf@jagor.srce.hr>
Lines: 499
X-Mailer: Quassia Gnus v0.5/XEmacs 20.3(beta20) - "Tirana"

The comment at events.c says:

/* #### This should accept a type and props (as returned by
   event-properties) to allow creation of any type of event.
   This is useful, for example, in Lisp code that might want
   to determine if, for a given button-down event, what the
   binding for the corresponding button-up event is. */

DEFUN ("make-event", Fmake_event, 0, 0, 0, /*
...


Here is an experimental patch for `make-event' to accept the TYPE and
PLIST arguments, so you can create events you like.  That can be used, 
for instance, to implement things like xterm-mouse-mode, or much
more.  The idea is that `make-event' parses PLIST as if it were a
list returned by `event-properties', and sanity-checks it on the way.


;; Create a fake keypress event, as if with `character-to-event'
(setq e (make-event 'key-press '(key ?a)))
  => #<keypress-event a>

;; The same, but more complex (`character-to-event' can't do this):
(setq e (make-event 'key-press '(key f1 modifiers (control))))
  => #<keypress-event control-f1>

;; A fake mouse event:

(setq e (make-event 'button-press `(channel ,(selected-frame)
                                    button 1 modifiers (control shift)
                                    x 20 y 20)))
  => #<buttondown-event control-shift-button1>

(event-properties e)
  => ( ...... )


I'd like to see your comments -- what do you think, how useful is
this?  Should we add this possibility?  If yes, then our event model
should become as flexible as the one found in GNU Emacs (I think).


1997-09-17  Hrvoje Niksic  <hniksic@srce.hr>

	* emacsfns.h: Ditto.

	* event-stream.c: Ditto.

	* frame.c: Ditto.

	* keymap.c: Ditto.

	* event-Xt.c: Ditto.

	* cmdloop.c: Call Fmake_event with the correct number of args.

	* events.c (Fmake_event): Allow TYPE and PLIST.


--- src/events.c.orig	Wed Sep 17 00:51:29 1997
+++ src/events.c	Wed Sep 17 03:44:40 1997
@@ -353,20 +353,25 @@
 }
 
 
-/* #### This should accept a type and props (as returned by
-   event-properties) to allow creation of any type of event.
-   This is useful, for example, in Lisp code that might want
-   to determine if, for a given button-down event, what the
-   binding for the corresponding button-up event is. */
+DEFUN ("make-event", Fmake_event, 0, 2, 0, /*
+Create a new event of type TYPE, with properties stored in PLIST.
+TYPE is a symbol, either `empty', `key-press', `button-press',
+ `button-release', or `motion'.  If TYPE is left out, it defaults to
+ `empty'.
+PLIST is a list of properties, as returned by `event-properties'.  Not
+ all properties are allowed for all kinds of events, and some are
+ required.
 
-DEFUN ("make-event", Fmake_event, 0, 0, 0, /*
-Create a new empty event.
 WARNING, the event object returned may be a reused one; see the function
-`deallocate-event'.
+ `deallocate-event'.
 */
-       ())
+       (type, plist))
 {
-  Lisp_Object event;
+  Lisp_Object event, tail, prop, val;
+  struct Lisp_Event *e;
+
+  if (NILP (type))
+    type = Qempty;
 
   if (!NILP (Vevent_resource))
     {
@@ -377,7 +382,129 @@
     {
       event = allocate_event ();
     }
-  zero_event (XEVENT (event));
+  e = XEVENT (event);
+  zero_event (e);
+
+  if (EQ (type, Qkey_press))
+    e->event_type = key_press_event;
+  else if (EQ (type, Qbutton_press))
+    e->event_type = button_press_event;
+  else if (EQ (type, Qbutton_release))
+    e->event_type = button_release_event;
+  else if (EQ (type, Qmotion))
+    e->event_type = pointer_motion_event;
+  else if (EQ (type, Qempty))
+    e->event_type = empty_event;
+  else
+    /* not allowed: Qmisc_user, Qprocess, Qtimeout, Qmagic, Qmagic_eval */
+    signal_simple_error ("Invalid event type", type);
+
+  /* Process the plist. */
+  while (!NILP (plist))
+    {
+      prop = Fcar (plist);
+      plist = Fcdr (plist);
+      val = Fcar (plist);
+      plist = Fcdr (plist);
+      if (EQ (prop, Qchannel))
+	{
+	  if (!DEVICEP (val) && !CONSOLEP (val) && !FRAMEP (val)
+	      && !NILP (val))
+	    signal_simple_error ("Invalid event channel", val);
+	  EVENT_CHANNEL (e) = val;
+	}
+      else if (EQ (prop, Qkey))
+	{
+	  if (e->event_type != key_press_event)
+	    wrong_type_argument (Qkey_press_event_p, event);
+	  if (!SYMBOLP (val) && !CHARP (val))
+	    signal_simple_error ("Invalid event key", val);
+	  e->event.key.keysym = val;
+	}
+      else if (EQ (prop, Qbutton))
+	{
+	  CHECK_NATNUM (val);
+	  check_int_range (val, 1, 3);
+	  if (e->event_type != button_press_event
+	      && e->event_type != button_release_event)
+	    signal_simple_error ("Invalid event type for `button' property",
+				 type);
+	  e->event.button.button = XINT (val);
+	}
+      else if (EQ (prop, Qmodifiers))
+	{
+	  Lisp_Object tail, sym;
+	  int modifiers = 0, modifier;
+
+	  if (e->event_type != key_press_event
+	      && e->event_type != button_press_event
+	      && e->event_type != button_release_event
+	      && e->event_type != pointer_motion_event)
+	    signal_simple_error ("Invalid event type for modifiers", type);
+
+	  for (tail = val; !NILP (tail); tail = Fcdr (tail))
+	    {
+	      sym = Fcar (tail);
+	      if (EQ (sym, Qcontrol))      modifiers |= MOD_CONTROL;
+	      else if (EQ (sym, Qmeta))    modifiers |= MOD_META;
+	      else if (EQ (sym, Qsuper))   modifiers |= MOD_SUPER;
+	      else if (EQ (sym, Qhyper))   modifiers |= MOD_HYPER;
+	      else if (EQ (sym, Qalt))     modifiers |= MOD_ALT;
+	      else if (EQ (sym, Qsymbol))  modifiers |= MOD_ALT;
+	      else if (EQ (sym, Qshift))   modifiers |= MOD_SHIFT;
+	      else
+		signal_simple_error ("Invalid key modifier", Fcar (tail));
+	    }
+	  if (e->event_type == key_press_event)
+	    e->event.key.modifiers = modifiers;
+	  else if (e->event_type == button_press_event
+		   || e->event_type == button_release_event)
+	    e->event.button.modifiers = modifiers;
+	  else /* pointer_motion_event */
+	    e->event.motion.modifiers = modifiers;
+	}
+      else if (EQ (prop, Qx))
+	{
+	  CHECK_NATNUM (val);
+	  if (e->event_type == pointer_motion_event)
+	    e->event.motion.x = XINT (val);
+	  else if (e->event_type == button_press_event
+		   || e->event_type == button_release_event)
+	    e->event.button.x = XINT (val);
+	}
+      else if (EQ (prop, Qy))
+	{
+	  CHECK_NATNUM (val);
+	  if (e->event_type == pointer_motion_event)
+	    e->event.motion.y = XINT (val);
+	  else if (e->event_type == button_press_event
+		   || e->event_type == button_release_event)
+	    e->event.button.y = XINT (val);
+	}
+      else if (EQ (prop, Qtimestamp))
+	{
+	  CHECK_NATNUM (val);
+	  e->timestamp = XINT (val);
+	}
+      else
+	signal_simple_error ("Invalid property", prop);
+    } /* while */
+
+  /* Now, let's validate what we got. */
+  switch (e->event_type)
+    {
+    case key_press_event:
+      if (!(SYMBOLP (e->event.key.keysym) || CHARP (e->event.key.keysym)))
+	error ("Undefined key for keypress event");
+      break;
+    case button_press_event:
+    case button_release_event:
+      if (!e->event.button.button)
+	error ("Undefined button for button-press or button-release event");
+      if (NILP (EVENT_CHANNEL (e)))
+	error ("Undefined channel for button-press or button-release event");
+      break;
+    }
   return event;
 }
 
@@ -444,7 +571,7 @@
 {
   CHECK_LIVE_EVENT (event1);
   if (NILP (event2))
-    event2 = Fmake_event ();
+    event2 = Fmake_event (Qnil, Qnil);
   else CHECK_LIVE_EVENT (event2);
   if (EQ (event1, event2))
     return signal_simple_continuable_error_2
@@ -828,7 +955,7 @@
 {
   struct console *con = decode_console (console);
   if (NILP (event))
-    event = Fmake_event ();
+    event = Fmake_event (Qnil, Qnil);
   else
     CHECK_LIVE_EVENT (event);
   if (CONSP (ch) || SYMBOLP (ch))
@@ -872,7 +999,7 @@
 
   for (i = 0; i < len; i++)
     {
-      Lisp_Object event = Fmake_event ();
+      Lisp_Object event = Fmake_event (Qnil, Qnil);
       nth_of_key_sequence_as_event (seq, i, event);
       enqueue_event (event, &head, &tail);
     }
--- src/cmdloop.c.orig	Wed Sep 17 03:41:38 1997
+++ src/cmdloop.c	Wed Sep 17 03:47:06 1997
@@ -497,7 +497,7 @@
        ())
 {
   /* This function can GC */
-  Lisp_Object event = Fmake_event ();
+  Lisp_Object event = Fmake_event (Qnil, Qnil);
   Lisp_Object old_loop = Qnil;
   struct gcpro gcpro1, gcpro2;
   int was_locked = in_single_console_state ();
--- src/event-Xt.c.orig	Wed Sep 17 03:42:56 1997
+++ src/event-Xt.c	Wed Sep 17 03:43:22 1997
@@ -849,7 +849,7 @@
 	GCPRO2 (instream, fb_instream);
         while ((ch = Lstream_get_emchar (istr)) != EOF)
           {
-            Lisp_Object emacs_event = Fmake_event ();
+            Lisp_Object emacs_event = Fmake_event (Qnil, Qnil);
 	    struct Lisp_Event *ev = XEVENT (emacs_event);
             ev->channel	            = DEVICE_CONSOLE (d);
             ev->event_type	    = key_press_event;
@@ -2149,7 +2149,7 @@
 signal_special_Xt_user_event (Lisp_Object channel, Lisp_Object function,
 			      Lisp_Object object)
 {
-  Lisp_Object event = Fmake_event ();
+  Lisp_Object event = Fmake_event (Qnil, Qnil);
 
   XEVENT (event)->event_type = misc_user_event;
   XEVENT (event)->channel = channel;
@@ -2242,7 +2242,7 @@
 			XEvent *event,
 			Boolean *continue_to_dispatch /* unused */)
 {
-  Lisp_Object emacs_event = Fmake_event ();
+  Lisp_Object emacs_event = Fmake_event (Qnil, Qnil);
 
 #ifdef DEBUG_XEMACS
   if (x_debug_events > 0)
@@ -2359,7 +2359,7 @@
       if (!poll_fds_for_input (temp_mask))
 	return;
 
-      event = Fmake_event ();
+      event = Fmake_event (Qnil, Qnil);
       if (!read_event_from_tty_or_stream_desc (XEVENT (event), con, infd))
 	/* EOF, or something ... */
 	return;
--- src/keymap.c.orig	Wed Sep 17 03:45:13 1997
+++ src/keymap.c	Wed Sep 17 03:45:16 1997
@@ -1558,7 +1558,7 @@
      to compare the ASCII values. */
 
   GCPRO1 (event2);
-  event2 = Fmake_event ();
+  event2 = Fmake_event (Qnil, Qnil);
   Fcharacter_to_event (key_specifier, event2, Qnil, Qnil);
   if (XEVENT (event2)->event_type != key_press_event)
     retval = 0;
--- src/frame.c.orig	Wed Sep 17 03:44:57 1997
+++ src/frame.c	Wed Sep 17 03:45:01 1997
@@ -1752,7 +1752,7 @@
 
   if (mouse_pixel_position_1 (d, &frame, &intx, &inty))
     {
-      Lisp_Object event = Fmake_event ();
+      Lisp_Object event = Fmake_event (Qnil, Qnil);
       XEVENT (event)->event_type = pointer_motion_event;
       XEVENT (event)->channel = frame;
       XEVENT (event)->event.motion.x = intx;
--- src/event-stream.c.orig	Wed Sep 17 03:44:25 1997
+++ src/event-stream.c	Wed Sep 17 03:44:26 1997
@@ -1547,7 +1547,7 @@
 void
 enqueue_magic_eval_event (void (*fun) (Lisp_Object), Lisp_Object object)
 {
-  Lisp_Object event = Fmake_event ();
+  Lisp_Object event = Fmake_event (Qnil, Qnil);
 
   XEVENT (event)->event_type = magic_eval_event;
   /* channel for magic_eval events is nil */
@@ -1565,7 +1565,7 @@
 */
        (function, object))
 {
-  Lisp_Object event = Fmake_event ();
+  Lisp_Object event = Fmake_event (Qnil, Qnil);
 
   XEVENT (event)->event_type = eval_event;
   /* channel for eval events is nil */
@@ -1580,7 +1580,7 @@
 enqueue_misc_user_event (Lisp_Object channel, Lisp_Object function,
 			 Lisp_Object object)
 {
-  Lisp_Object event = Fmake_event ();
+  Lisp_Object event = Fmake_event (Qnil, Qnil);
 
   XEVENT (event)->event_type = misc_user_event;
   XEVENT (event)->channel = channel;
@@ -2045,7 +2045,7 @@
 #endif /* LWLIB_MENUBARS_LUCID */
 
   if (NILP (event))
-    event = Fmake_event ();
+    event = Fmake_event (Qnil, Qnil);
   else
     CHECK_LIVE_EVENT (event);
 
@@ -2191,10 +2191,10 @@
      key, click, or menu selection), never a motion or process event.
      */
   if (!EVENTP (Vlast_input_event))
-    Vlast_input_event = Fmake_event ();
+    Vlast_input_event = Fmake_event (Qnil, Qnil);
   if (XEVENT_TYPE (Vlast_input_event) == dead_event)
     {
-      Vlast_input_event = Fmake_event ();
+      Vlast_input_event = Fmake_event (Qnil, Qnil);
       error ("Someone deallocated last-input-event!");
     }
   if (! EQ (event, Vlast_input_event))
@@ -2312,7 +2312,7 @@
   /* This throws away user-input on the queue, but doesn't process any
      events.  Calling dispatch_event() here leads to a race condition.
    */
-  Lisp_Object event = Fmake_event ();
+  Lisp_Object event = Fmake_event (Qnil, Qnil);
   Lisp_Object head = Qnil, tail = Qnil;
   Lisp_Object oiq = Vinhibit_quit;
   struct gcpro gcpro1, gcpro2;
@@ -2471,7 +2471,7 @@
         }
     }
 
-  event = Fmake_event ();
+  event = Fmake_event (Qnil, Qnil);
 
   count = specpdl_depth ();
   record_unwind_protect (sit_for_unwind,
@@ -2575,7 +2575,7 @@
   GCPRO1 (event);
 
   id = event_stream_generate_wakeup (msecs, 0, Qnil, Qnil, 0);
-  event = Fmake_event ();
+  event = Fmake_event (Qnil, Qnil);
 
   count = specpdl_depth ();
   record_unwind_protect (sit_for_unwind, make_int (id));
@@ -2681,7 +2681,7 @@
      redisplay when no input pending.
    */
   GCPRO1 (event);
-  event = Fmake_event ();
+  event = Fmake_event (Qnil, Qnil);
 
   /* Generate the wakeup even if MSECS is 0, so that existing timeout/etc.
      events get processed.  The old (pre-19.12) code special-cased this
@@ -2780,7 +2780,7 @@
 wait_delaying_user_input (int (*predicate) (void *arg), void *predicate_arg)
 {
   /* This function can GC */
-  Lisp_Object event = Fmake_event ();
+  Lisp_Object event = Fmake_event (Qnil, Qnil);
   struct gcpro gcpro1;
   GCPRO1 (event);
 
@@ -3921,7 +3921,7 @@
 static void
 push_this_command_keys (Lisp_Object event)
 {
-  Lisp_Object new = Fmake_event ();
+  Lisp_Object new = Fmake_event (Qnil, Qnil);
 
   Fcopy_event (event, new);
   enqueue_event (new, &Vthis_command_keys, &Vthis_command_keys_tail);
@@ -3998,7 +3998,7 @@
 
   if (NILP (e))
     {
-      e = Fmake_event ();
+      e = Fmake_event (Qnil, Qnil);
       XVECTOR_DATA (Vrecent_keys_ring) [recent_keys_ring_index] = e;
     }
   Fcopy_event (event, e);
@@ -4092,7 +4092,7 @@
       }
     else
       {
-	event = Fcopy_event (event, Fmake_event ());
+	event = Fcopy_event (event, Fmake_event (Qnil, Qnil));
 
 	command_builder_append_event (command_builder, event);
       }
@@ -4127,7 +4127,7 @@
 	      maybe_echo_keys (command_builder, 0);
 	  }
 	else if (!NILP (Vquit_flag)) {
-	  Lisp_Object quit_event = Fmake_event();
+	  Lisp_Object quit_event = Fmake_event(Qnil, Qnil);
 	  struct Lisp_Event *e = XEVENT (quit_event);
 	  /* if quit happened during menu acceleration, pretend we read it */
 	  struct console *con = XCONSOLE (Fselected_console ());
@@ -4184,10 +4184,10 @@
   /* Store the last-command-event.  The semantics of this is that it
      is the last event most recently involved in command-lookup. */
   if (!EVENTP (Vlast_command_event))
-    Vlast_command_event = Fmake_event ();
+    Vlast_command_event = Fmake_event (Qnil, Qnil);
   if (XEVENT (Vlast_command_event)->event_type == dead_event)
     {
-      Vlast_command_event = Fmake_event ();
+      Vlast_command_event = Fmake_event (Qnil, Qnil);
       error ("Someone deallocated the last-command-event!");
     }
 
@@ -4623,7 +4623,7 @@
   struct command_builder *command_builder =
     XCOMMAND_BUILDER (con->command_builder);
   Lisp_Object result;
-  Lisp_Object event = Fmake_event ();
+  Lisp_Object event = Fmake_event (Qnil, Qnil);
   int speccount = specpdl_depth ();
   struct gcpro gcpro1;
   GCPRO1 (event);
--- src/emacsfns.h.orig	Wed Sep 17 03:48:07 1997
+++ src/emacsfns.h	Wed Sep 17 03:48:16 1997
@@ -757,7 +757,7 @@
 
 /* Defined in events.c */
 void clear_event_resource (void);
-Lisp_Object Fmake_event (void);
+Lisp_Object Fmake_event (Lisp_Object, Lisp_Object);
 Lisp_Object Fdeallocate_event (Lisp_Object event);
 Lisp_Object Fcopy_event (Lisp_Object from, Lisp_Object to);
 Lisp_Object allocate_event (void);


-- 
Hrvoje Niksic <hniksic@srce.hr> | Student at FER Zagreb, Croatia
--------------------------------+--------------------------------
Then...  his face does a complete change of expression.  It goes from
a "Vengeance is mine" expression, to a "What the fuck" blank look.

