Mercurial > hg > xemacs-beta

comparison src/device.c @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 9ee227acff29
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 /* Generic device functions.
2 Copyright (C) 1994, 1995 Board of Trustees, University of Illinois.
3 Copyright (C) 1994, 1995 Free Software Foundation, Inc.
4 Copyright (C) 1995, 1996 Ben Wing
5
6 This file is part of XEmacs.
7
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
11 later version.
12
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
22
23 /* Synched up with: Not in FSF. */
24
25 /* Original version by Chuck Thompson;
26 rewritten and expanded by Ben Wing. */
27
28 #include <config.h>
29 #include "lisp.h"
30
31 #include "buffer.h"
32 #include "console.h"
33 #include "device.h"
34 #include "elhash.h"
35 #include "events.h"
36 #include "faces.h"
37 #include "frame.h"
38 #include "keymap.h"
39 #include "redisplay.h"
40 #include "scrollbar.h"
41 #include "specifier.h"
42 #include "sysdep.h"
43 #include "window.h"
44
45 #include "syssignal.h"
46
47 /* Vdefault_device is the firstly-created non-stream device that's still
48 around. We don't really use it anywhere currently, but it might
49 be used for resourcing at some point. (Currently we use
50 Vdefault_x_device.) */
51 Lisp_Object Vdefault_device;
52
53 Lisp_Object Vcreate_device_hook, Vdelete_device_hook;
54
55 /* Device classes */
56 /* Qcolor defined in general.c */
57 Lisp_Object Qgrayscale, Qmono;
58
59 Lisp_Object Qdevicep, Qdevice_live_p;
60 Lisp_Object Qdelete_device;
61 Lisp_Object Qcreate_device_hook;
62 Lisp_Object Qdelete_device_hook;
63
64 Lisp_Object Vdevice_class_list;
65
66 MAC_DEFINE (struct device *, MTdevice_data)
67
68
69 static Lisp_Object mark_device (Lisp_Object, void (*) (Lisp_Object));
70 static void print_device (Lisp_Object, Lisp_Object, int);
71 DEFINE_LRECORD_IMPLEMENTATION ("device", device,
72 mark_device, print_device, 0, 0, 0,
73 struct device);
74
75 static Lisp_Object
76 mark_device (Lisp_Object obj, void (*markobj) (Lisp_Object))
77 {
78 struct device *d = XDEVICE (obj);
79
80 ((markobj) (d->name));
81 ((markobj) (d->connection));
82 ((markobj) (d->canon_connection));
83 ((markobj) (d->console));
84 ((markobj) (d->_selected_frame));
85 ((markobj) (d->frame_with_focus_real));
86 ((markobj) (d->frame_with_focus_for_hooks));
87 ((markobj) (d->frame_that_ought_to_have_focus));
88 ((markobj) (d->device_class));
89 ((markobj) (d->user_defined_tags));
90 ((markobj) (d->pixel_to_glyph_cache.obj1));
91 ((markobj) (d->pixel_to_glyph_cache.obj2));
92
93 ((markobj) (d->color_instance_cache));
94 ((markobj) (d->font_instance_cache));
95 ((markobj) (d->image_instance_cache));
96
97 if (d->devmeths)
98 {
99 ((markobj) (d->devmeths->symbol));
100 MAYBE_DEVMETH (d, mark_device, (d, markobj));
101 }
102
103 return (d->frame_list);
104 }
105
106 static void
107 print_device (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
108 {
109 struct device *d = XDEVICE (obj);
110 char buf[256];
111
112 if (print_readably)
113 error ("printing unreadable object #<device %s 0x%x>",
114 string_data (XSTRING (d->name)), d->header.uid);
115
116 sprintf (buf, "#<%s-device", !DEVICE_LIVE_P (d) ? "dead" :
117 DEVICE_TYPE_NAME (d));
118 write_c_string (buf, printcharfun);
119 if (DEVICE_LIVE_P (d))
120 {
121 write_c_string (" on ", printcharfun);
122 print_internal (DEVICE_CONNECTION (d), printcharfun, 1);
123 }
124 sprintf (buf, " 0x%x>", d->header.uid);
125 write_c_string (buf, printcharfun);
126 }
127
128
129 int
130 valid_device_class_p (Lisp_Object class)
131 {
132 return !NILP (memq_no_quit (class, Vdevice_class_list));
133 }
134
135 DEFUN ("valid-device-class-p", Fvalid_device_class_p, Svalid_device_class_p,
136 1, 1, 0 /*
137 Given a DEVICE-CLASS, return t if it is valid.
138 Valid classes are 'color, 'grayscale, and 'mono.
139 */ )
140 (device_class)
141 Lisp_Object device_class;
142 {
143 if (valid_device_class_p (device_class))
144 return Qt;
145 else
146 return Qnil;
147 }
148
149 DEFUN ("device-class-list", Fdevice_class_list, Sdevice_class_list,
150 0, 0, 0 /*
151 Return a list of valid device classes.
152 */ )
153 ()
154 {
155 return Fcopy_sequence (Vdevice_class_list);
156 }
157
158 static struct device *
159 allocate_device (Lisp_Object console)
160 {
161 Lisp_Object device = Qnil;
162 struct device *d = alloc_lcrecord (sizeof (struct device), lrecord_device);
163 struct gcpro gcpro1;
164
165 zero_lcrecord (d);
166
167 XSETDEVICE (device, d);
168 GCPRO1 (device);
169
170 d->name = Qnil;
171 d->console = console;
172 d->connection = Qnil;
173 d->canon_connection = Qnil;
174 d->frame_list = Qnil;
175 d->_selected_frame = Qnil;
176 d->frame_with_focus_real = Qnil;
177 d->frame_with_focus_for_hooks = Qnil;
178 d->frame_that_ought_to_have_focus = Qnil;
179 d->device_class = Qnil;
180 d->user_defined_tags = Qnil;
181 d->pixel_to_glyph_cache.obj1 = Qnil;
182 d->pixel_to_glyph_cache.obj2 = Qnil;
183
184 d->infd = d->outfd = -1;
185
186 /* #### is 20 reasonable? */
187 d->color_instance_cache = make_lisp_hashtable (20, HASHTABLE_KEY_WEAK,
188 HASHTABLE_EQUAL);
189 d->font_instance_cache = make_lisp_hashtable (20, HASHTABLE_KEY_WEAK,
190 HASHTABLE_EQUAL);
191 /*
192 Note that the image instance cache is actually bi-level.
193 See device.h. We use a low number here because most of the
194 time there aren't very many diferent masks that will be used.
195 */
196 d->image_instance_cache = make_lisp_hashtable (5, HASHTABLE_NONWEAK,
197 HASHTABLE_EQ);
198
199 UNGCPRO;
200 return d;
201 }
202
203 struct device *
204 decode_device (Lisp_Object device)
205 {
206 if (NILP (device))
207 device = Fselected_device (Qnil);
208 /* quietly accept frames for the device arg */
209 if (FRAMEP (device))
210 device = FRAME_DEVICE (decode_frame (device));
211 CHECK_LIVE_DEVICE (device);
212 return XDEVICE (device);
213 }
214
215 Lisp_Object
216 make_device (struct device *d)
217 {
218 Lisp_Object device = Qnil;
219 XSETDEVICE (device, d);
220 return device;
221 }
222
223 DEFUN ("dfw-device", Fdfw_device, Sdfw_device, 1, 1, 0 /*
224 Given a device, frame, or window, return the associated device.
225 Return nil otherwise.
226 */ )
227 (obj)
228 Lisp_Object obj;
229 {
230 return DFW_DEVICE (obj);
231 }
232
233
234 DEFUN ("selected-device", Fselected_device, Sselected_device, 0, 1, 0 /*
235 Return the device which is currently active.
236 If optional CONSOLE is non-nil, return the device that would be currently
237 active if CONSOLE were the selected console.
238 */ )
239 (console)
240 Lisp_Object console;
241 {
242 if (NILP (console) && NILP (Vselected_console))
243 return Qnil; /* happens early in temacs */
244 return CONSOLE_SELECTED_DEVICE (decode_console (console));
245 }
246
247 /* Called from selected_frame_1(), called from Fselect_window() */
248 void
249 select_device_1 (Lisp_Object device)
250 {
251 struct device *dev = XDEVICE (device);
252 Lisp_Object old_selected_device = Fselected_device (Qnil);
253
254 if (EQ (device, old_selected_device))
255 return;
256
257 /* now select the device's console */
258 CONSOLE_SELECTED_DEVICE (XCONSOLE (DEVICE_CONSOLE (dev))) = device;
259 select_console_1 (DEVICE_CONSOLE (dev));
260 }
261
262 DEFUN ("select-device", Fselect_device, Sselect_device, 1, 1, 0 /*
263 Select the device DEVICE.
264 Subsequent editing commands apply to its console, selected frame,
265 and selected window.
266 The selection of DEVICE lasts until the next time the user does
267 something to select a different device, or until the next time this
268 function is called.
269 */ )
270 (device)
271 Lisp_Object device;
272 {
273 CHECK_LIVE_DEVICE (device);
274
275 /* select the device's selected frame's selected window. This will call
276 selected_frame_1()->selected_device_1()->selected_console_1(). */
277 if (!NILP (DEVICE_SELECTED_FRAME (XDEVICE (device))))
278 Fselect_window (FRAME_SELECTED_WINDOW
279 (XFRAME (DEVICE_SELECTED_FRAME (XDEVICE (device)))));
280 else
281 error ("Can't select a device with no frames");
282 return Qnil;
283 }
284
285 void
286 set_device_selected_frame (struct device *d, Lisp_Object frame)
287 {
288 if (!NILP (frame) && !FRAME_MINIBUF_ONLY_P (XFRAME (frame)))
289 set_console_last_nonminibuf_frame (XCONSOLE (DEVICE_CONSOLE (d)), frame);
290 d->_selected_frame = frame;
291 }
292
293 DEFUN ("set-device-selected-frame", Fset_device_selected_frame,
294 Sset_device_selected_frame, 2, 2, 0 /*
295 Set the selected frame of device object DEVICE to FRAME.
296 If DEVICE is nil, the selected device is used.
297 If DEVICE is the selected device, this makes FRAME the selected frame.
298 */ )
299 (device, frame)
300 Lisp_Object device, frame;
301 {
302 XSETDEVICE (device, decode_device (device));
303 CHECK_LIVE_FRAME (frame);
304
305 if (! EQ (device, FRAME_DEVICE (XFRAME (frame))))
306 error ("In `set-device-selected-frame', FRAME is not on DEVICE");
307
308 if (EQ (device, Fselected_device (Qnil)))
309 return Fselect_frame (frame);
310
311 set_device_selected_frame (XDEVICE (device), frame);
312 return frame;
313 }
314
315 DEFUN ("devicep", Fdevicep, Sdevicep, 1, 1, 0 /*
316 Return non-nil if OBJECT is a device.
317 */ )
318 (object)
319 Lisp_Object object;
320 {
321 if (!DEVICEP (object))
322 return Qnil;
323 return Qt;
324 }
325
326 DEFUN ("device-live-p", Fdevice_live_p, Sdevice_live_p, 1, 1, 0 /*
327 Return non-nil if OBJECT is a device that has not been deleted.
328 */ )
329 (object)
330 Lisp_Object object;
331 {
332 if (!DEVICEP (object) || !DEVICE_LIVE_P (XDEVICE (object)))
333 return Qnil;
334 return Qt;
335 }
336
337 DEFUN ("device-name", Fdevice_name, Sdevice_name, 0, 1, 0 /*
338 Return the name of the specified device.
339 DEVICE defaults to the selected device if omitted.
340 */ )
341 (device)
342 Lisp_Object device;
343 {
344 return DEVICE_NAME (decode_device (device));
345 }
346
347 DEFUN ("device-connection", Fdevice_connection, Sdevice_connection, 0, 1, 0 /*
348 Return the connection of the specified device.
349 DEVICE defaults to the selected device if omitted.
350 */ )
351 (device)
352 Lisp_Object device;
353 {
354 return DEVICE_CONNECTION (decode_device (device));
355 }
356
357 DEFUN ("device-console", Fdevice_console, Sdevice_console, 0, 1, 0 /*
358 Return the console of the specified device.
359 DEVICE defaults to the selected device if omitted.
360 */ )
361 (device)
362 Lisp_Object device;
363 {
364 return DEVICE_CONSOLE (decode_device (device));
365 }
366
367 #ifdef HAVE_X_WINDOWS
368 extern Lisp_Object Vdefault_x_device;
369 #endif
370 #ifdef HAVE_NEXTSTEP
371 extern Lisp_Object Vdefault_ns_device;
372 #endif
373
374 #ifdef HAVE_X_WINDOWS
375
376 static void
377 init_global_resources (struct device *d)
378 {
379 init_global_faces (d);
380 #ifdef HAVE_SCROLLBARS
381 init_global_scrollbars (d);
382 #endif
383 #ifdef HAVE_TOOLBARS
384 init_global_toolbars (d);
385 #endif
386 }
387
388 #endif
389
390 static void
391 init_device_resources (struct device *d)
392 {
393 init_device_faces (d);
394 #ifdef HAVE_SCROLLBARS
395 init_device_scrollbars (d);
396 #endif
397 #ifdef HAVE_TOOLBARS
398 init_device_toolbars (d);
399 #endif
400 }
401
402 static Lisp_Object
403 semi_canonicalize_device_connection (struct console_methods *meths,
404 Lisp_Object name, Error_behavior errb)
405 {
406 return CONTYPE_METH_OR_GIVEN (meths, semi_canonicalize_device_connection,
407 (name, errb), name);
408 }
409
410 static Lisp_Object
411 canonicalize_device_connection (struct console_methods *meths,
412 Lisp_Object name, Error_behavior errb)
413 {
414 return CONTYPE_METH_OR_GIVEN (meths, canonicalize_device_connection,
415 (name, errb), name);
416 }
417
418 static Lisp_Object
419 find_device_of_type (struct console_methods *meths, Lisp_Object canon)
420 {
421 Lisp_Object devcons, concons;
422
423 DEVICE_LOOP_NO_BREAK (devcons, concons)
424 {
425 Lisp_Object device = XCAR (devcons);
426
427 if (EQ (CONMETH_TYPE (meths), DEVICE_TYPE (XDEVICE (device)))
428 && !NILP (Fequal (DEVICE_CANON_CONNECTION (XDEVICE (device)),
429 canon)))
430 return device;
431 }
432
433 return Qnil;
434 }
435
436 DEFUN ("find-device", Ffind_device, Sfind_device, 1, 2, 0 /*
437 Look for an existing device attached to connection CONNECTION.
438 Return the device if found; otherwise, return nil.
439
440 If TYPE is specified, only return devices of that type; otherwise,
441 return devices of any type. (It is possible, although unlikely,
442 that two devices of different types could have the same connection
443 name; in such a case, the first device found is returned.)
444 */ )
445 (connection, type)
446 Lisp_Object connection, type;
447 {
448 Lisp_Object canon = Qnil;
449 struct gcpro gcpro1;
450
451 GCPRO1 (canon);
452
453 if (!NILP (type))
454 {
455 struct console_methods *conmeths = decode_console_type (type, ERROR_ME);
456 canon = canonicalize_device_connection (conmeths, connection,
457 ERROR_ME_NOT);
458 if (UNBOUNDP (canon))
459 RETURN_UNGCPRO (Qnil);
460
461 RETURN_UNGCPRO (find_device_of_type (conmeths, canon));
462 }
463 else
464 {
465 int i;
466
467 for (i = 0; i < Dynarr_length (the_console_type_entry_dynarr); i++)
468 {
469 struct console_methods *conmeths =
470 Dynarr_at (the_console_type_entry_dynarr, i).meths;
471 canon = canonicalize_device_connection (conmeths, connection,
472 ERROR_ME_NOT);
473 if (!UNBOUNDP (canon))
474 {
475 Lisp_Object device = find_device_of_type (conmeths, canon);
476 if (!NILP (device))
477 RETURN_UNGCPRO (device);
478 }
479 }
480
481 RETURN_UNGCPRO (Qnil);
482 }
483 }
484
485 DEFUN ("get-device", Fget_device, Sget_device, 1, 2, 0 /*
486 Look for an existing device attached to connection CONNECTION.
487 Return the device if found; otherwise, signal an error.
488
489 If TYPE is specified, only return devices of that type; otherwise,
490 return devices of any type. (It is possible, although unlikely,
491 that two devices of different types could have the same connection
492 name; in such a case, the first device found is returned.)
493 */ )
494 (connection, type)
495 Lisp_Object connection, type;
496 {
497 Lisp_Object device = Ffind_device (connection, type);
498 if (NILP (device))
499 {
500 if (NILP (type))
501 signal_simple_error ("No such device", connection);
502 else
503 signal_simple_error_2 ("No such device", type, connection);
504 }
505 return device;
506 }
507
508 DEFUN ("make-device", Fmake_device, Smake_device, 2, 3, 0 /*
509 Create a new device of type TYPE, attached to connection CONNECTION.
510
511 The valid values for CONNECTION are device-specific; however,
512 CONNECTION is generally a string. (Specifically, for X devices,
513 CONNECTION should be a display specification such as "foo:0", and
514 for TTY devices, CONNECTION should be the filename of a TTY device
515 file, such as "/dev/ttyp4", or nil to refer to XEmacs' standard
516 input/output.)
517
518 PROPS, if specified, should be a plist of properties controlling
519 device creation.
520
521 If CONNECTION specifies an already-existing device connection, that
522 device is simply returned; no new device is created, and PROPS
523 have no effect.
524 */ )
525 (type, connection, props)
526 Lisp_Object type, connection, props;
527 {
528 /* This function can GC */
529 struct device *d;
530 struct console *con;
531 Lisp_Object device = Qnil;
532 Lisp_Object console = Qnil;
533 Lisp_Object name = Qnil;
534 struct console_methods *conmeths;
535
536 struct gcpro gcpro1, gcpro2, gcpro3;
537 #ifdef HAVE_X_WINDOWS
538 /* #### icky-poo. If this is the first X device we are creating,
539 then retrieve the global face resources. We have to do it
540 here, at the same time as (or just before) the device face
541 resources are retrieved; specifically, it needs to be done
542 after the device has been created but before any frames have
543 been popped up or much anything else has been done. It's
544 possible for other devices to specify different global
545 resources (there's a property on each X server's root window
546 that holds some resources); tough luck for the moment.
547
548 This is a nasty violation of device independence, but
549 there's not a whole lot I can figure out to do about it.
550 The real problem is that the concept of resources is not
551 generalized away from X. Similar resource-related
552 device-independence violations occur in faces.el. */
553 int first_x_device = NILP (Vdefault_x_device) && EQ (type, Qx);
554 #endif
555
556 GCPRO3 (device, console, name);
557
558 conmeths = decode_console_type (type, ERROR_ME_NOT);
559 if (!conmeths)
560 signal_simple_error ("Invalid device type", type);
561
562 device = Ffind_device (connection, type);
563 if (!NILP (device))
564 RETURN_UNGCPRO (device);
565
566 name = Fplist_get (props, Qname, Qnil);
567
568 {
569 Lisp_Object conconnect =
570 CONTYPE_METH_OR_GIVEN (conmeths,
571 device_to_console_connection,
572 (connection, ERROR_ME),
573 connection);
574 console = create_console (name, type, conconnect, props);
575 }
576
577 con = XCONSOLE (console);
578 d = allocate_device (console);
579 XSETDEVICE (device, d);
580
581 d->devmeths = con->conmeths;
582
583 DEVICE_NAME (d) = name;
584 DEVICE_CONNECTION (d) = semi_canonicalize_device_connection (conmeths,
585 connection,
586 ERROR_ME);
587 DEVICE_CANON_CONNECTION (d) = canonicalize_device_connection (conmeths,
588 connection,
589 ERROR_ME);
590
591 MAYBE_DEVMETH (d, init_device, (d, props));
592
593 /* Do it this way so that the device list is in order of creation */
594 con->device_list = nconc2 (con->device_list, Fcons (device, Qnil));
595 RESET_CHANGED_SET_FLAGS;
596 if (NILP (Vdefault_device) || DEVICE_STREAM_P (XDEVICE (Vdefault_device)))
597 Vdefault_device = device;
598
599 init_device_sound (d);
600 #ifdef HAVE_X_WINDOWS
601 if (first_x_device)
602 init_global_resources (d);
603 #endif
604 init_device_resources (d);
605
606 MAYBE_DEVMETH (d, finish_init_device, (d, props));
607
608 /* If this is the first device on the console, make it the selected one. */
609 if (NILP (CONSOLE_SELECTED_DEVICE (con)))
610 CONSOLE_SELECTED_DEVICE (con) = device;
611
612 /* #### the following should trap errors. */
613 setup_device_initial_specifier_tags (d);
614
615 UNGCPRO;
616 return device;
617 }
618
619 /* find a device other than the selected one. Prefer non-stream
620 devices over stream devices. Maybe stay on the same console. */
621
622 static Lisp_Object
623 find_other_device (Lisp_Object device, int on_same_console)
624 {
625 Lisp_Object devcons = Qnil, concons = Qnil;
626 Lisp_Object console = DEVICE_CONSOLE (XDEVICE (device));
627
628 /* look for a non-stream device */
629 DEVICE_LOOP_NO_BREAK (devcons, concons)
630 {
631 Lisp_Object dev = XCAR (devcons);
632 if (on_same_console && !EQ (console, DEVICE_CONSOLE (XDEVICE (dev))))
633 continue;
634 if (!DEVICE_STREAM_P (XDEVICE (dev)) && !EQ (dev, device) &&
635 !NILP (DEVICE_SELECTED_FRAME (XDEVICE (dev))))
636 goto double_break_1;
637 }
638
639 double_break_1:
640 if (!NILP (devcons))
641 return XCAR (devcons);
642
643 /* OK, now look for a stream device */
644 DEVICE_LOOP_NO_BREAK (devcons, concons)
645 {
646 Lisp_Object dev = XCAR (devcons);
647 if (on_same_console && !EQ (console, DEVICE_CONSOLE (XDEVICE (dev))))
648 continue;
649 if (!EQ (dev, device) && !NILP (DEVICE_SELECTED_FRAME (XDEVICE (dev))))
650 goto double_break_2;
651 }
652 double_break_2:
653 if (!NILP (devcons))
654 return XCAR (devcons);
655
656 /* Sorry, there ain't none */
657 return Qnil;
658 }
659
660 static int
661 find_nonminibuffer_frame_not_on_device_predicate (Lisp_Object frame,
662 void *closure)
663 {
664 Lisp_Object device;
665
666 VOID_TO_LISP (device, closure);
667 if (FRAME_MINIBUF_ONLY_P (XFRAME (frame)))
668 return 0;
669 if (EQ (device, FRAME_DEVICE (XFRAME (frame))))
670 return 0;
671 return 1;
672 }
673
674 Lisp_Object
675 find_nonminibuffer_frame_not_on_device (Lisp_Object device)
676 {
677 return find_some_frame (find_nonminibuffer_frame_not_on_device_predicate,
678 LISP_TO_VOID (device));
679 }
680
681
682 /* Delete device D.
683
684 If FORCE is non-zero, allow deletion of the only frame.
685
686 If CALLED_FROM_DELETE_CONSOLE is non-zero, then, if
687 deleting the last device on a console, just delete it,
688 instead of calling `delete-console'.
689
690 If FROM_IO_ERROR is non-zero, then the device is gone due
691 to an I/O error. This affects what happens if we exit
692 (we do an emergency exit instead of `save-buffers-kill-emacs'.)
693 */
694
695 void
696 delete_device_internal (struct device *d, int force,
697 int called_from_delete_console,
698 int from_io_error)
699 {
700 /* This function can GC */
701 struct console *c;
702 Lisp_Object device = Qnil;
703 struct gcpro gcpro1;
704
705 /* OK to delete an already-deleted device. */
706 if (!DEVICE_LIVE_P (d))
707 return;
708
709 XSETDEVICE (device, d);
710 GCPRO1 (device);
711
712 c = XCONSOLE (DEVICE_CONSOLE (d));
713
714 if (!called_from_delete_console)
715 {
716 int delete_console = 0;
717 /* If we're deleting the only device on the console,
718 delete the console. */
719 if ((XINT (Flength (CONSOLE_DEVICE_LIST (c))) == 1)
720 /* if we just created the device, it might not be listed,
721 or something ... */
722 && !NILP (memq_no_quit (device, CONSOLE_DEVICE_LIST (c))))
723 delete_console = 1;
724 /* Or if there aren't any nonminibuffer frames that would be
725 left, delete the console (this will make XEmacs exit). */
726 else if (NILP (find_nonminibuffer_frame_not_on_device (device)))
727 delete_console = 1;
728
729 if (delete_console)
730 {
731 delete_console_internal (c, force, 0, from_io_error);
732 UNGCPRO;
733 return;
734 }
735 }
736
737 reset_one_device (d);
738
739 {
740 Lisp_Object frmcons;
741
742 /* First delete all frames without their own minibuffers,
743 to avoid errors coming from attempting to delete a frame
744 that is a surrogate for another frame. */
745 DEVICE_FRAME_LOOP (frmcons, d)
746 {
747 struct frame *f = XFRAME (XCAR (frmcons));
748 /* delete_frame_internal() might do anything such as run hooks,
749 so be defensive. */
750 if (FRAME_LIVE_P (f) && !FRAME_HAS_MINIBUF_P (f))
751 delete_frame_internal (f, 1, 1, from_io_error);
752
753 if (!DEVICE_LIVE_P (d)) /* make sure the delete-*-hook didn't
754 go ahead and delete anything */
755 {
756 UNGCPRO;
757 return;
758 }
759 }
760
761 /* #### This should probably be a device method but it is time for
762 19.14 to go out the door. */
763 #ifdef HAVE_X_WINDOWS
764 /* Next delete all frames which have the popup property to avoid
765 deleting a child after its parent. */
766 DEVICE_FRAME_LOOP (frmcons, d)
767 {
768 struct frame *f = XFRAME (XCAR (frmcons));
769
770 if (FRAME_LIVE_P (f))
771 {
772 Lisp_Object popup = Fframe_property (XCAR (frmcons), Qpopup, Qnil);
773 if (!NILP (popup))
774 delete_frame_internal (f, 1, 1, from_io_error);
775
776 if (!DEVICE_LIVE_P (d)) /* make sure the delete-*-hook didn't
777 go ahead and delete anything */
778 {
779 UNGCPRO;
780 return;
781 }
782 }
783 }
784 #endif /* HAVE_X_WINDOWS */
785
786 DEVICE_FRAME_LOOP (frmcons, d)
787 {
788 struct frame *f = XFRAME (XCAR (frmcons));
789 /* delete_frame_internal() might do anything such as run hooks,
790 so be defensive. */
791 if (FRAME_LIVE_P (f))
792 delete_frame_internal (f, 1, 1, from_io_error);
793
794 if (!DEVICE_LIVE_P (d)) /* make sure the delete-*-hook didn't
795 go ahead and delete anything */
796 {
797 UNGCPRO;
798 return;
799 }
800 }
801 }
802
803 set_device_selected_frame (d, Qnil);
804
805 /* try to select another device */
806
807 if (EQ (device, Fselected_device (DEVICE_CONSOLE (d))))
808 {
809 Lisp_Object other_dev = find_other_device (device, 1);
810 if (!NILP (other_dev))
811 Fselect_device (other_dev);
812 }
813
814 if (EQ (device, Vdefault_device))
815 Vdefault_device = find_other_device (device, 0);
816
817 MAYBE_DEVMETH (d, delete_device, (d));
818
819 CONSOLE_DEVICE_LIST (c) = delq_no_quit (device, CONSOLE_DEVICE_LIST (c));
820 RESET_CHANGED_SET_FLAGS;
821 d->devmeths = dead_console_methods;
822 UNGCPRO;
823 }
824
825 /* delete a device as a result of an I/O error. Called from
826 an enqueued magic-eval event. */
827
828 void
829 io_error_delete_device (Lisp_Object device)
830 {
831 delete_device_internal (XDEVICE (device), 1, 0, 1);
832 }
833
834 DEFUN ("delete-device", Fdelete_device, Sdelete_device, 1, 2, 0 /*
835 Delete DEVICE, permanently eliminating it from use.
836 Normally, you cannot delete the last non-minibuffer-only frame (you must
837 use `save-buffers-kill-emacs' or `kill-emacs'). However, if optional
838 second argument FORCE is non-nil, you can delete the last frame. (This
839 will automatically call `save-buffers-kill-emacs'.)
840 */ )
841 (device, force)
842 Lisp_Object device, force;
843 {
844 CHECK_DEVICE (device);
845 delete_device_internal (XDEVICE (device), !NILP (force), 0, 0);
846 return Qnil;
847 }
848
849 DEFUN ("device-frame-list", Fdevice_frame_list, Sdevice_frame_list,
850 0, 1, 0 /*
851 Return a list of all frames on DEVICE.
852 If DEVICE is nil, the selected device will be used.
853 */ )
854 (device)
855 Lisp_Object device;
856 {
857 return Fcopy_sequence (DEVICE_FRAME_LIST (decode_device (device)));
858 }
859
860 DEFUN ("device-class", Fdevice_class, Sdevice_class,
861 0, 1, 0 /*
862 Return the class (color behavior) of DEVICE.
863 This will be one of 'color, 'grayscale, or 'mono.
864 */ )
865 (device)
866 Lisp_Object device;
867 {
868 return DEVICE_CLASS (decode_device (device));
869 }
870
871 DEFUN ("set-device-class", Fset_device_class, Sset_device_class,
872 2, 2, 0 /*
873 Set the class (color behavior) of DEVICE.
874 CLASS should be one of 'color, 'grayscale, or 'mono.
875 This is only allowed on device such as TTY devices, where the color
876 behavior cannot necessarily be determined automatically.
877 */ )
878 (device, class)
879 Lisp_Object device, class;
880 {
881 struct device *d = decode_device (device);
882 XSETDEVICE (device, d);
883 if (!DEVICE_TTY_P (d))
884 signal_simple_error ("Cannot change the class of this device", device);
885 if (!EQ (class, Qcolor) && !EQ (class, Qmono) && !EQ (class, Qgrayscale))
886 signal_simple_error ("Must be color, mono, or grayscale", class);
887 DEVICE_CLASS (d) = class;
888 return Qnil;
889 }
890
891 DEFUN ("device-pixel-width", Fdevice_pixel_width, Sdevice_pixel_width,
892 0, 1, 0 /*
893 Return the width in pixels of DEVICE, or nil if unknown.
894 */ )
895 (device)
896 Lisp_Object device;
897 {
898 struct device *d = decode_device (device);
899 int retval;
900
901 retval = DEVMETH_OR_GIVEN (d, device_pixel_width, (d), 0);
902 if (retval <= 0)
903 return Qnil;
904
905 return make_int (retval);
906 }
907
908 DEFUN ("device-pixel-height", Fdevice_pixel_height, Sdevice_pixel_height,
909 0, 1, 0 /*
910 Return the height in pixels of DEVICE, or nil if unknown.
911 */ )
912 (device)
913 Lisp_Object device;
914 {
915 struct device *d = decode_device (device);
916 int retval;
917
918 retval = DEVMETH_OR_GIVEN (d, device_pixel_height, (d), 0);
919 if (retval <= 0)
920 return Qnil;
921
922 return make_int (retval);
923 }
924
925 DEFUN ("device-mm-width", Fdevice_mm_width, Sdevice_mm_width,
926 0, 1, 0 /*
927 Return the width in millimeters of DEVICE, or nil if unknown.
928 */ )
929 (device)
930 Lisp_Object device;
931 {
932 struct device *d = decode_device (device);
933 int retval;
934
935 retval = DEVMETH_OR_GIVEN (d, device_mm_width, (d), 0);
936 if (retval <= 0)
937 return Qnil;
938
939 return make_int (retval);
940 }
941
942 DEFUN ("device-mm-height", Fdevice_mm_height, Sdevice_mm_height,
943 0, 1, 0 /*
944 Return the height in millimeters of DEVICE, or nil if unknown.
945 */ )
946 (device)
947 Lisp_Object device;
948 {
949 struct device *d = decode_device (device);
950 int retval;
951
952 retval = DEVMETH_OR_GIVEN (d, device_mm_height, (d), 0);
953 if (retval <= 0)
954 return Qnil;
955
956 return make_int (retval);
957 }
958
959 DEFUN ("device-bitplanes", Fdevice_bitplanes, Sdevice_bitplanes,
960 0, 1, 0 /*
961 Return the number of bitplanes of DEVICE, or nil if unknown.
962 */ )
963 (device)
964 Lisp_Object device;
965 {
966 struct device *d = decode_device (device);
967 int retval;
968
969 retval = DEVMETH_OR_GIVEN (d, device_bitplanes, (d), 0);
970 if (retval <= 0)
971 return Qnil;
972
973 return make_int (retval);
974 }
975
976 DEFUN ("device-color-cells", Fdevice_color_cells, Sdevice_color_cells,
977 0, 1, 0 /*
978 Return the number of color cells of DEVICE, or nil if unknown.
979 */ )
980 (device)
981 Lisp_Object device;
982 {
983 struct device *d = decode_device (device);
984 int retval;
985
986 retval = DEVMETH_OR_GIVEN (d, device_color_cells, (d), 0);
987 if (retval <= 0)
988 return Qnil;
989
990 return make_int (retval);
991 }
992
993 DEFUN ("set-device-baud-rate", Fset_device_baud_rate, Sset_device_baud_rate,
994 2, 2, 0 /*
995 Set the output baud rate of DEVICE to RATE.
996 On most systems, changing this value will affect the amount of padding
997 and other strategic decisions made during redisplay.
998 */ )
999 (device, rate)
1000 Lisp_Object device, rate;
1001 {
1002 CHECK_INT (rate);
1003
1004 DEVICE_BAUD_RATE (decode_device (device)) = XINT (rate);
1005
1006 return rate;
1007 }
1008
1009 DEFUN ("device-baud-rate", Fdevice_baud_rate, Sdevice_baud_rate,
1010 0, 1, 0 /*
1011 Return the output baud rate of DEVICE.
1012 */ )
1013 (device)
1014 Lisp_Object device;
1015 {
1016 return make_int (DEVICE_BAUD_RATE (decode_device (device)));
1017 }
1018
1019 void
1020 handle_asynch_device_change (void)
1021 {
1022 int i;
1023 int old_asynch_device_change_pending = asynch_device_change_pending;
1024 for (i = 0; i < Dynarr_length (the_console_type_entry_dynarr); i++)
1025 {
1026 if (Dynarr_at (the_console_type_entry_dynarr, i).meths->
1027 asynch_device_change_method)
1028 (Dynarr_at (the_console_type_entry_dynarr, i).meths->
1029 asynch_device_change_method) ();
1030 }
1031 /* reset the flag to 0 unless another notification occurred while
1032 we were processing this one. Block SIGWINCH during this
1033 check to prevent a possible race condition. */
1034 EMACS_BLOCK_SIGNAL (SIGWINCH);
1035 if (old_asynch_device_change_pending == asynch_device_change_pending)
1036 asynch_device_change_pending = 0;
1037 EMACS_UNBLOCK_SIGNAL (SIGWINCH);
1038 }
1039
1040 void
1041 call_critical_lisp_code (struct device *d, Lisp_Object function,
1042 Lisp_Object object)
1043 {
1044 int old_gc_currently_forbidden = gc_currently_forbidden;
1045 Lisp_Object old_inhibit_quit = Vinhibit_quit;
1046
1047 /* There's no reason to bother doing specbinds here, because if
1048 initialize-*-faces signals an error, emacs is going to crash
1049 immediately.
1050 */
1051 gc_currently_forbidden = 1;
1052 Vinhibit_quit = Qt;
1053 LOCK_DEVICE (d);
1054
1055 /* But it's useful to have an error handler; otherwise an infinite
1056 loop may result. */
1057 if (!NILP (object))
1058 call1_with_handler (Qreally_early_error_handler, function, object);
1059 else
1060 call0_with_handler (Qreally_early_error_handler, function);
1061
1062 UNLOCK_DEVICE (d);
1063 Vinhibit_quit = old_inhibit_quit;
1064 gc_currently_forbidden = old_gc_currently_forbidden;
1065 }
1066
1067
1068 /************************************************************************/
1069 /* initialization */
1070 /************************************************************************/
1071
1072 void
1073 syms_of_device (void)
1074 {
1075 defsubr (&Svalid_device_class_p);
1076 defsubr (&Sdevice_class_list);
1077
1078 defsubr (&Sdfw_device);
1079 defsubr (&Sselected_device);
1080 defsubr (&Sselect_device);
1081 defsubr (&Sset_device_selected_frame);
1082 defsubr (&Sdevicep);
1083 defsubr (&Sdevice_live_p);
1084 defsubr (&Sdevice_name);
1085 defsubr (&Sdevice_connection);
1086 defsubr (&Sdevice_console);
1087 defsubr (&Sfind_device);
1088 defsubr (&Sget_device);
1089 defsubr (&Smake_device);
1090 defsubr (&Sdelete_device);
1091 defsubr (&Sdevice_frame_list);
1092 defsubr (&Sdevice_class);
1093 defsubr (&Sset_device_class);
1094 defsubr (&Sdevice_pixel_width);
1095 defsubr (&Sdevice_pixel_height);
1096 defsubr (&Sdevice_mm_width);
1097 defsubr (&Sdevice_mm_height);
1098 defsubr (&Sdevice_bitplanes);
1099 defsubr (&Sdevice_color_cells);
1100 defsubr (&Sset_device_baud_rate);
1101 defsubr (&Sdevice_baud_rate);
1102
1103 defsymbol (&Qdevicep, "devicep");
1104 defsymbol (&Qdevice_live_p, "device-live-p");
1105 defsymbol (&Qdelete_device, "delete-device");
1106
1107 defsymbol (&Qcreate_device_hook, "create-device-hook");
1108 defsymbol (&Qdelete_device_hook, "delete-device-hook");
1109
1110 /* Qcolor defined in general.c */
1111 defsymbol (&Qgrayscale, "grayscale");
1112 defsymbol (&Qmono, "mono");
1113 }
1114
1115 void
1116 vars_of_device (void)
1117 {
1118 DEFVAR_LISP ("create-device-hook", &Vcreate_device_hook /*
1119 Function or functions to call when a device is created.
1120 One argument, the newly-created device.
1121 This is called after the first frame has been created, but before
1122 calling the `create-frame-hook'.
1123 Note that in general the device will not be selected.
1124 */ );
1125 Vcreate_device_hook = Qnil;
1126
1127 DEFVAR_LISP ("delete-device-hook", &Vdelete_device_hook /*
1128 Function or functions to call when a device is deleted.
1129 One argument, the to-be-deleted device.
1130 */ );
1131 Vdelete_device_hook = Qnil;
1132
1133 staticpro (&Vdefault_device);
1134 Vdefault_device = Qnil;
1135
1136 asynch_device_change_pending = 0;
1137
1138 Vdevice_class_list = list3 (Qcolor, Qgrayscale, Qmono);
1139 staticpro (&Vdevice_class_list);
1140 }