--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/device.c	Mon Aug 13 08:45:50 2007 +0200
@@ -0,0 +1,1140 @@
+/* Generic device functions.
+   Copyright (C) 1994, 1995 Board of Trustees, University of Illinois.
+   Copyright (C) 1994, 1995 Free Software Foundation, Inc.
+   Copyright (C) 1995, 1996 Ben Wing
+
+This file is part of XEmacs.
+
+XEmacs is free software; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by the
+Free Software Foundation; either version 2, or (at your option) any
+later version.
+
+XEmacs is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with XEmacs; see the file COPYING.  If not, write to
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+/* Synched up with: Not in FSF. */
+
+/* Original version by Chuck Thompson;
+   rewritten and expanded by Ben Wing. */
+
+#include <config.h>
+#include "lisp.h"
+
+#include "buffer.h"
+#include "console.h"
+#include "device.h"
+#include "elhash.h"
+#include "events.h"
+#include "faces.h"
+#include "frame.h"
+#include "keymap.h"
+#include "redisplay.h"
+#include "scrollbar.h"
+#include "specifier.h"
+#include "sysdep.h"
+#include "window.h"
+
+#include "syssignal.h"
+
+/* Vdefault_device is the firstly-created non-stream device that's still
+   around.  We don't really use it anywhere currently, but it might
+   be used for resourcing at some point.  (Currently we use
+   Vdefault_x_device.) */
+Lisp_Object Vdefault_device;
+
+Lisp_Object Vcreate_device_hook, Vdelete_device_hook;
+
+/* Device classes */
+/* Qcolor defined in general.c */
+Lisp_Object Qgrayscale, Qmono;
+
+Lisp_Object Qdevicep, Qdevice_live_p;
+Lisp_Object Qdelete_device;
+Lisp_Object Qcreate_device_hook;
+Lisp_Object Qdelete_device_hook;
+
+Lisp_Object Vdevice_class_list;
+
+MAC_DEFINE (struct device *, MTdevice_data)
+
+
+static Lisp_Object mark_device (Lisp_Object, void (*) (Lisp_Object));
+static void print_device (Lisp_Object, Lisp_Object, int);
+DEFINE_LRECORD_IMPLEMENTATION ("device", device,
+			       mark_device, print_device, 0, 0, 0,
+			       struct device);
+
+static Lisp_Object
+mark_device (Lisp_Object obj, void (*markobj) (Lisp_Object))
+{
+  struct device *d = XDEVICE (obj);
+
+  ((markobj) (d->name));
+  ((markobj) (d->connection));
+  ((markobj) (d->canon_connection));
+  ((markobj) (d->console));
+  ((markobj) (d->_selected_frame));
+  ((markobj) (d->frame_with_focus_real));
+  ((markobj) (d->frame_with_focus_for_hooks));
+  ((markobj) (d->frame_that_ought_to_have_focus));
+  ((markobj) (d->device_class));
+  ((markobj) (d->user_defined_tags));
+  ((markobj) (d->pixel_to_glyph_cache.obj1));
+  ((markobj) (d->pixel_to_glyph_cache.obj2));
+
+  ((markobj) (d->color_instance_cache));
+  ((markobj) (d->font_instance_cache));
+  ((markobj) (d->image_instance_cache));
+
+  if (d->devmeths)
+    {
+      ((markobj) (d->devmeths->symbol));
+      MAYBE_DEVMETH (d, mark_device, (d, markobj));
+    }
+
+  return (d->frame_list);
+}
+
+static void
+print_device (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
+{
+  struct device *d = XDEVICE (obj);
+  char buf[256];
+
+  if (print_readably)
+    error ("printing unreadable object #<device %s 0x%x>",
+	   string_data (XSTRING (d->name)), d->header.uid);
+
+  sprintf (buf, "#<%s-device", !DEVICE_LIVE_P (d) ? "dead" :
+	   DEVICE_TYPE_NAME (d));
+  write_c_string (buf, printcharfun);
+  if (DEVICE_LIVE_P (d))
+    {
+      write_c_string (" on ", printcharfun);
+      print_internal (DEVICE_CONNECTION (d), printcharfun, 1);
+    }
+  sprintf (buf, " 0x%x>", d->header.uid);
+  write_c_string (buf, printcharfun);
+}
+
+
+int
+valid_device_class_p (Lisp_Object class)
+{
+  return !NILP (memq_no_quit (class, Vdevice_class_list));
+}
+
+DEFUN ("valid-device-class-p", Fvalid_device_class_p, Svalid_device_class_p,
+       1, 1, 0 /*
+Given a DEVICE-CLASS, return t if it is valid.
+Valid classes are 'color, 'grayscale, and 'mono.
+*/ )
+     (device_class)
+     Lisp_Object device_class;
+{
+  if (valid_device_class_p (device_class))
+    return Qt;
+  else
+    return Qnil;
+}
+
+DEFUN ("device-class-list", Fdevice_class_list, Sdevice_class_list,
+       0, 0, 0 /*
+Return a list of valid device classes.
+*/ )
+     ()
+{
+  return Fcopy_sequence (Vdevice_class_list);
+}
+
+static struct device *
+allocate_device (Lisp_Object console)
+{
+  Lisp_Object device = Qnil;
+  struct device *d = alloc_lcrecord (sizeof (struct device), lrecord_device);
+  struct gcpro gcpro1;
+
+  zero_lcrecord (d);
+
+  XSETDEVICE (device, d);
+  GCPRO1 (device);
+
+  d->name = Qnil;
+  d->console = console;
+  d->connection = Qnil;
+  d->canon_connection = Qnil;
+  d->frame_list = Qnil;
+  d->_selected_frame = Qnil;
+  d->frame_with_focus_real = Qnil;
+  d->frame_with_focus_for_hooks = Qnil;
+  d->frame_that_ought_to_have_focus = Qnil;
+  d->device_class = Qnil;
+  d->user_defined_tags = Qnil;
+  d->pixel_to_glyph_cache.obj1 = Qnil;
+  d->pixel_to_glyph_cache.obj2 = Qnil;
+
+  d->infd = d->outfd = -1;
+
+  /* #### is 20 reasonable? */
+  d->color_instance_cache = make_lisp_hashtable (20, HASHTABLE_KEY_WEAK,
+						 HASHTABLE_EQUAL);
+  d->font_instance_cache = make_lisp_hashtable (20, HASHTABLE_KEY_WEAK,
+						HASHTABLE_EQUAL);
+  /*
+     Note that the image instance cache is actually bi-level.
+     See device.h.  We use a low number here because most of the
+     time there aren't very many diferent masks that will be used.
+     */
+  d->image_instance_cache = make_lisp_hashtable (5, HASHTABLE_NONWEAK,
+						 HASHTABLE_EQ);
+
+  UNGCPRO;
+  return d;
+}
+
+struct device *
+decode_device (Lisp_Object device)
+{
+  if (NILP (device))
+    device = Fselected_device (Qnil);
+  /* quietly accept frames for the device arg */
+  if (FRAMEP (device))
+    device = FRAME_DEVICE (decode_frame (device));
+  CHECK_LIVE_DEVICE (device);
+  return XDEVICE (device);
+}
+
+Lisp_Object
+make_device (struct device *d)
+{
+  Lisp_Object device = Qnil;
+  XSETDEVICE (device, d);
+  return device;
+}
+
+DEFUN ("dfw-device", Fdfw_device, Sdfw_device, 1, 1, 0 /*
+Given a device, frame, or window, return the associated device.
+Return nil otherwise.
+*/ )
+     (obj)
+     Lisp_Object obj;
+{
+  return DFW_DEVICE (obj);
+}
+
+
+DEFUN ("selected-device", Fselected_device, Sselected_device, 0, 1, 0 /*
+Return the device which is currently active.
+If optional CONSOLE is non-nil, return the device that would be currently
+active if CONSOLE were the selected console.
+*/ )
+  (console)
+     Lisp_Object console;
+{
+  if (NILP (console) && NILP (Vselected_console))
+    return Qnil; /* happens early in temacs */
+  return CONSOLE_SELECTED_DEVICE (decode_console (console));
+}
+
+/* Called from selected_frame_1(), called from Fselect_window() */
+void
+select_device_1 (Lisp_Object device)
+{
+  struct device *dev = XDEVICE (device);
+  Lisp_Object old_selected_device = Fselected_device (Qnil);
+  
+  if (EQ (device, old_selected_device))
+    return;
+
+  /* now select the device's console */
+  CONSOLE_SELECTED_DEVICE (XCONSOLE (DEVICE_CONSOLE (dev))) = device;
+  select_console_1 (DEVICE_CONSOLE (dev));
+}
+
+DEFUN ("select-device", Fselect_device, Sselect_device, 1, 1, 0 /*
+Select the device DEVICE.
+Subsequent editing commands apply to its console, selected frame,
+and selected window.
+The selection of DEVICE lasts until the next time the user does
+something to select a different device, or until the next time this
+function is called.
+*/ )
+  (device)
+     Lisp_Object device;
+{
+  CHECK_LIVE_DEVICE (device);
+
+  /* select the device's selected frame's selected window.  This will call
+     selected_frame_1()->selected_device_1()->selected_console_1(). */
+  if (!NILP (DEVICE_SELECTED_FRAME (XDEVICE (device))))
+    Fselect_window (FRAME_SELECTED_WINDOW
+		    (XFRAME (DEVICE_SELECTED_FRAME (XDEVICE (device)))));
+  else
+    error ("Can't select a device with no frames");
+  return Qnil;
+}
+
+void
+set_device_selected_frame (struct device *d, Lisp_Object frame)
+{
+  if (!NILP (frame) && !FRAME_MINIBUF_ONLY_P (XFRAME (frame)))
+    set_console_last_nonminibuf_frame (XCONSOLE (DEVICE_CONSOLE (d)), frame);
+  d->_selected_frame = frame;
+}
+
+DEFUN ("set-device-selected-frame", Fset_device_selected_frame,
+       Sset_device_selected_frame, 2, 2, 0 /*
+Set the selected frame of device object DEVICE to FRAME.
+If DEVICE is nil, the selected device is used.
+If DEVICE is the selected device, this makes FRAME the selected frame.
+*/ )
+  (device, frame)
+     Lisp_Object device, frame;
+{
+  XSETDEVICE (device, decode_device (device));
+  CHECK_LIVE_FRAME (frame);
+
+  if (! EQ (device, FRAME_DEVICE (XFRAME (frame))))
+    error ("In `set-device-selected-frame', FRAME is not on DEVICE");
+
+  if (EQ (device, Fselected_device (Qnil)))
+    return Fselect_frame (frame);
+
+  set_device_selected_frame (XDEVICE (device), frame);
+  return frame;
+}
+
+DEFUN ("devicep", Fdevicep, Sdevicep, 1, 1, 0 /*
+Return non-nil if OBJECT is a device.
+*/ )
+     (object)
+     Lisp_Object object;
+{
+  if (!DEVICEP (object))
+    return Qnil;
+  return Qt;
+}
+
+DEFUN ("device-live-p", Fdevice_live_p, Sdevice_live_p, 1, 1, 0 /*
+Return non-nil if OBJECT is a device that has not been deleted.
+*/ )
+     (object)
+     Lisp_Object object;
+{
+  if (!DEVICEP (object) || !DEVICE_LIVE_P (XDEVICE (object)))
+    return Qnil;
+  return Qt;
+}
+
+DEFUN ("device-name", Fdevice_name, Sdevice_name, 0, 1, 0 /*
+Return the name of the specified device.
+DEVICE defaults to the selected device if omitted.
+*/ )
+     (device)
+     Lisp_Object device;
+{
+  return DEVICE_NAME (decode_device (device));
+}
+
+DEFUN ("device-connection", Fdevice_connection, Sdevice_connection, 0, 1, 0 /*
+Return the connection of the specified device.
+DEVICE defaults to the selected device if omitted.
+*/ )
+     (device)
+     Lisp_Object device;
+{
+  return DEVICE_CONNECTION (decode_device (device));
+}
+
+DEFUN ("device-console", Fdevice_console, Sdevice_console, 0, 1, 0 /*
+Return the console of the specified device.
+DEVICE defaults to the selected device if omitted.
+*/ )
+     (device)
+     Lisp_Object device;
+{
+  return DEVICE_CONSOLE (decode_device (device));
+}
+
+#ifdef HAVE_X_WINDOWS
+extern Lisp_Object Vdefault_x_device;
+#endif
+#ifdef HAVE_NEXTSTEP
+extern Lisp_Object Vdefault_ns_device;
+#endif
+
+#ifdef HAVE_X_WINDOWS
+
+static void
+init_global_resources (struct device *d)
+{
+  init_global_faces (d);
+#ifdef HAVE_SCROLLBARS
+  init_global_scrollbars (d);
+#endif
+#ifdef HAVE_TOOLBARS
+  init_global_toolbars (d);
+#endif
+}
+
+#endif
+
+static void
+init_device_resources (struct device *d)
+{
+  init_device_faces (d);
+#ifdef HAVE_SCROLLBARS
+  init_device_scrollbars (d);
+#endif
+#ifdef HAVE_TOOLBARS
+  init_device_toolbars (d);
+#endif
+}
+
+static Lisp_Object
+semi_canonicalize_device_connection (struct console_methods *meths,
+				     Lisp_Object name, Error_behavior errb)
+{
+  return CONTYPE_METH_OR_GIVEN (meths, semi_canonicalize_device_connection,
+				(name, errb), name);
+}
+
+static Lisp_Object
+canonicalize_device_connection (struct console_methods *meths,
+				Lisp_Object name, Error_behavior errb)
+{
+  return CONTYPE_METH_OR_GIVEN (meths, canonicalize_device_connection,
+				(name, errb), name);
+}
+
+static Lisp_Object
+find_device_of_type (struct console_methods *meths, Lisp_Object canon)
+{
+  Lisp_Object devcons, concons;
+
+  DEVICE_LOOP_NO_BREAK (devcons, concons)
+    {
+      Lisp_Object device = XCAR (devcons);
+
+      if (EQ (CONMETH_TYPE (meths), DEVICE_TYPE (XDEVICE (device)))
+	  && !NILP (Fequal (DEVICE_CANON_CONNECTION (XDEVICE (device)),
+			    canon)))
+	return device;
+    }
+
+  return Qnil;
+}
+
+DEFUN ("find-device", Ffind_device, Sfind_device, 1, 2, 0 /*
+Look for an existing device attached to connection CONNECTION.
+Return the device if found; otherwise, return nil.
+
+If TYPE is specified, only return devices of that type; otherwise,
+return devices of any type. (It is possible, although unlikely,
+that two devices of different types could have the same connection
+name; in such a case, the first device found is returned.)
+*/ )
+  (connection, type)
+     Lisp_Object connection, type;
+{
+  Lisp_Object canon = Qnil;
+  struct gcpro gcpro1;
+
+  GCPRO1 (canon);
+
+  if (!NILP (type))
+    {
+      struct console_methods *conmeths = decode_console_type (type, ERROR_ME);
+      canon = canonicalize_device_connection (conmeths, connection,
+					      ERROR_ME_NOT);
+      if (UNBOUNDP (canon))
+	RETURN_UNGCPRO (Qnil);
+
+      RETURN_UNGCPRO (find_device_of_type (conmeths, canon));
+    }
+  else
+    {
+      int i;
+
+      for (i = 0; i < Dynarr_length (the_console_type_entry_dynarr); i++)
+	{
+	  struct console_methods *conmeths =
+	    Dynarr_at (the_console_type_entry_dynarr, i).meths;
+	  canon = canonicalize_device_connection (conmeths, connection,
+						  ERROR_ME_NOT);
+	  if (!UNBOUNDP (canon))
+	    {
+	      Lisp_Object device = find_device_of_type (conmeths, canon);
+	      if (!NILP (device))
+		RETURN_UNGCPRO (device);
+	    }
+	}
+
+      RETURN_UNGCPRO (Qnil);
+    }
+}
+
+DEFUN ("get-device", Fget_device, Sget_device, 1, 2, 0 /*
+Look for an existing device attached to connection CONNECTION.
+Return the device if found; otherwise, signal an error.
+
+If TYPE is specified, only return devices of that type; otherwise,
+return devices of any type. (It is possible, although unlikely,
+that two devices of different types could have the same connection
+name; in such a case, the first device found is returned.)
+*/ )
+  (connection, type)
+     Lisp_Object connection, type;
+{
+  Lisp_Object device = Ffind_device (connection, type);
+  if (NILP (device))
+    {
+      if (NILP (type))
+	signal_simple_error ("No such device", connection);
+      else
+	signal_simple_error_2 ("No such device", type, connection);
+    }
+  return device;
+}
+
+DEFUN ("make-device", Fmake_device, Smake_device, 2, 3, 0 /*
+Create a new device of type TYPE, attached to connection CONNECTION.
+
+The valid values for CONNECTION are device-specific; however,
+CONNECTION is generally a string. (Specifically, for X devices,
+CONNECTION should be a display specification such as "foo:0", and
+for TTY devices, CONNECTION should be the filename of a TTY device
+file, such as "/dev/ttyp4", or nil to refer to XEmacs' standard
+input/output.)
+
+PROPS, if specified, should be a plist of properties controlling
+device creation.
+
+If CONNECTION specifies an already-existing device connection, that
+device is simply returned; no new device is created, and PROPS
+have no effect.
+*/ )
+     (type, connection, props)
+     Lisp_Object type, connection, props;
+{
+  /* This function can GC */
+  struct device *d;
+  struct console *con;
+  Lisp_Object device = Qnil;
+  Lisp_Object console = Qnil;
+  Lisp_Object name = Qnil;
+  struct console_methods *conmeths;
+
+  struct gcpro gcpro1, gcpro2, gcpro3;
+#ifdef HAVE_X_WINDOWS
+  /* #### icky-poo.  If this is the first X device we are creating,
+     then retrieve the global face resources.  We have to do it
+     here, at the same time as (or just before) the device face
+     resources are retrieved; specifically, it needs to be done
+     after the device has been created but before any frames have
+     been popped up or much anything else has been done.  It's
+     possible for other devices to specify different global
+     resources (there's a property on each X server's root window
+     that holds some resources); tough luck for the moment.
+
+     This is a nasty violation of device independence, but
+     there's not a whole lot I can figure out to do about it.
+     The real problem is that the concept of resources is not
+     generalized away from X.  Similar resource-related
+     device-independence violations occur in faces.el. */
+  int first_x_device = NILP (Vdefault_x_device) && EQ (type, Qx);
+#endif
+
+  GCPRO3 (device, console, name);
+
+  conmeths = decode_console_type (type, ERROR_ME_NOT);
+  if (!conmeths)
+    signal_simple_error ("Invalid device type", type);
+
+  device = Ffind_device (connection, type);
+  if (!NILP (device))
+    RETURN_UNGCPRO (device);
+
+  name = Fplist_get (props, Qname, Qnil);
+
+  {
+    Lisp_Object conconnect =
+      CONTYPE_METH_OR_GIVEN (conmeths,
+			     device_to_console_connection,
+			     (connection, ERROR_ME),
+			     connection);
+    console = create_console (name, type, conconnect, props);
+  }
+
+  con = XCONSOLE (console);
+  d = allocate_device (console);
+  XSETDEVICE (device, d);
+
+  d->devmeths = con->conmeths;
+
+  DEVICE_NAME (d) = name;
+  DEVICE_CONNECTION (d) = semi_canonicalize_device_connection (conmeths,
+							       connection,
+							       ERROR_ME);
+  DEVICE_CANON_CONNECTION (d) = canonicalize_device_connection (conmeths,
+								connection,
+								ERROR_ME);
+
+  MAYBE_DEVMETH (d, init_device, (d, props));
+
+  /* Do it this way so that the device list is in order of creation */
+  con->device_list = nconc2 (con->device_list, Fcons (device, Qnil));
+  RESET_CHANGED_SET_FLAGS;
+  if (NILP (Vdefault_device) || DEVICE_STREAM_P (XDEVICE (Vdefault_device)))
+    Vdefault_device = device;
+
+  init_device_sound (d);
+#ifdef HAVE_X_WINDOWS
+  if (first_x_device)
+    init_global_resources (d);
+#endif
+  init_device_resources (d);
+
+  MAYBE_DEVMETH (d, finish_init_device, (d, props));
+
+  /* If this is the first device on the console, make it the selected one. */
+  if (NILP (CONSOLE_SELECTED_DEVICE (con)))
+    CONSOLE_SELECTED_DEVICE (con) = device;
+
+  /* #### the following should trap errors. */
+  setup_device_initial_specifier_tags (d);
+
+  UNGCPRO;
+  return device;
+}
+
+/* find a device other than the selected one.  Prefer non-stream
+   devices over stream devices.  Maybe stay on the same console. */
+
+static Lisp_Object
+find_other_device (Lisp_Object device, int on_same_console)
+{
+  Lisp_Object devcons = Qnil, concons = Qnil;
+  Lisp_Object console = DEVICE_CONSOLE (XDEVICE (device));
+
+  /* look for a non-stream device */
+  DEVICE_LOOP_NO_BREAK (devcons, concons)
+    {
+      Lisp_Object dev = XCAR (devcons);
+      if (on_same_console && !EQ (console, DEVICE_CONSOLE (XDEVICE (dev))))
+	continue;
+      if (!DEVICE_STREAM_P (XDEVICE (dev)) && !EQ (dev, device) &&
+	  !NILP (DEVICE_SELECTED_FRAME (XDEVICE (dev))))
+	goto double_break_1;
+    }
+
+ double_break_1:
+  if (!NILP (devcons))
+    return XCAR (devcons);
+
+  /* OK, now look for a stream device */
+  DEVICE_LOOP_NO_BREAK (devcons, concons)
+    {
+      Lisp_Object dev = XCAR (devcons);
+      if (on_same_console && !EQ (console, DEVICE_CONSOLE (XDEVICE (dev))))
+	continue;
+      if (!EQ (dev, device) && !NILP (DEVICE_SELECTED_FRAME (XDEVICE (dev))))
+	goto double_break_2;
+    }
+ double_break_2:
+  if (!NILP (devcons))
+    return XCAR (devcons);
+
+  /* Sorry, there ain't none */
+  return Qnil;
+}
+
+static int
+find_nonminibuffer_frame_not_on_device_predicate (Lisp_Object frame,
+						  void *closure)
+{
+  Lisp_Object device;
+
+  VOID_TO_LISP (device, closure);
+  if (FRAME_MINIBUF_ONLY_P (XFRAME (frame)))
+    return 0;
+  if (EQ (device, FRAME_DEVICE (XFRAME (frame))))
+    return 0;
+  return 1;
+}
+
+Lisp_Object
+find_nonminibuffer_frame_not_on_device (Lisp_Object device)
+{
+  return find_some_frame (find_nonminibuffer_frame_not_on_device_predicate,
+			  LISP_TO_VOID (device));
+}
+
+
+/* Delete device D.
+
+   If FORCE is non-zero, allow deletion of the only frame.
+
+   If CALLED_FROM_DELETE_CONSOLE is non-zero, then, if
+   deleting the last device on a console, just delete it,
+   instead of calling `delete-console'.
+
+   If FROM_IO_ERROR is non-zero, then the device is gone due
+   to an I/O error.  This affects what happens if we exit
+   (we do an emergency exit instead of `save-buffers-kill-emacs'.)
+*/
+
+void
+delete_device_internal (struct device *d, int force,
+			int called_from_delete_console,
+			int from_io_error)
+{
+  /* This function can GC */
+  struct console *c;
+  Lisp_Object device = Qnil;
+  struct gcpro gcpro1;
+
+  /* OK to delete an already-deleted device. */
+  if (!DEVICE_LIVE_P (d))
+    return;
+
+  XSETDEVICE (device, d);
+  GCPRO1 (device);
+
+  c = XCONSOLE (DEVICE_CONSOLE (d));
+
+  if (!called_from_delete_console)
+    {
+      int delete_console = 0;
+      /* If we're deleting the only device on the console,
+	 delete the console. */
+      if ((XINT (Flength (CONSOLE_DEVICE_LIST (c))) == 1)
+	  /* if we just created the device, it might not be listed,
+	     or something ... */
+	  && !NILP (memq_no_quit (device, CONSOLE_DEVICE_LIST (c))))
+	delete_console = 1;
+      /* Or if there aren't any nonminibuffer frames that would be
+	 left, delete the console (this will make XEmacs exit). */
+      else if (NILP (find_nonminibuffer_frame_not_on_device (device)))
+	delete_console = 1;
+
+      if (delete_console)
+	{
+	  delete_console_internal (c, force, 0, from_io_error);
+	  UNGCPRO;
+	  return;
+	}
+    }
+
+  reset_one_device (d);
+
+  {
+    Lisp_Object frmcons;
+
+    /* First delete all frames without their own minibuffers,
+       to avoid errors coming from attempting to delete a frame
+       that is a surrogate for another frame. */
+    DEVICE_FRAME_LOOP (frmcons, d)
+      {
+	struct frame *f = XFRAME (XCAR (frmcons));
+	/* delete_frame_internal() might do anything such as run hooks,
+	   so be defensive. */
+	if (FRAME_LIVE_P (f) && !FRAME_HAS_MINIBUF_P (f))
+	  delete_frame_internal (f, 1, 1, from_io_error);
+
+	if (!DEVICE_LIVE_P (d)) /* make sure the delete-*-hook didn't
+				   go ahead and delete anything */
+	  {
+	    UNGCPRO;
+	    return;
+	  }
+      }
+
+    /* #### This should probably be a device method but it is time for
+       19.14 to go out the door. */
+#ifdef HAVE_X_WINDOWS
+    /* Next delete all frames which have the popup property to avoid
+       deleting a child after its parent. */
+    DEVICE_FRAME_LOOP (frmcons, d)
+      {
+	struct frame *f = XFRAME (XCAR (frmcons));
+
+	if (FRAME_LIVE_P (f))
+	  {
+	    Lisp_Object popup = Fframe_property (XCAR (frmcons), Qpopup, Qnil);
+	    if (!NILP (popup))
+	      delete_frame_internal (f, 1, 1, from_io_error);
+
+	    if (!DEVICE_LIVE_P (d)) /* make sure the delete-*-hook didn't
+				       go ahead and delete anything */
+	      {
+		UNGCPRO;
+		return;
+	      }
+	  }
+      }
+#endif /* HAVE_X_WINDOWS */
+
+    DEVICE_FRAME_LOOP (frmcons, d)
+      {
+	struct frame *f = XFRAME (XCAR (frmcons));
+	/* delete_frame_internal() might do anything such as run hooks,
+	   so be defensive. */
+	if (FRAME_LIVE_P (f))
+	  delete_frame_internal (f, 1, 1, from_io_error);
+
+	if (!DEVICE_LIVE_P (d)) /* make sure the delete-*-hook didn't
+				   go ahead and delete anything */
+	  {
+	    UNGCPRO;
+	    return;
+	  }
+      }
+  }
+
+  set_device_selected_frame (d, Qnil);
+
+  /* try to select another device */
+
+  if (EQ (device, Fselected_device (DEVICE_CONSOLE (d))))
+    {
+      Lisp_Object other_dev = find_other_device (device, 1);
+      if (!NILP (other_dev))
+	Fselect_device (other_dev);
+    }
+
+  if (EQ (device, Vdefault_device))
+    Vdefault_device = find_other_device (device, 0);
+
+  MAYBE_DEVMETH (d, delete_device, (d));
+
+  CONSOLE_DEVICE_LIST (c) = delq_no_quit (device, CONSOLE_DEVICE_LIST (c));
+  RESET_CHANGED_SET_FLAGS;
+  d->devmeths = dead_console_methods;
+  UNGCPRO;
+}
+
+/* delete a device as a result of an I/O error.  Called from
+   an enqueued magic-eval event. */
+
+void
+io_error_delete_device (Lisp_Object device)
+{
+  delete_device_internal (XDEVICE (device), 1, 0, 1);
+}
+
+DEFUN ("delete-device", Fdelete_device, Sdelete_device, 1, 2, 0 /*
+Delete DEVICE, permanently eliminating it from use.
+Normally, you cannot delete the last non-minibuffer-only frame (you must
+use `save-buffers-kill-emacs' or `kill-emacs').  However, if optional
+second argument FORCE is non-nil, you can delete the last frame. (This
+will automatically call `save-buffers-kill-emacs'.)
+*/ )
+     (device, force)
+     Lisp_Object device, force;
+{
+  CHECK_DEVICE (device);
+  delete_device_internal (XDEVICE (device), !NILP (force), 0, 0);
+  return Qnil;
+}
+
+DEFUN ("device-frame-list", Fdevice_frame_list, Sdevice_frame_list,
+       0, 1, 0 /*
+Return a list of all frames on DEVICE.
+If DEVICE is nil, the selected device will be used.
+*/ )
+  (device)
+     Lisp_Object device;
+{
+  return Fcopy_sequence (DEVICE_FRAME_LIST (decode_device (device)));
+}
+
+DEFUN ("device-class", Fdevice_class, Sdevice_class,
+       0, 1, 0 /*
+Return the class (color behavior) of DEVICE.
+This will be one of 'color, 'grayscale, or 'mono.
+*/ )
+     (device)
+     Lisp_Object device;
+{
+  return DEVICE_CLASS (decode_device (device));
+}
+
+DEFUN ("set-device-class", Fset_device_class, Sset_device_class,
+       2, 2, 0 /*
+Set the class (color behavior) of DEVICE.
+CLASS should be one of 'color, 'grayscale, or 'mono.
+This is only allowed on device such as TTY devices, where the color
+behavior cannot necessarily be determined automatically.
+*/ )
+     (device, class)
+     Lisp_Object device, class;
+{
+  struct device *d = decode_device (device);
+  XSETDEVICE (device, d);
+  if (!DEVICE_TTY_P (d))
+    signal_simple_error ("Cannot change the class of this device", device);
+  if (!EQ (class, Qcolor) && !EQ (class, Qmono) && !EQ (class, Qgrayscale))
+    signal_simple_error ("Must be color, mono, or grayscale", class);
+  DEVICE_CLASS (d) = class;
+  return Qnil;
+}
+
+DEFUN ("device-pixel-width", Fdevice_pixel_width, Sdevice_pixel_width,
+       0, 1, 0 /*
+Return the width in pixels of DEVICE, or nil if unknown.
+*/ )
+     (device)
+  Lisp_Object device;
+{
+  struct device *d = decode_device (device);
+  int retval;
+
+  retval = DEVMETH_OR_GIVEN (d, device_pixel_width, (d), 0);
+  if (retval <= 0)
+    return Qnil;
+
+  return make_int (retval);
+}
+
+DEFUN ("device-pixel-height", Fdevice_pixel_height, Sdevice_pixel_height,
+       0, 1, 0 /*
+Return the height in pixels of DEVICE, or nil if unknown.
+*/ )
+     (device)
+  Lisp_Object device;
+{
+  struct device *d = decode_device (device);
+  int retval;
+
+  retval = DEVMETH_OR_GIVEN (d, device_pixel_height, (d), 0);
+  if (retval <= 0)
+    return Qnil;
+
+  return make_int (retval);
+}
+
+DEFUN ("device-mm-width", Fdevice_mm_width, Sdevice_mm_width,
+       0, 1, 0 /*
+Return the width in millimeters of DEVICE, or nil if unknown.
+*/ )
+     (device)
+  Lisp_Object device;
+{
+  struct device *d = decode_device (device);
+  int retval;
+
+  retval = DEVMETH_OR_GIVEN (d, device_mm_width, (d), 0);
+  if (retval <= 0)
+    return Qnil;
+
+  return make_int (retval);
+}
+
+DEFUN ("device-mm-height", Fdevice_mm_height, Sdevice_mm_height,
+       0, 1, 0 /*
+Return the height in millimeters of DEVICE, or nil if unknown.
+*/ )
+     (device)
+  Lisp_Object device;
+{
+  struct device *d = decode_device (device);
+  int retval;
+
+  retval = DEVMETH_OR_GIVEN (d, device_mm_height, (d), 0);
+  if (retval <= 0)
+    return Qnil;
+
+  return make_int (retval);
+}
+
+DEFUN ("device-bitplanes", Fdevice_bitplanes, Sdevice_bitplanes,
+       0, 1, 0 /*
+Return the number of bitplanes of DEVICE, or nil if unknown.
+*/ )
+     (device)
+  Lisp_Object device;
+{
+  struct device *d = decode_device (device);
+  int retval;
+
+  retval = DEVMETH_OR_GIVEN (d, device_bitplanes, (d), 0);
+  if (retval <= 0)
+    return Qnil;
+
+  return make_int (retval);
+}
+
+DEFUN ("device-color-cells", Fdevice_color_cells, Sdevice_color_cells,
+       0, 1, 0 /*
+Return the number of color cells of DEVICE, or nil if unknown.
+*/ )
+     (device)
+  Lisp_Object device;
+{
+  struct device *d = decode_device (device);
+  int retval;
+
+  retval = DEVMETH_OR_GIVEN (d, device_color_cells, (d), 0);
+  if (retval <= 0)
+    return Qnil;
+
+  return make_int (retval);
+}
+
+DEFUN ("set-device-baud-rate", Fset_device_baud_rate, Sset_device_baud_rate,
+       2, 2, 0 /*
+Set the output baud rate of DEVICE to RATE.
+On most systems, changing this value will affect the amount of padding
+and other strategic decisions made during redisplay.
+*/ )
+     (device, rate)
+     Lisp_Object device, rate;
+{
+  CHECK_INT (rate);
+
+  DEVICE_BAUD_RATE (decode_device (device)) = XINT (rate);
+
+  return rate;
+}
+
+DEFUN ("device-baud-rate", Fdevice_baud_rate, Sdevice_baud_rate,
+       0, 1, 0 /*
+Return the output baud rate of DEVICE.
+*/ )
+     (device)
+     Lisp_Object device;
+{
+  return make_int (DEVICE_BAUD_RATE (decode_device (device)));
+}
+
+void
+handle_asynch_device_change (void)
+{
+  int i;
+  int old_asynch_device_change_pending = asynch_device_change_pending;
+  for (i = 0; i < Dynarr_length (the_console_type_entry_dynarr); i++)
+    {
+      if (Dynarr_at (the_console_type_entry_dynarr, i).meths->
+	  asynch_device_change_method)
+	(Dynarr_at (the_console_type_entry_dynarr, i).meths->
+	 asynch_device_change_method) ();
+    }
+  /* reset the flag to 0 unless another notification occurred while
+     we were processing this one.  Block SIGWINCH during this
+     check to prevent a possible race condition. */
+  EMACS_BLOCK_SIGNAL (SIGWINCH);
+  if (old_asynch_device_change_pending == asynch_device_change_pending)
+    asynch_device_change_pending = 0;
+  EMACS_UNBLOCK_SIGNAL (SIGWINCH);
+}
+
+void
+call_critical_lisp_code (struct device *d, Lisp_Object function,
+			 Lisp_Object object)
+{
+  int old_gc_currently_forbidden = gc_currently_forbidden;
+  Lisp_Object old_inhibit_quit = Vinhibit_quit;
+
+  /* There's no reason to bother doing specbinds here, because if
+     initialize-*-faces signals an error, emacs is going to crash
+     immediately.
+     */
+  gc_currently_forbidden = 1;
+  Vinhibit_quit = Qt;
+  LOCK_DEVICE (d);
+
+  /* But it's useful to have an error handler; otherwise an infinite
+     loop may result. */
+  if (!NILP (object))
+    call1_with_handler (Qreally_early_error_handler, function, object);
+  else
+    call0_with_handler (Qreally_early_error_handler, function);
+      
+  UNLOCK_DEVICE (d);
+  Vinhibit_quit = old_inhibit_quit;
+  gc_currently_forbidden = old_gc_currently_forbidden;
+}
+
+
+/************************************************************************/
+/*                            initialization                            */
+/************************************************************************/
+
+void
+syms_of_device (void)
+{
+  defsubr (&Svalid_device_class_p);
+  defsubr (&Sdevice_class_list);
+
+  defsubr (&Sdfw_device);
+  defsubr (&Sselected_device);
+  defsubr (&Sselect_device);
+  defsubr (&Sset_device_selected_frame);
+  defsubr (&Sdevicep);
+  defsubr (&Sdevice_live_p);
+  defsubr (&Sdevice_name);
+  defsubr (&Sdevice_connection);
+  defsubr (&Sdevice_console);
+  defsubr (&Sfind_device);
+  defsubr (&Sget_device);
+  defsubr (&Smake_device);
+  defsubr (&Sdelete_device);
+  defsubr (&Sdevice_frame_list);
+  defsubr (&Sdevice_class);
+  defsubr (&Sset_device_class);
+  defsubr (&Sdevice_pixel_width);
+  defsubr (&Sdevice_pixel_height);
+  defsubr (&Sdevice_mm_width);
+  defsubr (&Sdevice_mm_height);
+  defsubr (&Sdevice_bitplanes);
+  defsubr (&Sdevice_color_cells);
+  defsubr (&Sset_device_baud_rate);
+  defsubr (&Sdevice_baud_rate);
+
+  defsymbol (&Qdevicep, "devicep");
+  defsymbol (&Qdevice_live_p, "device-live-p");
+  defsymbol (&Qdelete_device, "delete-device");
+
+  defsymbol (&Qcreate_device_hook, "create-device-hook");
+  defsymbol (&Qdelete_device_hook, "delete-device-hook");
+
+  /* Qcolor defined in general.c */
+  defsymbol (&Qgrayscale, "grayscale");
+  defsymbol (&Qmono, "mono");
+}
+
+void
+vars_of_device (void)
+{
+  DEFVAR_LISP ("create-device-hook", &Vcreate_device_hook /*
+Function or functions to call when a device is created.
+One argument, the newly-created device.
+This is called after the first frame has been created, but before
+  calling the `create-frame-hook'.
+Note that in general the device will not be selected.
+*/ );
+  Vcreate_device_hook = Qnil;
+
+  DEFVAR_LISP ("delete-device-hook", &Vdelete_device_hook /*
+Function or functions to call when a device is deleted.
+One argument, the to-be-deleted device.
+*/ );
+  Vdelete_device_hook = Qnil;
+
+  staticpro (&Vdefault_device);
+  Vdefault_device = Qnil;
+
+  asynch_device_change_pending = 0;
+
+  Vdevice_class_list = list3 (Qcolor, Qgrayscale, Qmono);
+  staticpro (&Vdevice_class_list);
+}