Mercurial > hg > xemacs-beta
annotate src/event-unixoid.c @ 4792:95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
lisp/ChangeLog addition:
2009-11-08 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (cl-string-vector-equalp)
(cl-bit-vector-vector-equalp, cl-vector-array-equalp)
(cl-hash-table-contents-equalp): New functions, to implement
equalp treating arrays with identical contents as equivalent, as
specified by Common Lisp.
(equalp): Revise this function to implement array equivalence,
and the hash-table equalp behaviour specified by CL.
* cl-macs.el (equalp): Add a compiler macro for this function,
used when one of the arguments is constant, and as such, its type
is known at compile time.
man/ChangeLog addition:
2009-11-08 Aidan Kehoe <kehoea@parhasard.net>
* lispref/objects.texi (Equality Predicates):
Document #'equalp here, as well as #'equal and #'eq.
tests/ChangeLog addition:
2009-12-31 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Test much of the functionality of equalp; add a pointer to Paul
Dietz' ANSI test suite for this function, converted to Emacs
Lisp. Not including the tests themselves in XEmacs because who
owns the copyright on the files is unclear and the GCL people
didn't respond to my queries.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Thu, 31 Dec 2009 15:09:41 +0000 |
| parents | 2fd201d73a92 |
| children | 70e8a00896e9 |
| rev | line source |
|---|---|
| 428 | 1 /* Code shared between all event loops that use select() and have a |
| 2 different input descriptor for each device. | |
| 3 Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. | |
| 4 Copyright (C) 1995 Board of Trustees, University of Illinois. | |
| 5 Copyright (C) 1995 Sun Microsystems, Inc. | |
| 1268 | 6 Copyright (C) 1995, 1996, 2001, 2002, 2003 Ben Wing. |
| 428 | 7 |
| 8 This file is part of XEmacs. | |
| 9 | |
| 10 XEmacs is free software; you can redistribute it and/or modify it | |
| 11 under the terms of the GNU General Public License as published by the | |
| 12 Free Software Foundation; either version 2, or (at your option) any | |
| 13 later version. | |
| 14 | |
| 15 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 16 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 18 for more details. | |
| 19 | |
| 20 You should have received a copy of the GNU General Public License | |
| 21 along with XEmacs; see the file COPYING. If not, write to | |
| 22 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 23 Boston, MA 02111-1307, USA. */ | |
| 24 | |
| 25 /* Synched up with: Not in FSF. */ | |
| 26 | |
| 27 /* This file has been Mule-ized. */ | |
| 28 | |
| 29 #include <config.h> | |
| 30 #include "lisp.h" | |
| 31 | |
| 872 | 32 #include "console-stream-impl.h" |
| 33 #include "console-tty-impl.h" | |
| 1204 | 34 #include "device-impl.h" |
| 428 | 35 #include "events.h" |
| 36 #include "lstream.h" | |
| 37 #include "process.h" | |
| 38 | |
| 39 #include "sysdep.h" | |
| 40 #include "sysfile.h" | |
| 41 #include "sysproc.h" /* select stuff */ | |
| 42 #include "systime.h" | |
| 43 | |
| 44 /* Mask of bits indicating the descriptors that we wait for input on. | |
| 45 These work as follows: | |
| 46 | |
| 1268 | 47 In event-tty.c we call select() directly on this |
| 48 to retrieve an event. In event-Xt.c we use | |
| 49 XtAppAddInput() and the call to select() is down in | |
| 50 the guts of Xt, but we still use the masks when checking for pending input, even in event-Xt.c. (We can't use XtAppPending() because of the presence of the signal event pipe.) | |
| 51 | |
| 428 | 52 input_wait_mask == mask of all file descriptors we select() on, |
| 53 including TTY/stream console descriptors, | |
| 54 process descriptors, and the signal event pipe. | |
| 55 | |
| 56 non_fake_input_wait_mask == same as input_wait_mask but minus the | |
| 57 signal event pipe. Also only used in | |
| 58 event-tty.c. | |
| 59 | |
| 60 process_only_mask == only the process descriptors. | |
| 61 | |
| 62 tty_only_mask == only the TTY/stream console descriptors. | |
| 63 */ | |
| 64 SELECT_TYPE input_wait_mask, non_fake_input_wait_mask; | |
| 65 SELECT_TYPE process_only_mask, tty_only_mask; | |
| 66 | |
| 67 /* This is used to terminate the select(), when an event came in | |
| 68 through a signal (e.g. window-change or C-g on controlling TTY). */ | |
| 69 int signal_event_pipe[2]; | |
| 70 | |
| 71 int signal_event_pipe_initialized; | |
| 72 | |
| 73 int fake_event_occurred; | |
| 74 | |
| 1204 | 75 struct console * |
| 76 find_tty_or_stream_console_from_fd (int fd) | |
| 77 { | |
| 78 Lisp_Object concons; | |
| 79 | |
| 80 CONSOLE_LOOP (concons) | |
| 81 { | |
| 82 struct console *c; | |
| 83 | |
| 84 c = XCONSOLE (XCAR (concons)); | |
| 85 if ((CONSOLE_TTY_P (c) && CONSOLE_TTY_DATA (c)->infd == fd) || | |
| 86 (CONSOLE_STREAM_P (c) && fileno (CONSOLE_STREAM_DATA (c)->in) == fd)) | |
| 87 return c; | |
| 88 } | |
| 89 | |
| 90 return 0; | |
| 91 } | |
| 92 | |
| 428 | 93 int |
| 771 | 94 read_event_from_tty_or_stream_desc (Lisp_Event *event, struct console *con) |
| 428 | 95 { |
| 867 | 96 Ichar ch; |
| 793 | 97 Lisp_Object console = wrap_console (con); |
| 428 | 98 |
| 771 | 99 if (CONSOLE_TTY_P (con)) |
| 867 | 100 ch = Lstream_get_ichar (XLSTREAM (CONSOLE_TTY_DATA (con)->instream)); |
| 771 | 101 else |
| 102 { | |
| 103 /* #### Definitely something strange here. We should be setting | |
| 104 the stdio handle unbuffered and reading from it instead of mixing | |
| 105 stdio and raw io calls. */ | |
| 106 int nread = retry_read (fileno (CONSOLE_STREAM_DATA (con)->in), &ch, 1); | |
| 107 if (nread <= 0) | |
| 108 ch = -1; | |
| 109 } | |
| 110 | |
| 111 if (ch < 0) | |
| 428 | 112 { |
| 113 /* deleting the console might not be safe right now ... */ | |
| 114 enqueue_magic_eval_event (io_error_delete_console, console); | |
| 115 /* but we definitely need to unselect it to avoid infinite | |
| 116 loops reading EOF's */ | |
| 117 Fconsole_disable_input (console); | |
| 118 } | |
| 119 else | |
| 120 { | |
|
4780
2fd201d73a92
Call character_to_event on characters received from XIM, event-Xt.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
4031
diff
changeset
|
121 character_to_event (ch, event, con, use_console_meta_flag, 1); |
| 428 | 122 event->channel = console; |
| 123 return 1; | |
| 124 } | |
| 125 return 0; | |
| 126 } | |
| 127 | |
| 128 void | |
| 129 signal_fake_event (void) | |
| 130 { | |
| 131 char byte = 0; | |
| 132 /* We do the write always. Formerly I tried to "optimize" this | |
| 133 by setting a flag indicating whether we're blocking and only | |
| 134 doing the write in that case, but there is a race condition | |
| 135 if the signal occurs after we've checked for the signal | |
| 136 occurrence (which could occur in many places throughout | |
| 137 an iteration of the command loop, e.g. in status_notify()), | |
| 138 but before we set the blocking flag. | |
| 139 | |
| 771 | 140 This should be OK as long as write() is reentrant, which I'm fairly |
| 141 sure it is since it's a system call. */ | |
| 428 | 142 |
| 143 if (signal_event_pipe_initialized) | |
| 144 /* In case a signal comes through while we're dumping */ | |
| 145 { | |
| 146 int old_errno = errno; | |
| 771 | 147 retry_write (signal_event_pipe[1], &byte, 1); |
| 428 | 148 errno = old_errno; |
| 149 } | |
| 150 } | |
| 151 | |
| 152 void | |
| 153 drain_signal_event_pipe (void) | |
| 154 { | |
| 155 char chars[128]; | |
| 156 /* The input end of the pipe has been set to non-blocking. */ | |
| 771 | 157 while (retry_read (signal_event_pipe[0], chars, sizeof (chars)) > 0) |
| 428 | 158 ; |
| 159 } | |
| 160 | |
| 1204 | 161 void |
| 162 drain_tty_devices (void) | |
| 163 { | |
| 164 Lisp_Object devcons, concons; | |
| 165 CONSOLE_LOOP (concons) | |
| 166 { | |
| 167 struct console *con = XCONSOLE (XCAR (concons)); | |
| 168 if (!con->input_enabled) | |
| 169 continue; | |
| 170 | |
| 171 CONSOLE_DEVICE_LOOP (devcons, con) | |
| 172 { | |
| 173 struct device *d = XDEVICE (XCAR (devcons)); | |
| 174 if (DEVICE_TTY_P (d)) | |
| 175 { | |
| 176 SELECT_TYPE temp_mask; | |
| 177 int infd = DEVICE_INFD (d); | |
| 178 | |
| 179 FD_ZERO (&temp_mask); | |
| 180 FD_SET (infd, &temp_mask); | |
| 181 | |
| 182 while (1) | |
| 183 { | |
| 184 Lisp_Object event; | |
| 185 | |
| 186 if (!poll_fds_for_input (temp_mask)) | |
| 187 break; | |
| 188 | |
| 189 event = Fmake_event (Qnil, Qnil); | |
| 190 if (!read_event_from_tty_or_stream_desc (XEVENT (event), | |
| 191 con)) | |
| 192 /* EOF, or something ... */ | |
| 193 break; | |
| 194 | |
| 195 /* queue the read event to be read for real later. */ | |
| 196 enqueue_dispatch_event (event); | |
| 197 } | |
| 198 } | |
| 199 } | |
| 200 } | |
| 201 } | |
| 202 | |
| 428 | 203 int |
| 204 event_stream_unixoid_select_console (struct console *con) | |
| 205 { | |
| 206 int infd; | |
| 207 | |
| 208 if (CONSOLE_STREAM_P (con)) | |
| 209 infd = fileno (CONSOLE_STREAM_DATA (con)->in); | |
| 210 else | |
| 211 { | |
| 212 assert (CONSOLE_TTY_P (con)); | |
| 213 infd = CONSOLE_TTY_DATA (con)->infd; | |
| 214 } | |
| 215 | |
| 216 assert (infd >= 0); | |
| 217 | |
| 218 FD_SET (infd, &input_wait_mask); | |
| 219 FD_SET (infd, &non_fake_input_wait_mask); | |
| 220 FD_SET (infd, &tty_only_mask); | |
| 221 return infd; | |
| 222 } | |
| 223 | |
| 224 int | |
| 225 event_stream_unixoid_unselect_console (struct console *con) | |
| 226 { | |
| 227 int infd; | |
| 228 | |
| 229 if (CONSOLE_STREAM_P (con)) | |
| 230 infd = fileno (CONSOLE_STREAM_DATA (con)->in); | |
| 231 else | |
| 232 { | |
| 233 assert (CONSOLE_TTY_P (con)); | |
| 234 infd = CONSOLE_TTY_DATA (con)->infd; | |
| 235 } | |
| 236 | |
| 237 assert (infd >= 0); | |
| 238 | |
| 239 FD_CLR (infd, &input_wait_mask); | |
| 240 FD_CLR (infd, &non_fake_input_wait_mask); | |
| 241 FD_CLR (infd, &tty_only_mask); | |
| 242 return infd; | |
| 243 } | |
| 244 | |
| 245 static int | |
| 440 | 246 get_process_infd (Lisp_Process *p) |
| 428 | 247 { |
| 853 | 248 Lisp_Object instr, outstr, errstr; |
| 249 get_process_streams (p, &instr, &outstr, &errstr); | |
| 428 | 250 assert (!NILP (instr)); |
| 251 return filedesc_stream_fd (XLSTREAM (instr)); | |
| 252 } | |
| 253 | |
| 853 | 254 static int |
| 255 get_process_errfd (Lisp_Process *p) | |
| 428 | 256 { |
| 853 | 257 Lisp_Object instr, outstr, errstr; |
| 258 get_process_streams (p, &instr, &outstr, &errstr); | |
| 259 if (!NILP (errstr)) | |
| 260 return filedesc_stream_fd (XLSTREAM (errstr)); | |
| 261 else | |
| 262 return -1; | |
| 428 | 263 } |
| 264 | |
| 853 | 265 void |
| 266 event_stream_unixoid_select_process (Lisp_Process *proc, int doin, int doerr, | |
| 267 int *infd, int *errfd) | |
| 428 | 268 { |
| 853 | 269 if (doin) |
| 270 { | |
| 271 *infd = get_process_infd (proc); | |
| 272 FD_SET (*infd, &input_wait_mask); | |
| 273 FD_SET (*infd, &non_fake_input_wait_mask); | |
| 274 FD_SET (*infd, &process_only_mask); | |
| 275 } | |
| 276 | |
| 277 if (doerr) | |
| 278 { | |
| 279 *errfd = get_process_errfd (proc); | |
| 428 | 280 |
| 853 | 281 if (*errfd >= 0) |
| 282 { | |
| 283 FD_SET (*errfd, &input_wait_mask); | |
| 284 FD_SET (*errfd, &non_fake_input_wait_mask); | |
| 285 FD_SET (*errfd, &process_only_mask); | |
| 286 } | |
| 287 } | |
| 288 } | |
| 289 | |
| 290 void | |
| 291 event_stream_unixoid_unselect_process (Lisp_Process *proc, int doin, int doerr, | |
| 292 int *infd, int *errfd) | |
| 293 { | |
| 294 if (doin) | |
| 295 { | |
| 296 *infd = get_process_infd (proc); | |
| 297 FD_CLR (*infd, &input_wait_mask); | |
| 298 FD_CLR (*infd, &non_fake_input_wait_mask); | |
| 299 FD_CLR (*infd, &process_only_mask); | |
| 300 } | |
| 301 | |
| 302 if (doerr) | |
| 303 { | |
| 304 *errfd = get_process_errfd (proc); | |
| 305 | |
| 306 if (*errfd >= 0) | |
| 307 { | |
| 308 FD_CLR (*errfd, &input_wait_mask); | |
| 309 FD_CLR (*errfd, &non_fake_input_wait_mask); | |
| 310 FD_CLR (*errfd, &process_only_mask); | |
| 311 } | |
| 312 } | |
| 428 | 313 } |
| 314 | |
| 315 int | |
| 316 poll_fds_for_input (SELECT_TYPE mask) | |
| 317 { | |
| 318 EMACS_TIME sometime; | |
| 319 EMACS_SELECT_TIME select_time; | |
| 320 SELECT_TYPE temp_mask; | |
| 321 int retval; | |
| 322 | |
| 323 while (1) | |
| 324 { | |
| 325 EMACS_SET_SECS_USECS (sometime, 0, 0); | |
| 326 EMACS_TIME_TO_SELECT_TIME (sometime, select_time); | |
| 327 temp_mask = mask; | |
| 328 /* To effect a poll, tell select() to block for zero seconds. */ | |
| 329 retval = select (MAXDESC, &temp_mask, 0, 0, &select_time); | |
| 330 if (retval >= 0) | |
| 331 return retval; | |
| 332 if (errno != EINTR) | |
| 333 { | |
| 334 /* Something went seriously wrong; don't abort since maybe | |
| 335 the TTY just died at the wrong time. */ | |
| 442 | 336 stderr_out ("xemacs: select failed: errno = %d\n", errno); |
| 428 | 337 return 0; |
| 338 } | |
| 339 /* else, we got interrupted by a signal, so try again. */ | |
| 340 } | |
| 341 | |
| 1204 | 342 RETURN_NOT_REACHED (0); |
| 428 | 343 } |
| 344 | |
| 345 /****************************************************************************/ | |
| 346 /* Unixoid (file descriptors based) process I/O streams routines */ | |
| 347 /****************************************************************************/ | |
| 348 | |
| 853 | 349 void |
| 350 event_stream_unixoid_create_io_streams (void* inhandle, void* outhandle, | |
| 351 void *errhandle, Lisp_Object* instream, | |
| 352 Lisp_Object* outstream, | |
| 353 Lisp_Object* errstream, | |
| 354 USID* in_usid, | |
| 355 USID* err_usid, | |
| 356 int flags) | |
| 428 | 357 { |
| 853 | 358 int infd, outfd, errfd; |
| 428 | 359 /* Decode inhandle and outhandle. Their meaning depends on |
| 360 the process implementation being used. */ | |
| 4031 | 361 /* We are passed plain old file descs, which are ints, so */ |
| 362 /* if sizeof(EMACS_INT) > sizeof(int) it's OK. */ | |
| 363 infd = (EMACS_INT) inhandle; | |
| 364 outfd = (EMACS_INT) outhandle; | |
| 365 errfd = (EMACS_INT) errhandle; | |
| 428 | 366 |
| 367 *instream = (infd >= 0 | |
| 368 ? make_filedesc_input_stream (infd, 0, -1, 0) | |
| 369 : Qnil); | |
| 370 | |
| 371 *outstream = (outfd >= 0 | |
| 372 ? make_filedesc_output_stream (outfd, 0, -1, LSTR_BLOCKED_OK) | |
| 373 : Qnil); | |
| 374 | |
| 853 | 375 *errstream = (errfd >= 0 |
| 376 ? make_filedesc_input_stream (errfd, 0, -1, 0) | |
| 377 : Qnil); | |
| 378 | |
| 428 | 379 /* FLAGS is process->pty_flag for UNIX_PROCESSES */ |
| 380 if ((flags & STREAM_PTY_FLUSHING) && outfd >= 0) | |
| 381 { | |
| 867 | 382 Ibyte eof_char = get_eof_char (outfd); |
| 428 | 383 int pty_max_bytes = get_pty_max_bytes (outfd); |
| 853 | 384 filedesc_stream_set_pty_flushing (XLSTREAM (*outstream), pty_max_bytes, |
| 385 eof_char); | |
| 428 | 386 } |
| 387 | |
| 853 | 388 *in_usid = FD_TO_USID (infd); |
| 389 *err_usid = FD_TO_USID (errfd); | |
| 428 | 390 } |
| 391 | |
| 853 | 392 void |
| 393 event_stream_unixoid_delete_io_streams (Lisp_Object instream, | |
| 394 Lisp_Object outstream, | |
| 395 Lisp_Object errstream, | |
| 396 USID *in_usid, | |
| 397 USID *err_usid) | |
| 428 | 398 { |
| 853 | 399 int in = (NILP (instream) ? -1 |
| 428 | 400 : filedesc_stream_fd (XLSTREAM (instream))); |
| 853 | 401 int out = (NILP (outstream) ? -1 |
| 428 | 402 : filedesc_stream_fd (XLSTREAM (outstream))); |
| 853 | 403 int err = (NILP (errstream) ? -1 |
| 404 : filedesc_stream_fd (XLSTREAM (errstream))); | |
| 428 | 405 |
| 406 if (in >= 0) | |
| 771 | 407 retry_close (in); |
| 428 | 408 if (out != in && out >= 0) |
| 771 | 409 retry_close (out); |
| 853 | 410 if (err != in && err != out && err >= 0) |
| 411 retry_close (err); | |
| 428 | 412 |
| 853 | 413 *in_usid = FD_TO_USID (in); |
| 414 *err_usid = FD_TO_USID (err); | |
| 428 | 415 } |
| 416 | |
| 417 | |
| 418 void | |
| 419 init_event_unixoid (void) | |
| 420 { | |
| 421 /* Do this first; the init_event_*_late() functions | |
| 422 pay attention to it. */ | |
| 423 if (pipe (signal_event_pipe) < 0) | |
| 424 { | |
| 425 perror ("XEmacs: can't open pipe"); | |
| 426 exit (-1); | |
| 427 } | |
| 428 signal_event_pipe_initialized = 1; | |
| 429 | |
| 430 /* Set it non-blocking so we can drain its output. */ | |
| 431 set_descriptor_non_blocking (signal_event_pipe[0]); | |
| 432 | |
| 433 /* Also set the write descriptor non-blocking so we don't | |
| 434 hang in case a long time passes between times when | |
| 435 we drain the pipe. */ | |
| 436 set_descriptor_non_blocking (signal_event_pipe[1]); | |
| 437 | |
| 438 /* WARNING: In order for the signal-event pipe to work correctly | |
| 439 and not cause lockups, the following need to be followed: | |
| 440 | |
| 441 1) event_pending_p() must ignore input on the signal-event pipe. | |
| 442 2) As soon as next_event() notices input on the signal-event | |
| 443 pipe, it must drain it. */ | |
| 444 FD_ZERO (&input_wait_mask); | |
| 445 FD_ZERO (&non_fake_input_wait_mask); | |
| 446 FD_ZERO (&process_only_mask); | |
| 447 FD_ZERO (&tty_only_mask); | |
| 448 | |
| 449 FD_SET (signal_event_pipe[0], &input_wait_mask); | |
| 450 } |