annotate lisp/device.el @ 5146:88bd4f3ef8e4

make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c -------------------- ChangeLog entries follow: -------------------- src/ChangeLog addition: 2010-03-15 Ben Wing <ben@xemacs.org> * alloc.c: * alloc.c (c_readonly): * alloc.c (deadbeef_memory): * alloc.c (make_compiled_function): * alloc.c (make_button_data): * alloc.c (make_motion_data): * alloc.c (make_process_data): * alloc.c (make_timeout_data): * alloc.c (make_magic_data): * alloc.c (make_magic_eval_data): * alloc.c (make_eval_data): * alloc.c (make_misc_user_data): * alloc.c (noseeum_make_marker): * alloc.c (ADDITIONAL_FREE_string): * alloc.c (common_init_alloc_early): * alloc.c (init_alloc_once_early): * bytecode.c (print_compiled_function): * bytecode.c (mark_compiled_function): * casetab.c: * casetab.c (print_case_table): * console.c: * console.c (print_console): * database.c (print_database): * database.c (finalize_database): * device-msw.c (sync_printer_with_devmode): * device-msw.c (print_devmode): * device-msw.c (finalize_devmode): * device.c: * device.c (print_device): * elhash.c: * elhash.c (print_hash_table): * eval.c (print_multiple_value): * eval.c (mark_multiple_value): * events.c (deinitialize_event): * events.c (print_event): * events.c (event_equal): * extents.c: * extents.c (soe_dump): * extents.c (soe_insert): * extents.c (soe_delete): * extents.c (soe_move): * extents.c (extent_fragment_update): * extents.c (print_extent_1): * extents.c (print_extent): * extents.c (vars_of_extents): * frame.c: * frame.c (print_frame): * free-hook.c: * free-hook.c (check_free): * glyphs.c: * glyphs.c (print_image_instance): * glyphs.c (print_glyph): * gui.c: * gui.c (copy_gui_item): * hash.c: * hash.c (NULL_ENTRY): * hash.c (KEYS_DIFFER_P): * keymap.c (print_keymap): * keymap.c (MARKED_SLOT): * lisp.h: * lrecord.h: * lrecord.h (LISP_OBJECT_UID): * lrecord.h (set_lheader_implementation): * lrecord.h (struct old_lcrecord_header): * lstream.c (print_lstream): * lstream.c (finalize_lstream): * marker.c (print_marker): * marker.c (marker_equal): * mc-alloc.c (visit_all_used_page_headers): * mule-charset.c: * mule-charset.c (print_charset): * objects.c (print_color_instance): * objects.c (print_font_instance): * objects.c (finalize_font_instance): * opaque.c (print_opaque): * opaque.c (print_opaque_ptr): * opaque.c (equal_opaque_ptr): * print.c (internal_object_printer): * print.c (enum printing_badness): * rangetab.c (print_range_table): * rangetab.c (range_table_equal): * specifier.c (print_specifier): * specifier.c (finalize_specifier): * symbols.c: * symbols.c (print_symbol_value_magic): * tooltalk.c: * tooltalk.c (print_tooltalk_message): * tooltalk.c (print_tooltalk_pattern): * window.c (print_window): * window.c (debug_print_window): (1) Make lrecord UID's have a separate UID space for each object. Otherwise, with 20-bit UID's, we rapidly wrap around, especially when common objects like conses and strings increment the UID value for every object created. (Originally I tried making two UID spaces, one for objects that always print readably and hence don't display the UID, and one for other objects. But certain objects like markers for which a UID is displayed are still generated rapidly enough that UID overflow is a serious issue.) This also has the advantage of making UID values smaller, hence easier to remember -- their main purpose is to make it easier to keep track of different objects of the same type when debugging code. Make sure we dump lrecord UID's so that we don't have problems with pdumped and non-dumped objects having the same UID. (2) Display UID's consistently whenever an object (a) doesn't consistently print readably (objects like cons and string, which always print readably, can't display a UID), and (b) doesn't otherwise have a unique property that makes objects of a particular type distinguishable. (E.g. buffers didn't and still don't print an ID, but the buffer name uniquely identifies the buffer.) Some types, such as event, extent, compiled-function, didn't always (or didn't ever) display an ID; others (such as marker, extent, lstream, opaque, opaque-ptr, any object using internal_object_printer()) used to display the actual machine pointer instead. (3) Rename NORMAL_LISP_OBJECT_UID to LISP_OBJECT_UID; make it work over all Lisp objects and take a Lisp object, not a struct pointer. (4) Some misc cleanups in alloc.c, elhash.c. (5) Change code in events.c that "deinitializes" an event so that it doesn't increment the event UID counter in the process. Also use deadbeef_memory() to overwrite memory instead of doing the same with custom code. In the process, make deadbeef_memory() in alloc.c always available, and delete extraneous copy in mc-alloc.c. Also capitalize all uses of 0xDEADBEEF. Similarly in elhash.c call deadbeef_memory(). (6) Resurrect "debug SOE" code in extents.c. Make it conditional on DEBUG_XEMACS and on a `debug-soe' variable, rather than on SOE_DEBUG. Make it output to stderr, not stdout. (7) Delete some custom print methods that were identical to external_object_printer().
author Ben Wing <ben@xemacs.org>
date Mon, 15 Mar 2010 16:35:38 -0500
parents aa5ed11f473b
children 0d43872986b6
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1 ;;; device.el --- miscellaneous device functions not written in C
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3 ;; Copyright (C) 1994-5, 1997 Free Software Foundation, Inc.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4 ;; Copyright (C) 1995, 1996 Ben Wing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6 ;; Maintainer: XEmacs Development Team
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7 ;; Keywords: internal, dumped
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9 ;; This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11 ;; XEmacs is free software; you can redistribute it and/or modify it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
12 ;; under the terms of the GNU General Public License as published by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
13 ;; the Free Software Foundation; either version 2, or (at your option)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
14 ;; any later version.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
15
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
16 ;; XEmacs is distributed in the hope that it will be useful, but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
19 ;; General Public License for more details.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
20
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21 ;; You should have received a copy of the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22 ;; along with XEmacs; see the file COPYING. If not, write to the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
23 ;; Free Software Foundation, 59 Temple Place - Suite 330,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
24 ;; Boston, MA 02111-1307, USA.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
25
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
26 ;;; Synched up with: Not in FSF.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
27
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
28 ;;; Commentary:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
29
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
30 ;; This file is dumped with XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
32 ;;; Code:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
33
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 428
diff changeset
34 ;;; Initialization
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 428
diff changeset
35
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 428
diff changeset
36 ; Specifier tag 'printer which matches printers
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 428
diff changeset
37 (define-specifier-tag 'printer (function device-printer-p))
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 428
diff changeset
38
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 428
diff changeset
39 ; Specifier tag 'display which matches displays
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 428
diff changeset
40 (define-specifier-tag 'display (function
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 428
diff changeset
41 (lambda (device)
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 428
diff changeset
42 (not (device-printer-p device)))))
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 428
diff changeset
43
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 428
diff changeset
44 ;;; Functions
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 428
diff changeset
45
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
46 (defun device-list ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
47 "Return a list of all devices."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
48 (apply 'nconc (mapcar 'console-device-list (console-list))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
49
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
50 (defun device-type (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
51 "Return the type of the specified device (e.g. `x' or `tty').
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
52 This is equivalent to the type of the device's console.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
53 Value is `tty' for a tty device (a character-only terminal),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
54 `x' for a device that is a screen on an X display,
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents: 440
diff changeset
55 `gtk' for a device that is a GTK connection.
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 428
diff changeset
56 `mswindows' for a device that is a MS Windows workstation,
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 428
diff changeset
57 `msprinter' for a device that is a MS Windows printer connection,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58 `stream' for a stream device (which acts like a stdio stream), and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
59 `dead' for a deleted device."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60 (or device (setq device (selected-device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61 (if (not (device-live-p device)) 'dead
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62 (console-type (device-console device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
64 (defun make-tty-device (&optional tty terminal-type controlling-process)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65 "Create a new device on TTY.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
66 TTY should be the name of a tty device file (e.g. \"/dev/ttyp3\" under
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
67 SunOS et al.), as returned by the `tty' command. A value of nil means
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
68 use the stdin and stdout as passed to XEmacs from the shell.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
69 If TERMINAL-TYPE is non-nil, it should be a string specifying the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70 type of the terminal attached to the specified tty. If it is nil,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71 the terminal type will be inferred from the TERM environment variable.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
72 If CONTROLLING-PROCESS is non-nil, it should be an integer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
73 specifying the process id of the process in control of the specified tty. If
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
74 it is nil, it is assumes to be the value returned by emacs-pid."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
75 (make-device 'tty tty (list 'terminal-type terminal-type
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
76 'controlling-process controlling-process)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
77
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
78 (defun device-pixel-width (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
79 "Return the width in pixels of DEVICE, or nil if unknown."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
80 (let ((ds (device-system-metric device 'size-device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
81 (and ds (car ds))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
82
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
83 (defun device-pixel-height (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
84 "Return the height in pixels of DEVICE, or nil if unknown."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
85 (let ((ds (device-system-metric device 'size-device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86 (and ds (cdr ds))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
88 (defun device-mm-width (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89 "Return the width in millimeters of DEVICE, or nil if unknown."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90 (let ((ds (device-system-metric device 'size-device-mm)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
91 (and ds (car ds))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
92
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
93 (defun device-mm-height (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94 "Return the height in millimeters of DEVICE, or nil if unknown."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
95 (let ((ds (device-system-metric device 'size-device-mm)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
96 (and ds (cdr ds))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
97
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
98 (defun device-bitplanes (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
99 "Return the number of bitplanes of DEVICE, or nil if unknown."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
100 (device-system-metric device 'num-bit-planes))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
101
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
102 (defun device-color-cells (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
103 "Return the number of color cells of DEVICE, or nil if unknown."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
104 (device-system-metric device 'num-color-cells))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
105
1942
da8cdcec6dff [xemacs-hg @ 2004-03-08 15:22:44 by james]
james
parents: 462
diff changeset
106 (defun device-num-screens (&optional device)
da8cdcec6dff [xemacs-hg @ 2004-03-08 15:22:44 by james]
james
parents: 462
diff changeset
107 "Return the number of display screens available on DEVICE, or 1 if unknown."
da8cdcec6dff [xemacs-hg @ 2004-03-08 15:22:44 by james]
james
parents: 462
diff changeset
108 (device-system-metric device 'num-screens 1))
da8cdcec6dff [xemacs-hg @ 2004-03-08 15:22:44 by james]
james
parents: 462
diff changeset
109
da8cdcec6dff [xemacs-hg @ 2004-03-08 15:22:44 by james]
james
parents: 462
diff changeset
110 (defun device-backing-store (&optional device)
da8cdcec6dff [xemacs-hg @ 2004-03-08 15:22:44 by james]
james
parents: 462
diff changeset
111 "Return the backing store capability of DEVICE.
da8cdcec6dff [xemacs-hg @ 2004-03-08 15:22:44 by james]
james
parents: 462
diff changeset
112 The value may be `always', `when-mapped', `not-useful', or nil if
da8cdcec6dff [xemacs-hg @ 2004-03-08 15:22:44 by james]
james
parents: 462
diff changeset
113 the question is inapplicable to a certain kind of display."
da8cdcec6dff [xemacs-hg @ 2004-03-08 15:22:44 by james]
james
parents: 462
diff changeset
114 (device-system-metric device 'backing-store))
da8cdcec6dff [xemacs-hg @ 2004-03-08 15:22:44 by james]
james
parents: 462
diff changeset
115
da8cdcec6dff [xemacs-hg @ 2004-03-08 15:22:44 by james]
james
parents: 462
diff changeset
116 (defun device-save-under (&optional device)
da8cdcec6dff [xemacs-hg @ 2004-03-08 15:22:44 by james]
james
parents: 462
diff changeset
117 "Return non-nil if DEVICE supports the SaveUnder feature."
da8cdcec6dff [xemacs-hg @ 2004-03-08 15:22:44 by james]
james
parents: 462
diff changeset
118 (device-system-metric device 'save-under))
da8cdcec6dff [xemacs-hg @ 2004-03-08 15:22:44 by james]
james
parents: 462
diff changeset
119
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents: 440
diff changeset
120 (defun make-gtk-device ()
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents: 440
diff changeset
121 "Create a new GTK device."
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents: 440
diff changeset
122 (make-device 'gtk nil))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents: 440
diff changeset
123
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
124 (defun make-x-device (&optional display)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
125 "Create a new device connected to DISPLAY."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
126 (make-device 'x display))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
127
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
128 (defun make-mswindows-device ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
129 "Create a new mswindows device."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 (make-device 'mswindows nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
132 (defun device-on-window-system-p (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
133 "Return non-nil if DEVICE is on a window system.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
134 This generally means that there is support for the mouse, the menubar,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
135 the toolbar, glyphs, etc."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
136 (or device (setq device (selected-device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137 (console-on-window-system-p (device-console device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139 (defun call-device-method (name device &rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
140 "Call a DEVICE-specific function with the generic name NAME.
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 428
diff changeset
141 If DEVICE is not provided then the selected device is used."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
142 (or device (setq device (selected-device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143 (or (symbolp name) (error "function name must be a symbol"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
144 (let ((devmeth (intern (concat (symbol-name
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
145 (device-type device)) "-" (symbol-name name)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146 (if (functionp devmeth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147 (if args
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148 (apply devmeth args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
149 (funcall devmeth))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150 nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
152 (defmacro define-device-method (name &optional docstring)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
153 "Define NAME to be a device method."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
154 `(defun ,name (&rest arglist) ,docstring
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
155 (apply 'call-device-method (quote ,name) nil arglist)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
156
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
157 (defmacro define-device-method* (name &optional docstring)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
158 "Define NAME to be a device method."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
159 `(defun* ,name (&rest arglist) ,docstring
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160 (apply 'call-device-method (quote ,name) nil arglist)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
161
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
162 (defalias 'valid-device-type-p 'valid-console-type-p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163 (defalias 'device-type-list 'console-type-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164 (defalias 'device-pixel-depth 'device-bitplanes)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
165
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
166 ;;; device.el ends here