ftp.nice.ch/pub/next/unix/editor/xemacs.19.13.s.tar.gz#/xemacs-19.13/src/device.c

This is device.c in view mode; [Download] [Up]

/* Generic device functions.
   Copyright (C) 1994, 1995 Board of Trustees, University of Illinois
   Copyright (C) 1994, 1995 Amdahl Corporation

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, 675 Mass Ave, Cambridge, MA 02139, USA.  */

/* Synched up with: Not in FSF. */

/* Original version by Chuck Thompson;
   rewritten by Ben Wing. */

#include <config.h>
#include "lisp.h"

#include "buffer.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 "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 Vdevice_list, Vselected_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;

DEFINE_DEVICE_TYPE (dead);

Lisp_Object Vdevice_class_list;
Lisp_Object Vdevice_type_list;

MAC_DEFINE (struct device *, mactemp_device_data);
MAC_DEFINE (struct device_methods *, mactemp_devtype_meth_or_given);

struct device_type_entry
{
  Lisp_Object symbol;
  struct device_methods *meths;
};

typedef struct device_type_entry_dynarr_type
{
  Dynarr_declare (struct device_type_entry);
} device_type_entry_dynarr;

device_type_entry_dynarr *the_device_type_entry_dynarr;



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->selected_frame));
  ((markobj) (d->frame_with_focus));
  ((markobj) (d->frame_that_ought_to_have_focus));
  ((markobj) (d->device_class));
  ((markobj) (d->function_key_map));
  ((markobj) (d->user_defined_tags));
  ((markobj) (d->pixel_to_glyph_cache.obj));

  ((markobj) (d->color_instance_cache));
  ((markobj) (d->font_instance_cache));
  ((markobj) (d->image_instance_cache));

  if (d->methods)
    ((markobj) (d->methods->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);
  print_internal (DEVICE_NAME (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));
}

struct device_methods *
decode_device_type (Lisp_Object type, int no_error)
{
  int i;

  for (i = 0; i < Dynarr_length (the_device_type_entry_dynarr); i++)
    {
      if (EQ (type, Dynarr_at (the_device_type_entry_dynarr, i).symbol))
	return Dynarr_at (the_device_type_entry_dynarr, i).meths;
    }

  if (!no_error)
    signal_simple_error ("Invalid device type", type);

  return 0;
}

int
valid_device_type_p (Lisp_Object type)
{
  if (decode_device_type (type, 1))
    return 1;
  return 0;
}

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.\n\
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 ("valid-device-type-p", Fvalid_device_type_p, Svalid_device_type_p,
       1, 1, 0,
       "Given a DEVICE-TYPE, return t if it is valid.\n\
Valid types are 'x, 'tty, and 'stream.")
     (device_type)
     Lisp_Object device_type;
{
  if (valid_device_type_p (device_type))
    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);
}

DEFUN ("device-type-list", Fdevice_type_list, Sdevice_type_list,
       0, 0, 0,
       "Return a list of valid device types.")
     ()
{
  return Fcopy_sequence (Vdevice_type_list);
}

static struct device *
allocate_device (void)
{
  Lisp_Object device = Qnil;
  struct device *d = alloc_lcrecord (sizeof (struct device), lrecord_device);

  zero_lcrecord (d);
  XSETDEVICE (device, d);

  d->name = Qnil;
  d->frame_list = Qnil;
  d->selected_frame = Qnil;
  d->frame_with_focus = Qnil;
  d->frame_that_ought_to_have_focus = Qnil;
  d->device_class = Qnil;
  d->function_key_map = Qnil;
  d->user_defined_tags = Qnil;
  d->pixel_to_glyph_cache.obj = Qnil;

  d->infd = d->outfd = -1;

  /* #### is 20 reasonable? */
  d->color_instance_cache = make_lisp_hashtable (20, lisp_string_equal,
						 lisp_string_hash,
						 HASHTABLE_KEY_WEAK);
  d->font_instance_cache = make_lisp_hashtable (20, lisp_string_equal,
						lisp_string_hash,
						HASHTABLE_KEY_WEAK);
  /*
     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, 0, 0,
						 HASHTABLE_NONWEAK);

  d->quit_char = 7; /* C-g */

  return d;
}

struct device *
get_device (Lisp_Object device)
{
  if (NILP (device))
    device = Fselected_device ();
  /* quietly accept frames for the device arg */
  if (FRAMEP (device))
    {
      CHECK_LIVE_FRAME (device, 0);
      device = XFRAME (device)->device;
    }
  else
    {
      CHECK_LIVE_DEVICE (device, 0);
    }
  return XDEVICE (device);
}

DEFUN ("dfw-device", Fdfw_device, Sdfw_device, 1, 1, 0,
  "Given a device, frame, or window, return the associated device.\n\
Return nil otherwise.")
     (obj)
     Lisp_Object obj;
{
  return DFW_DEVICE (obj);
}


DEFUN ("selected-device", Fselected_device, Sselected_device, 0, 0, 0,
       "Return the device which is currently active.")
     ()
{
  return Vselected_device;
}

/* Called from selected_frame_1(), called from Fselect_window() */
void
select_device_1 (Lisp_Object device)
{
  /* perhaps this should do something more complicated */
  Vselected_device = device;

  /* #### Schedule this to be removed in 19.14 */
#ifdef HAVE_X_WINDOWS
  if (DEVICE_IS_X (XDEVICE (device)))
    Vwindow_system = Qx;
  else
#endif
#ifdef HAVE_NEXTSTEP
  if (DEVICE_IS_NS (XDEVICE (device)))
    Vwindow_system = Qns;
  else
#endif
    Vwindow_system = Qnil;
}

DEFUN ("select-device", Fselect_device, Sselect_device, 1, 1, 0,
  "Select the device DEVICE.\n\
Subsequent editing commands apply to its selected frame and selected window.\n\
The selection of DEVICE lasts until the next time the user does\n\
something to select a different device, or until the next time this\n\
function is called.")
  (device)
     Lisp_Object device;
{
  CHECK_LIVE_DEVICE (device, 0);

  /* select the device's selected frame's selected window.  This will call
     selected_frame_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;
}

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-type", Fdevice_type, Sdevice_type, 0, 1, 0,
       "Return the type of the specified device (e.g. `x' or `tty').\n\
Value is `tty' for a tty device (a character-only terminal),\n\
`x' for a device which is a connection to an X server,\n\
`stream' for a stream device (which acts like a stdio stream), and\n\
`dead' for a deleted device.")
     (device)
     Lisp_Object device;
{
  /* don't call get_device() because we want to allow for dead devices. */
  if (NILP (device))
    device = Fselected_device ();
  CHECK_DEVICE (device, 0);
  return DEVICE_TYPE (XDEVICE (device));
}

DEFUN ("device-name", Fdevice_name, Sdevice_name, 0, 1, 0,
       "Return the name of the specified device.")
     (device)
     Lisp_Object device;
{
  return DEVICE_NAME (get_device (device));
}

#ifdef HAVE_X_WINDOWS
extern Lisp_Object Vdefault_x_device;
#endif
#ifdef HAVE_NEXTSTEP
extern Lisp_Object Vdefault_ns_device;
#endif

static void
init_global_resources (struct device *d)
{
  init_global_faces (d);
  init_global_scrollbars (d);
  init_global_toolbars (d);
}

static void
init_device_resources (struct device *d)
{
  init_device_faces (d);
  init_device_scrollbars (d);
  init_device_toolbars (d);
}

DEFUN ("make-device", Fmake_device, Smake_device, 1, 2, 0,
       "Create a new device of type TYPE.\n\
PARAMS, if specified, should be an alist of parameters controlling\n\
device creation.")
     (type, params)
     Lisp_Object type, params;
{
  /* This function can GC */
  struct device *d;
  Lisp_Object device = Qnil;
  struct gcpro gcpro1;
#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

  GCPRO1 (device);

  if (!valid_device_type_p (type))
    signal_simple_error ("Invalid device type", type);

  d = allocate_device ();
  XSETDEVICE (device, d);

  d->methods = decode_device_type (type, 0);

  DEVICE_NAME (d) = Fcdr_safe (Fassq (Qname, params));
  DEVMETH (d, init_device, (d, params));

  /* Do it this way so that the device list is in order of creation */
  Vdevice_list = nconc2 (Vdevice_list, Fcons (device, Qnil));
  RESET_CHANGED_SET_FLAGS;
  if (NILP (Vdefault_device) || DEVICE_IS_STREAM (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);

  if (DEVMETH (d, initially_selected_for_input, (d)))
    event_stream_select_device (d);

  /* #### the following should trap errors.  However, if an error
     occurs, all that will happen is that the create-device-hook
     doesn't get run. */
  setup_device_initial_specifier_tags (d);

  run_hook_with_args (Qcreate_device_hook, 1, device);

  UNGCPRO;
  return device;
}

void
add_entry_to_device_type_list (Lisp_Object symbol,
			       struct device_methods *meths)
{
  struct device_type_entry entry;

  entry.symbol = symbol;
  entry.meths = meths;
  Dynarr_add (the_device_type_entry_dynarr, entry);
  Vdevice_type_list = Fcons (symbol, Vdevice_type_list);
}

/* find a device other than the selected one.  Prefer non-stream
   devices over stream devices. */

static Lisp_Object
find_other_device (Lisp_Object device)
{
  Lisp_Object rest;

  /* look for a non-stream device */
  DEVICE_LOOP (rest)
    {
      Lisp_Object dev = XCAR (rest);
      if (!DEVICE_IS_STREAM (XDEVICE (dev)) && !EQ (dev, device) &&
	  !NILP (DEVICE_SELECTED_FRAME (XDEVICE (dev))))
	break;
    }
  if (!NILP (rest))
    return XCAR (rest);

  /* OK, now look for a stream device */
  DEVICE_LOOP (rest)
    {
      Lisp_Object dev = XCAR (rest);
      if (!EQ (dev, device) && !NILP (DEVICE_SELECTED_FRAME (XDEVICE (dev))))
	break;
    }
  if (!NILP (rest))
    return XCAR (rest);

  /* Sorry, there ain't none */
  return Qnil;
}
 

DEFUN ("delete-device", Fdelete_device, Sdelete_device, 1, 1, 0,
       "Delete DEVICE, permanently eliminating it from use.")
     (device)
     Lisp_Object device;
{
  /* This function can GC */
  Lisp_Object rest;
  struct device *d;
  int from_io_error = 0;

  /* kludge: if the device argument is a cons whose car is Qunbound,
     we are being called as a result of an IO error on a device.
     If this is the last device, don't try to ask for confirmation. */

  if (CONSP (device) && UNBOUNDP (XCAR (device)))
    {
      from_io_error = 1;
      device = XCDR (device);
    }

  CHECK_DEVICE (device, 0);
  d = XDEVICE (device);

  /* OK to delete an already-deleted device. */
  if (!DEVICE_LIVE_P (d))
    return Qnil;

  /* If Vrun_hooks is nil, we are being called from shut_down_emacs().
     At the time this is called, we could be in some weird unstable
     state, so it's safest not to do most of the junk below.  We're
     about to exit, so it doesn't matter anyway. */
  if (!NILP (Vrun_hooks))
    {
      run_hook_with_args (Qdelete_device_hook, 1, device);
    
      if ((XINT (Flength (Vdevice_list)) == 1)
	  && !NILP (memq_no_quit (device, Vdevice_list)))
        {
	  if (from_io_error)
	    {
	      /* Mayday mayday!  We're going down! */
      	      stderr_out ("  Autosaving and exiting...\n");
      	      Vwindow_system = Qnil; /* let it lie! */
	      Fset (Qkill_emacs_hook, Qnil); /* too dangerous */
	      Fkill_emacs (make_number (70));
	    }
	  else
	    call0 (Qsave_buffers_kill_emacs);
	}

      for (rest = DEVICE_FRAME_LIST (d); !NILP (rest);
	   rest = XCDR (rest))
	{
	  if (!FRAMEP (XCAR (rest)))
	    continue;
	  delete_frame_internal (XCAR (rest), 1);
	}

      DEVICE_SELECTED_FRAME (d) = Qnil;

      /* try to select another device */

      if (EQ (device, Fselected_device ()))
	{
	  Lisp_Object other_dev = find_other_device (device);
	  if (!NILP (other_dev))
	    Fselect_device (other_dev);
	  else
	    {
	      /* necessary? */
	      Vselected_device = Qnil;
	      Vwindow_system = Qnil;
	    }
	}
      
      if (EQ (device, Vdefault_device))
	Vdefault_device = find_other_device (device);
    }
      
  if (d->input_enabled)
    event_stream_unselect_device (d);
  
  DEVMETH (d, delete_device, (d));

  Vdevice_list = delq_no_quit (device, Vdevice_list);
  RESET_CHANGED_SET_FLAGS;
  d->methods = dead_device_methods;

  return Qnil;
}

DEFUN ("device-list", Fdevice_list, Sdevice_list, 0, 0, 0,
       "Return a list of all devices.")
     ()
{
  return Fcopy_sequence (Vdevice_list);
}

DEFUN ("device-frame-list", Fdevice_frame_list, Sdevice_frame_list,
       0, 1, 0,
       "Return a list of all frames on DEVICE.\n\
If DEVICE is nil, the selected device will be used.")
  (device)
     Lisp_Object device;
{
  return Fcopy_sequence (DEVICE_FRAME_LIST (get_device (device)));
}

DEFUN ("device-class", Fdevice_class, Sdevice_class,
       0, 1, 0,
       "Return the class (color behavior) of DEVICE.\n\
This will be one of 'color, 'grayscale, or 'mono.")
     (device)
     Lisp_Object device;
{
  return DEVICE_CLASS (get_device (device));
}

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 = get_device (device);
  int retval;

  retval = DEVMETH_OR_GIVEN (d, device_pixel_width, (d), 0);
  if (retval <= 0)
    return Qnil;

  return make_number (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 = get_device (device);
  int retval;

  retval = DEVMETH_OR_GIVEN (d, device_pixel_height, (d), 0);
  if (retval <= 0)
    return Qnil;

  return make_number (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 = get_device (device);
  int retval;

  retval = DEVMETH_OR_GIVEN (d, device_mm_width, (d), 0);
  if (retval <= 0)
    return Qnil;

  return make_number (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 = get_device (device);
  int retval;

  retval = DEVMETH_OR_GIVEN (d, device_mm_height, (d), 0);
  if (retval <= 0)
    return Qnil;

  return make_number (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 = get_device (device);
  int retval;

  retval = DEVMETH_OR_GIVEN (d, device_bitplanes, (d), 0);
  if (retval <= 0)
    return Qnil;

  return make_number (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 = get_device (device);
  int retval;

  retval = DEVMETH_OR_GIVEN (d, device_color_cells, (d), 0);
  if (retval <= 0)
    return Qnil;

  return make_number (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.\n\
On most systems, changing this value will affect the amount of padding\n\
and other strategic decisions made during redisplay.")
     (device, rate)
     Lisp_Object device, rate;
{
  CHECK_INT (rate, 0);

  DEVICE_BAUD_RATE (get_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_number (DEVICE_BAUD_RATE (get_device (device)));
}

DEFUN ("device-enable-input", Fdevice_enable_input, Sdevice_enable_input,
       1, 1, 0,
  "Enable input on device DEVICE.")
  (device)
     Lisp_Object device;
{
  struct device *d = get_device (device);
  if (!d->input_enabled)
    event_stream_select_device (d);
  return Qnil;
}

DEFUN ("device-disable-input", Fdevice_disable_input, Sdevice_disable_input,
       1, 1, 0,
  "Disable input on device DEVICE.")
  (device)
     Lisp_Object device;
{
  struct device *d = get_device (device);
  if (d->input_enabled)
    event_stream_unselect_device (d);
  return Qnil;
}

/* #### These make a good case for adding at least some per-device
   variables. */
DEFUN ("device-function-key-map", Fdevice_function_key_map,
       Sdevice_function_key_map, 0, 1, 0,
  "Return the function key mapping for DEVICE.")
  (device)
     Lisp_Object device;
{
  return DEVICE_FUNCTION_KEY_MAP (get_device (device));
}

DEFUN ("set-device-function-key-map", Fset_device_function_key_map,
       Sset_device_function_key_map, 2, 2, 0,
  "Set the function key mapping for DEVICE to KEYMAP.")
  (device, keymap)
     Lisp_Object device, keymap;
{
  struct device *d = get_device (device);

  CHECK_KEYMAP (keymap, 0);
  d->function_key_map = keymap;
  return keymap;
}

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_device_type_entry_dynarr); i++)
    {
      if (Dynarr_at (the_device_type_entry_dynarr, i).meths->
	  asynch_device_change_method)
	(Dynarr_at (the_device_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 (&Svalid_device_type_p);
  defsubr (&Sdevice_class_list);
  defsubr (&Sdevice_type_list);

  defsubr (&Sdfw_device);
  defsubr (&Sselected_device);
  defsubr (&Sselect_device);
  defsubr (&Sdevicep);
  defsubr (&Sdevice_live_p);
  defsubr (&Sdevice_type);
  defsubr (&Sdevice_name);
  defsubr (&Smake_device);
  defsubr (&Sdelete_device);
  defsubr (&Sdevice_list);
  defsubr (&Sdevice_frame_list);
  defsubr (&Sdevice_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);
  defsubr (&Sdevice_enable_input);
  defsubr (&Sdevice_disable_input);
  defsubr (&Sdevice_function_key_map);
  defsubr (&Sset_device_function_key_map);

  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
device_type_create (void)
{
  the_device_type_entry_dynarr = Dynarr_new (struct device_type_entry);

  Vdevice_type_list = Qnil;
  staticpro (&Vdevice_type_list);

  /* Initialize the dead device type */
  INITIALIZE_DEVICE_TYPE (dead, "dead", "device-dead-p");

  /* then reset the device-type lists, because `dead' is not really
     a valid device type */
  Dynarr_reset (the_device_type_entry_dynarr);
  Vdevice_type_list = Qnil;
}

void
vars_of_device (void)
{
  DEFVAR_LISP ("create-device-hook", &Vcreate_device_hook,
     "Function or functions to call when a device is created.\n\
One argument, the newly-created device.\n\
Note that the device will not be selected and will not have any\n\
frames on it.");
  Vcreate_device_hook = Qnil;

  DEFVAR_LISP ("delete-device-hook", &Vdelete_device_hook,
     "Function or functions to call when a device is deleted.\n\
One argument, the to-be-deleted device.");
  Vdelete_device_hook = Qnil;

  staticpro (&Vdevice_list);
  Vdevice_list = Qnil;
  staticpro (&Vselected_device);
  Vselected_device = Qnil;
  staticpro (&Vdefault_device);
  Vdefault_device = Qnil;

  asynch_device_change_pending = 0;

  Vdevice_class_list = list3 (Qcolor, Qgrayscale, Qmono);
  staticpro (&Vdevice_class_list);
}

These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.