Mercurial > hg > xemacs-beta
annotate src/objects.c @ 5124:623d57b7fbe8 ben-lisp-object
separate regular and disksave finalization, print method fixes.
Create separate disksave method and make the finalize method only be for
actual object finalization, not disksave finalization.
Fix places where 0 was given in place of a printer -- print methods are
mandatory, and internal objects formerly without a print method now must
explicitly specify internal_object_printer().
Change the defn of CONSOLE_LIVE_P to avoid problems in some weird situations.
-------------------- ChangeLog entries follow: --------------------
src/ChangeLog addition:
2010-01-20 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (very_old_free_lcrecord):
* alloc.c (disksave_object_finalization_1):
* alloc.c (make_lcrecord_list):
* alloc.c (alloc_managed_lcrecord):
* alloc.c (free_managed_lcrecord):
* alloc.c (sweep_lcrecords_1):
* buffer.c:
* bytecode.c:
* bytecode.c (Fcompiled_function_p):
* chartab.c:
* console-impl.h:
* console-impl.h (CONSOLE_TYPE_P):
* console.c:
* console.c (set_quit_events):
* data.c:
* data.c (Fmake_ephemeron):
* database.c:
* database.c (finalize_database):
* database.c (Fclose_database):
* device-msw.c:
* device-msw.c (finalize_devmode):
* device-msw.c (allocate_devmode):
* device.c:
* elhash.c:
* elhash.c (finalize_hash_table):
* eval.c:
* eval.c (bind_multiple_value_limits):
* event-stream.c:
* event-stream.c (finalize_command_builder):
* events.c:
* events.c (mark_event):
* extents.c:
* extents.c (finalize_extent_info):
* extents.c (uninit_buffer_extents):
* faces.c:
* file-coding.c:
* file-coding.c (finalize_coding_system):
* file-coding.h:
* file-coding.h (struct coding_system_methods):
* file-coding.h (struct detector):
* floatfns.c:
* floatfns.c (extract_float):
* fns.c:
* fns.c (Fidentity):
* font-mgr.c (finalize_fc_pattern):
* font-mgr.c (finalize_fc_config):
* frame.c:
* glyphs.c:
* glyphs.c (finalize_image_instance):
* glyphs.c (unmap_subwindow_instance_cache_mapper):
* gui.c:
* gui.c (gui_error):
* keymap.c:
* lisp.h (struct Lisp_Symbol):
* lrecord.h:
* lrecord.h (struct lrecord_implementation):
* lrecord.h (MC_ALLOC_CALL_FINALIZER):
* lrecord.h (MC_ALLOC_CALL_FINALIZER_FOR_DISKSAVE):
* lrecord.h (DEFINE_DUMPABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_SIZABLE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_SIZABLE_INTERNAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_SIZABLE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_FROB_BLOCK_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_FROB_BLOCK_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_INTERNAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_SIZABLE_INTERNAL_LISP_OBJECT):
* lrecord.h (MAKE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_SIZABLE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_SIZABLE_GENERAL_LISP_OBJECT):
* lrecord.h (MAKE_MODULE_LISP_OBJECT):
* lstream.c:
* lstream.c (finalize_lstream):
* lstream.c (disksave_lstream):
* marker.c:
* marker.c (finalize_marker):
* mule-charset.c (make_charset):
* number.c:
* objects.c:
* objects.c (finalize_color_instance):
* objects.c (finalize_font_instance):
* opaque.c:
* opaque.c (make_opaque_ptr):
* process-nt.c:
* process-nt.c (nt_finalize_process_data):
* process-nt.c (nt_deactivate_process):
* process.c:
* process.c (finalize_process):
* procimpl.h (struct process_methods):
* scrollbar.c:
* scrollbar.c (free_scrollbar_instance):
* specifier.c (finalize_specifier):
* symbols.c:
* toolbar.c:
* toolbar.c (Ftoolbar_button_p):
* tooltalk.c:
* ui-gtk.c:
* ui-gtk.c (emacs_gtk_object_finalizer):
* ui-gtk.c (allocate_emacs_gtk_boxed_data):
* window.c:
* window.c (finalize_window):
* window.c (mark_window_as_deleted):
Separate out regular and disksave finalization. Instead of a
FOR_DISKSAVE argument to the finalizer, create a separate object
method `disksaver'. Make `finalizer' have only one argument.
Go through and separate out all finalize methods into finalize
and disksave. Delete lots of thereby redundant disksave checking.
Delete places that signal an error if we attempt to disksave --
all of these objects are non-dumpable and we will get an error
from pdump anyway if we attempt to dump them. After this is done,
only one object remains that has a disksave method -- lstream.
Change DEFINE_*_LISP_OBJECT_WITH_PROPS to DEFINE_*_GENERAL_LISP_OBJECT,
which is used for specifying either property methods or disksave
methods (or in the future, any other less-used methods).
Remove the for_disksave argument to finalize_process_data. Don't
provide a disksaver for processes because no one currently needs
it.
Clean up various places where objects didn't provide a print method.
It was made mandatory in previous changes, and all methods now
either provide their own print method or use internal_object_printer
or external_object_printer.
Change the definition of CONSOLE_LIVE_P to use the contype enum
rather than looking into the conmeths structure -- in some weird
situations with dead objects, the conmeths structure is NULL,
and printing such objects from debug_print() will crash if we try
to look into the conmeths structure.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Wed, 20 Jan 2010 07:05:57 -0600 |
| parents | e0db3c197671 |
| children | b5df3737028a |
| rev | line source |
|---|---|
| 428 | 1 /* Generic Objects and Functions. |
| 2 Copyright (C) 1995 Free Software Foundation, Inc. | |
| 3 Copyright (C) 1995 Board of Trustees, University of Illinois. | |
| 2527 | 4 Copyright (C) 1995, 1996, 2002, 2004 Ben Wing. |
| 428 | 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 #include <config.h> | |
| 26 #include "lisp.h" | |
| 27 | |
| 771 | 28 #include "buffer.h" |
| 872 | 29 #include "device-impl.h" |
| 428 | 30 #include "elhash.h" |
| 31 #include "faces.h" | |
| 32 #include "frame.h" | |
| 800 | 33 #include "glyphs.h" |
| 872 | 34 #include "objects-impl.h" |
| 428 | 35 #include "specifier.h" |
| 36 #include "window.h" | |
| 37 | |
| 1204 | 38 #ifdef HAVE_TTY |
| 39 #include "console-tty.h" | |
| 40 #endif | |
| 934 | 41 |
| 428 | 42 /* Objects that are substituted when an instantiation fails. |
| 43 If we leave in the Qunbound value, we will probably get crashes. */ | |
| 44 Lisp_Object Vthe_null_color_instance, Vthe_null_font_instance; | |
| 45 | |
| 46 /* Authors: Ben Wing, Chuck Thompson */ | |
| 47 | |
| 2268 | 48 DOESNT_RETURN |
| 428 | 49 finalose (void *ptr) |
| 50 { | |
| 793 | 51 Lisp_Object obj = wrap_pointer_1 (ptr); |
| 52 | |
| 563 | 53 invalid_operation |
| 428 | 54 ("Can't dump an emacs containing window system objects", obj); |
| 55 } | |
| 56 | |
| 57 | |
| 58 /**************************************************************************** | |
| 59 * Color-Instance Object * | |
| 60 ****************************************************************************/ | |
| 61 | |
| 62 Lisp_Object Qcolor_instancep; | |
| 63 | |
| 1204 | 64 static const struct memory_description color_instance_data_description_1 []= { |
| 65 #ifdef HAVE_TTY | |
| 3092 | 66 #ifdef NEW_GC |
| 67 { XD_LISP_OBJECT, tty_console }, | |
| 68 #else /* not NEW_GC */ | |
| 2551 | 69 { XD_BLOCK_PTR, tty_console, 1, { &tty_color_instance_data_description } }, |
| 3092 | 70 #endif /* not NEW_GC */ |
| 1204 | 71 #endif |
| 934 | 72 { XD_END } |
| 73 }; | |
| 74 | |
| 1204 | 75 static const struct sized_memory_description color_instance_data_description = { |
| 76 sizeof (void *), color_instance_data_description_1 | |
| 934 | 77 }; |
| 78 | |
| 1204 | 79 static const struct memory_description color_instance_description[] = { |
| 934 | 80 { XD_INT, offsetof (Lisp_Color_Instance, color_instance_type) }, |
| 81 { XD_LISP_OBJECT, offsetof (Lisp_Color_Instance, name)}, | |
| 82 { XD_LISP_OBJECT, offsetof (Lisp_Color_Instance, device)}, | |
| 1204 | 83 { XD_UNION, offsetof (Lisp_Color_Instance, data), |
| 2551 | 84 XD_INDIRECT (0, 0), { &color_instance_data_description } }, |
| 934 | 85 {XD_END} |
| 86 }; | |
| 87 | |
| 428 | 88 static Lisp_Object |
| 89 mark_color_instance (Lisp_Object obj) | |
| 90 { | |
| 440 | 91 Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); |
| 428 | 92 mark_object (c->name); |
| 93 if (!NILP (c->device)) /* Vthe_null_color_instance */ | |
| 94 MAYBE_DEVMETH (XDEVICE (c->device), mark_color_instance, (c)); | |
| 95 | |
| 96 return c->device; | |
| 97 } | |
| 98 | |
| 99 static void | |
| 100 print_color_instance (Lisp_Object obj, Lisp_Object printcharfun, | |
| 101 int escapeflag) | |
| 102 { | |
| 440 | 103 Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); |
| 428 | 104 if (print_readably) |
| 563 | 105 printing_unreadable_object ("#<color-instance 0x%x>", |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
106 c->header.uid); |
| 800 | 107 write_fmt_string_lisp (printcharfun, "#<color-instance %s", 1, c->name); |
| 108 write_fmt_string_lisp (printcharfun, " on %s", 1, c->device); | |
| 428 | 109 if (!NILP (c->device)) /* Vthe_null_color_instance */ |
| 110 MAYBE_DEVMETH (XDEVICE (c->device), print_color_instance, | |
| 111 (c, printcharfun, escapeflag)); | |
| 800 | 112 write_fmt_string (printcharfun, " 0x%x>", c->header.uid); |
| 428 | 113 } |
| 114 | |
| 115 static void | |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
116 finalize_color_instance (void *header) |
| 428 | 117 { |
| 440 | 118 Lisp_Color_Instance *c = (Lisp_Color_Instance *) header; |
| 428 | 119 |
| 120 if (!NILP (c->device)) | |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
121 MAYBE_DEVMETH (XDEVICE (c->device), finalize_color_instance, (c)); |
| 428 | 122 } |
| 123 | |
| 124 static int | |
| 125 color_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 126 { | |
| 440 | 127 Lisp_Color_Instance *c1 = XCOLOR_INSTANCE (obj1); |
| 128 Lisp_Color_Instance *c2 = XCOLOR_INSTANCE (obj2); | |
| 428 | 129 |
| 130 return (c1 == c2) || | |
| 131 (EQ (c1->device, c2->device) && | |
| 132 DEVICEP (c1->device) && | |
| 133 HAS_DEVMETH_P (XDEVICE (c1->device), color_instance_equal) && | |
| 134 DEVMETH (XDEVICE (c1->device), color_instance_equal, (c1, c2, depth))); | |
| 135 } | |
| 136 | |
| 2515 | 137 static Hashcode |
| 428 | 138 color_instance_hash (Lisp_Object obj, int depth) |
| 139 { | |
| 440 | 140 Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); |
| 428 | 141 struct device *d = DEVICEP (c->device) ? XDEVICE (c->device) : 0; |
| 142 | |
| 2515 | 143 return HASH2 ((Hashcode) d, |
| 428 | 144 !d ? LISP_HASH (obj) |
| 145 : DEVMETH_OR_GIVEN (d, color_instance_hash, (c, depth), | |
| 146 LISP_HASH (obj))); | |
| 147 } | |
| 148 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
149 DEFINE_NODUMP_LISP_OBJECT ("color-instance", color_instance, |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
150 mark_color_instance, print_color_instance, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
151 finalize_color_instance, color_instance_equal, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
152 color_instance_hash, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
153 color_instance_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
154 Lisp_Color_Instance); |
| 428 | 155 |
| 156 DEFUN ("make-color-instance", Fmake_color_instance, 1, 3, 0, /* | |
| 157 Return a new `color-instance' object named NAME (a string). | |
| 158 | |
| 159 Optional argument DEVICE specifies the device this object applies to | |
| 160 and defaults to the selected device. | |
| 161 | |
| 162 An error is signaled if the color is unknown or cannot be allocated; | |
| 444 | 163 however, if optional argument NOERROR is non-nil, nil is simply |
| 164 returned in this case. (And if NOERROR is other than t, a warning may | |
| 428 | 165 be issued.) |
| 166 | |
| 167 The returned object is a normal, first-class lisp object. The way you | |
| 168 `deallocate' the color is the way you deallocate any other lisp object: | |
| 169 you drop all pointers to it and allow it to be garbage collected. When | |
| 170 these objects are GCed, the underlying window-system data (e.g. X object) | |
| 171 is deallocated as well. | |
| 172 */ | |
| 444 | 173 (name, device, noerror)) |
| 428 | 174 { |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
175 Lisp_Object obj; |
| 440 | 176 Lisp_Color_Instance *c; |
| 428 | 177 int retval; |
| 178 | |
| 179 CHECK_STRING (name); | |
| 793 | 180 device = wrap_device (decode_device (device)); |
| 428 | 181 |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
182 obj = ALLOC_LISP_OBJECT (color_instance); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
183 c = XCOLOR_INSTANCE (obj); |
| 428 | 184 c->name = name; |
| 185 c->device = device; | |
| 186 c->data = 0; | |
| 1204 | 187 c->color_instance_type = get_console_variant (XDEVICE_TYPE (c->device)); |
| 428 | 188 |
| 189 retval = MAYBE_INT_DEVMETH (XDEVICE (device), initialize_color_instance, | |
| 190 (c, name, device, | |
| 444 | 191 decode_error_behavior_flag (noerror))); |
| 428 | 192 if (!retval) |
| 193 return Qnil; | |
| 194 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
195 return obj; |
| 428 | 196 } |
| 197 | |
| 198 DEFUN ("color-instance-p", Fcolor_instance_p, 1, 1, 0, /* | |
| 199 Return non-nil if OBJECT is a color instance. | |
| 200 */ | |
| 201 (object)) | |
| 202 { | |
| 203 return COLOR_INSTANCEP (object) ? Qt : Qnil; | |
| 204 } | |
| 205 | |
| 206 DEFUN ("color-instance-name", Fcolor_instance_name, 1, 1, 0, /* | |
| 207 Return the name used to allocate COLOR-INSTANCE. | |
| 208 */ | |
| 209 (color_instance)) | |
| 210 { | |
| 211 CHECK_COLOR_INSTANCE (color_instance); | |
| 212 return XCOLOR_INSTANCE (color_instance)->name; | |
| 213 } | |
| 214 | |
| 215 DEFUN ("color-instance-rgb-components", Fcolor_instance_rgb_components, 1, 1, 0, /* | |
| 216 Return a three element list containing the red, green, and blue | |
| 217 color components of COLOR-INSTANCE, or nil if unknown. | |
| 218 Component values range from 0 to 65535. | |
| 219 */ | |
| 220 (color_instance)) | |
| 221 { | |
| 440 | 222 Lisp_Color_Instance *c; |
| 428 | 223 |
| 224 CHECK_COLOR_INSTANCE (color_instance); | |
| 225 c = XCOLOR_INSTANCE (color_instance); | |
| 226 | |
| 227 if (NILP (c->device)) | |
| 228 return Qnil; | |
| 229 | |
| 230 return MAYBE_LISP_DEVMETH (XDEVICE (c->device), | |
| 231 color_instance_rgb_components, | |
| 232 (c)); | |
| 233 } | |
| 234 | |
| 235 DEFUN ("valid-color-name-p", Fvalid_color_name_p, 1, 2, 0, /* | |
| 236 Return true if COLOR names a valid color for the current device. | |
| 237 | |
| 238 Valid color names for X are listed in the file /usr/lib/X11/rgb.txt, or | |
| 239 whatever the equivalent is on your system. | |
| 240 | |
| 241 Valid color names for TTY are those which have an ISO 6429 (ANSI) sequence. | |
| 242 In addition to being a color this may be one of a number of attributes | |
| 243 such as `blink'. | |
| 244 */ | |
| 245 (color, device)) | |
| 246 { | |
| 247 struct device *d = decode_device (device); | |
| 248 | |
| 249 CHECK_STRING (color); | |
| 250 return MAYBE_INT_DEVMETH (d, valid_color_name_p, (d, color)) ? Qt : Qnil; | |
| 251 } | |
| 252 | |
| 2527 | 253 DEFUN ("color-list", Fcolor_list, 0, 1, 0, /* |
| 254 Return a list of color names. | |
| 255 DEVICE specifies which device to return names for, and defaults to the | |
| 256 currently selected device. | |
| 257 */ | |
| 258 (device)) | |
| 259 { | |
| 260 device = wrap_device (decode_device (device)); | |
| 261 | |
| 262 return MAYBE_LISP_DEVMETH (XDEVICE (device), color_list, ()); | |
| 263 } | |
| 264 | |
| 428 | 265 |
| 266 /*************************************************************************** | |
| 267 * Font-Instance Object * | |
| 268 ***************************************************************************/ | |
| 269 | |
| 270 Lisp_Object Qfont_instancep; | |
| 271 | |
| 272 static Lisp_Object font_instance_truename_internal (Lisp_Object xfont, | |
| 578 | 273 Error_Behavior errb); |
| 934 | 274 |
| 1204 | 275 static const struct memory_description font_instance_data_description_1 []= { |
| 276 #ifdef HAVE_TTY | |
| 3092 | 277 #ifdef NEW_GC |
| 278 { XD_LISP_OBJECT, tty_console }, | |
| 279 #else /* not NEW_GC */ | |
| 280 { XD_BLOCK_PTR, tty_console, 1, { &tty_font_instance_data_description } }, | |
| 281 #endif /* not NEW_GC */ | |
| 1204 | 282 #endif |
| 934 | 283 { XD_END } |
| 284 }; | |
| 285 | |
| 1204 | 286 static const struct sized_memory_description font_instance_data_description = { |
| 287 sizeof (void *), font_instance_data_description_1 | |
| 934 | 288 }; |
| 289 | |
| 1204 | 290 static const struct memory_description font_instance_description[] = { |
| 934 | 291 { XD_INT, offsetof (Lisp_Font_Instance, font_instance_type) }, |
| 292 { XD_LISP_OBJECT, offsetof (Lisp_Font_Instance, name)}, | |
| 293 { XD_LISP_OBJECT, offsetof (Lisp_Font_Instance, truename)}, | |
| 294 { XD_LISP_OBJECT, offsetof (Lisp_Font_Instance, device)}, | |
| 3094 | 295 { XD_LISP_OBJECT, offsetof (Lisp_Font_Instance, charset)}, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
296 { XD_UNION, offsetof (Lisp_Font_Instance, data), |
| 2551 | 297 XD_INDIRECT (0, 0), { &font_instance_data_description } }, |
| 1204 | 298 { XD_END } |
| 934 | 299 }; |
| 300 | |
| 428 | 301 |
| 302 static Lisp_Object | |
| 303 mark_font_instance (Lisp_Object obj) | |
| 304 { | |
| 440 | 305 Lisp_Font_Instance *f = XFONT_INSTANCE (obj); |
| 428 | 306 |
| 307 mark_object (f->name); | |
| 872 | 308 mark_object (f->truename); |
| 428 | 309 if (!NILP (f->device)) /* Vthe_null_font_instance */ |
| 310 MAYBE_DEVMETH (XDEVICE (f->device), mark_font_instance, (f)); | |
| 311 | |
| 312 return f->device; | |
| 313 } | |
| 314 | |
| 315 static void | |
| 316 print_font_instance (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) | |
| 317 { | |
| 440 | 318 Lisp_Font_Instance *f = XFONT_INSTANCE (obj); |
| 428 | 319 if (print_readably) |
| 563 | 320 printing_unreadable_object ("#<font-instance 0x%x>", f->header.uid); |
| 800 | 321 write_fmt_string_lisp (printcharfun, "#<font-instance %S", 1, f->name); |
| 322 write_fmt_string_lisp (printcharfun, " on %s", 1, f->device); | |
| 428 | 323 if (!NILP (f->device)) |
| 3659 | 324 { |
| 325 MAYBE_DEVMETH (XDEVICE (f->device), print_font_instance, | |
| 326 (f, printcharfun, escapeflag)); | |
| 327 | |
| 328 } | |
| 800 | 329 write_fmt_string (printcharfun, " 0x%x>", f->header.uid); |
| 428 | 330 } |
| 331 | |
| 332 static void | |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
333 finalize_font_instance (void *header) |
| 428 | 334 { |
| 440 | 335 Lisp_Font_Instance *f = (Lisp_Font_Instance *) header; |
| 428 | 336 |
| 337 if (!NILP (f->device)) | |
| 338 { | |
| 339 MAYBE_DEVMETH (XDEVICE (f->device), finalize_font_instance, (f)); | |
| 340 } | |
| 341 } | |
| 342 | |
| 343 /* Fonts are equal if they resolve to the same name. | |
| 344 Since we call `font-truename' to do this, and since font-truename is lazy, | |
| 345 this means the `equal' could cause XListFonts to be run the first time. | |
| 346 */ | |
| 347 static int | |
| 348 font_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 349 { | |
| 350 /* #### should this be moved into a device method? */ | |
| 793 | 351 return internal_equal (font_instance_truename_internal |
| 352 (obj1, ERROR_ME_DEBUG_WARN), | |
| 353 font_instance_truename_internal | |
| 354 (obj2, ERROR_ME_DEBUG_WARN), | |
| 428 | 355 depth + 1); |
| 356 } | |
| 357 | |
| 2515 | 358 static Hashcode |
| 428 | 359 font_instance_hash (Lisp_Object obj, int depth) |
| 360 { | |
| 793 | 361 return internal_hash (font_instance_truename_internal |
| 362 (obj, ERROR_ME_DEBUG_WARN), | |
| 428 | 363 depth + 1); |
| 364 } | |
| 365 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
366 DEFINE_NODUMP_LISP_OBJECT ("font-instance", font_instance, |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
367 mark_font_instance, print_font_instance, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
368 finalize_font_instance, font_instance_equal, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
369 font_instance_hash, font_instance_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
370 Lisp_Font_Instance); |
| 934 | 371 |
| 428 | 372 |
| 3094 | 373 /* #### Why is this exposed to Lisp? Used in: |
| 374 x-frob-font-size, gtk-font-menu-load-font, x-font-menu-load-font-xft, | |
| 375 x-font-menu-load-font-core, mswindows-font-menu-load-font, | |
| 376 mswindows-frob-font-style-and-sizify, mswindows-frob-font-size. */ | |
| 377 DEFUN ("make-font-instance", Fmake_font_instance, 1, 4, 0, /* | |
| 428 | 378 Return a new `font-instance' object named NAME. |
| 379 DEVICE specifies the device this object applies to and defaults to the | |
| 380 selected device. An error is signalled if the font is unknown or cannot | |
| 381 be allocated; however, if NOERROR is non-nil, nil is simply returned in | |
| 3094 | 382 this case. CHARSET is used internally. #### make helper function? |
| 428 | 383 |
| 384 The returned object is a normal, first-class lisp object. The way you | |
| 385 `deallocate' the font is the way you deallocate any other lisp object: | |
| 386 you drop all pointers to it and allow it to be garbage collected. When | |
| 3094 | 387 these objects are GCed, the underlying GUI data is deallocated as well. |
| 428 | 388 */ |
| 3094 | 389 (name, device, noerror, charset)) |
| 428 | 390 { |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
391 Lisp_Object obj; |
| 440 | 392 Lisp_Font_Instance *f; |
| 428 | 393 int retval = 0; |
| 578 | 394 Error_Behavior errb = decode_error_behavior_flag (noerror); |
| 428 | 395 |
| 396 if (ERRB_EQ (errb, ERROR_ME)) | |
| 397 CHECK_STRING (name); | |
| 398 else if (!STRINGP (name)) | |
| 399 return Qnil; | |
| 400 | |
| 793 | 401 device = wrap_device (decode_device (device)); |
| 428 | 402 |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
403 obj = ALLOC_LISP_OBJECT (font_instance); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
404 f = XFONT_INSTANCE (obj); |
| 428 | 405 f->name = name; |
| 872 | 406 f->truename = Qnil; |
| 428 | 407 f->device = device; |
| 408 | |
| 409 f->data = 0; | |
| 1204 | 410 f->font_instance_type = get_console_variant (XDEVICE_TYPE (f->device)); |
| 428 | 411 |
| 412 /* Stick some default values here ... */ | |
| 413 f->ascent = f->height = 1; | |
| 414 f->descent = 0; | |
| 415 f->width = 1; | |
| 3094 | 416 f->charset = charset; |
| 428 | 417 f->proportional_p = 0; |
| 418 | |
| 419 retval = MAYBE_INT_DEVMETH (XDEVICE (device), initialize_font_instance, | |
| 420 (f, name, device, errb)); | |
| 421 | |
| 422 if (!retval) | |
| 423 return Qnil; | |
| 424 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
425 return obj; |
| 428 | 426 } |
| 427 | |
| 428 DEFUN ("font-instance-p", Ffont_instance_p, 1, 1, 0, /* | |
| 429 Return non-nil if OBJECT is a font instance. | |
| 430 */ | |
| 431 (object)) | |
| 432 { | |
| 433 return FONT_INSTANCEP (object) ? Qt : Qnil; | |
| 434 } | |
| 435 | |
| 436 DEFUN ("font-instance-name", Ffont_instance_name, 1, 1, 0, /* | |
| 437 Return the name used to allocate FONT-INSTANCE. | |
| 438 */ | |
| 439 (font_instance)) | |
| 440 { | |
| 441 CHECK_FONT_INSTANCE (font_instance); | |
| 442 return XFONT_INSTANCE (font_instance)->name; | |
| 443 } | |
| 444 | |
| 445 DEFUN ("font-instance-ascent", Ffont_instance_ascent, 1, 1, 0, /* | |
| 446 Return the ascent in pixels of FONT-INSTANCE. | |
| 447 The returned value is the maximum ascent for all characters in the font, | |
| 448 where a character's ascent is the number of pixels above (and including) | |
| 449 the baseline. | |
| 450 */ | |
| 451 (font_instance)) | |
| 452 { | |
| 453 CHECK_FONT_INSTANCE (font_instance); | |
| 454 return make_int (XFONT_INSTANCE (font_instance)->ascent); | |
| 455 } | |
| 456 | |
| 457 DEFUN ("font-instance-descent", Ffont_instance_descent, 1, 1, 0, /* | |
| 458 Return the descent in pixels of FONT-INSTANCE. | |
| 459 The returned value is the maximum descent for all characters in the font, | |
| 460 where a character's descent is the number of pixels below the baseline. | |
| 461 \(Many characters to do not have any descent. Typical characters with a | |
| 462 descent are lowercase p and lowercase g.) | |
| 463 */ | |
| 464 (font_instance)) | |
| 465 { | |
| 466 CHECK_FONT_INSTANCE (font_instance); | |
| 467 return make_int (XFONT_INSTANCE (font_instance)->descent); | |
| 468 } | |
| 469 | |
| 470 DEFUN ("font-instance-width", Ffont_instance_width, 1, 1, 0, /* | |
| 471 Return the width in pixels of FONT-INSTANCE. | |
| 472 The returned value is the average width for all characters in the font. | |
| 473 */ | |
| 474 (font_instance)) | |
| 475 { | |
| 476 CHECK_FONT_INSTANCE (font_instance); | |
| 477 return make_int (XFONT_INSTANCE (font_instance)->width); | |
| 478 } | |
| 479 | |
| 480 DEFUN ("font-instance-proportional-p", Ffont_instance_proportional_p, 1, 1, 0, /* | |
| 481 Return whether FONT-INSTANCE is proportional. | |
| 482 This means that different characters in the font have different widths. | |
| 483 */ | |
| 484 (font_instance)) | |
| 485 { | |
| 486 CHECK_FONT_INSTANCE (font_instance); | |
| 487 return XFONT_INSTANCE (font_instance)->proportional_p ? Qt : Qnil; | |
| 488 } | |
| 489 | |
| 490 static Lisp_Object | |
| 491 font_instance_truename_internal (Lisp_Object font_instance, | |
| 578 | 492 Error_Behavior errb) |
| 428 | 493 { |
| 440 | 494 Lisp_Font_Instance *f = XFONT_INSTANCE (font_instance); |
| 495 | |
| 428 | 496 if (NILP (f->device)) |
| 497 { | |
|
4757
a23ac8f90a49
Improve warning and error messages from Xft.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4426
diff
changeset
|
498 maybe_signal_error (Qgui_error, |
|
a23ac8f90a49
Improve warning and error messages from Xft.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4426
diff
changeset
|
499 "can't determine truename: " |
|
a23ac8f90a49
Improve warning and error messages from Xft.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4426
diff
changeset
|
500 "no device for font instance", |
|
a23ac8f90a49
Improve warning and error messages from Xft.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4426
diff
changeset
|
501 font_instance, Qfont, errb); |
| 428 | 502 return Qnil; |
| 503 } | |
| 440 | 504 |
| 428 | 505 return DEVMETH_OR_GIVEN (XDEVICE (f->device), |
| 506 font_instance_truename, (f, errb), f->name); | |
| 507 } | |
| 508 | |
| 509 DEFUN ("font-instance-truename", Ffont_instance_truename, 1, 1, 0, /* | |
| 510 Return the canonical name of FONT-INSTANCE. | |
| 511 Font names are patterns which may match any number of fonts, of which | |
| 512 the first found is used. This returns an unambiguous name for that font | |
| 513 \(but not necessarily its only unambiguous name). | |
| 514 */ | |
| 515 (font_instance)) | |
| 516 { | |
| 517 CHECK_FONT_INSTANCE (font_instance); | |
| 518 return font_instance_truename_internal (font_instance, ERROR_ME); | |
| 519 } | |
| 520 | |
| 3094 | 521 DEFUN ("font-instance-charset", Ffont_instance_charset, 1, 1, 0, /* |
| 522 Return the Mule charset that FONT-INSTANCE was allocated to handle. | |
| 523 */ | |
| 524 (font_instance)) | |
| 525 { | |
| 526 CHECK_FONT_INSTANCE (font_instance); | |
| 527 return XFONT_INSTANCE (font_instance)->charset; | |
| 528 } | |
| 529 | |
| 428 | 530 DEFUN ("font-instance-properties", Ffont_instance_properties, 1, 1, 0, /* |
| 531 Return the properties (an alist or nil) of FONT-INSTANCE. | |
| 532 */ | |
| 533 (font_instance)) | |
| 534 { | |
| 440 | 535 Lisp_Font_Instance *f; |
| 428 | 536 |
| 537 CHECK_FONT_INSTANCE (font_instance); | |
| 538 f = XFONT_INSTANCE (font_instance); | |
| 539 | |
| 540 if (NILP (f->device)) | |
| 541 return Qnil; | |
| 542 | |
| 543 return MAYBE_LISP_DEVMETH (XDEVICE (f->device), | |
| 544 font_instance_properties, (f)); | |
| 545 } | |
| 546 | |
| 2527 | 547 DEFUN ("font-list", Ffont_list, 1, 3, 0, /* |
| 428 | 548 Return a list of font names matching the given pattern. |
| 549 DEVICE specifies which device to search for names, and defaults to the | |
| 550 currently selected device. | |
| 551 */ | |
| 1701 | 552 (pattern, device, maxnumber)) |
| 428 | 553 { |
| 554 CHECK_STRING (pattern); | |
| 793 | 555 device = wrap_device (decode_device (device)); |
| 428 | 556 |
| 2527 | 557 return MAYBE_LISP_DEVMETH (XDEVICE (device), font_list, (pattern, device, |
| 1701 | 558 maxnumber)); |
| 428 | 559 } |
| 560 | |
| 561 | |
| 562 /**************************************************************************** | |
| 563 Color Object | |
| 564 ***************************************************************************/ | |
| 1204 | 565 |
| 566 static const struct memory_description color_specifier_description[] = { | |
| 567 { XD_LISP_OBJECT, offsetof (struct color_specifier, face) }, | |
| 568 { XD_LISP_OBJECT, offsetof (struct color_specifier, face_property) }, | |
| 569 { XD_END } | |
| 570 }; | |
| 571 | |
| 572 DEFINE_SPECIFIER_TYPE_WITH_DATA (color); | |
| 428 | 573 /* Qcolor defined in general.c */ |
| 574 | |
| 575 static void | |
| 576 color_create (Lisp_Object obj) | |
| 577 { | |
| 440 | 578 Lisp_Specifier *color = XCOLOR_SPECIFIER (obj); |
| 428 | 579 |
| 580 COLOR_SPECIFIER_FACE (color) = Qnil; | |
| 581 COLOR_SPECIFIER_FACE_PROPERTY (color) = Qnil; | |
| 582 } | |
| 583 | |
| 584 static void | |
| 585 color_mark (Lisp_Object obj) | |
| 586 { | |
| 440 | 587 Lisp_Specifier *color = XCOLOR_SPECIFIER (obj); |
| 428 | 588 |
| 589 mark_object (COLOR_SPECIFIER_FACE (color)); | |
| 590 mark_object (COLOR_SPECIFIER_FACE_PROPERTY (color)); | |
| 591 } | |
| 592 | |
| 593 /* No equal or hash methods; ignore the face the color is based off | |
| 594 of for `equal' */ | |
| 595 | |
| 596 static Lisp_Object | |
| 2286 | 597 color_instantiate (Lisp_Object specifier, Lisp_Object UNUSED (matchspec), |
| 428 | 598 Lisp_Object domain, Lisp_Object instantiator, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
599 Lisp_Object depth, int no_fallback) |
| 428 | 600 { |
| 601 /* When called, we're inside of call_with_suspended_errors(), | |
| 602 so we can freely error. */ | |
| 442 | 603 Lisp_Object device = DOMAIN_DEVICE (domain); |
| 428 | 604 struct device *d = XDEVICE (device); |
| 605 | |
| 606 if (COLOR_INSTANCEP (instantiator)) | |
| 607 { | |
| 608 /* If we are on the same device then we're done. Otherwise change | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
609 the instantiator to the name used to generate the pixel and let the |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
610 STRINGP case deal with it. */ |
| 428 | 611 if (NILP (device) /* Vthe_null_color_instance */ |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
612 || EQ (device, XCOLOR_INSTANCE (instantiator)->device)) |
| 428 | 613 return instantiator; |
| 614 else | |
| 615 instantiator = Fcolor_instance_name (instantiator); | |
| 616 } | |
| 617 | |
| 618 if (STRINGP (instantiator)) | |
| 619 { | |
| 620 /* First, look to see if we can retrieve a cached value. */ | |
| 621 Lisp_Object instance = | |
| 622 Fgethash (instantiator, d->color_instance_cache, Qunbound); | |
| 623 /* Otherwise, make a new one. */ | |
| 624 if (UNBOUNDP (instance)) | |
| 625 { | |
| 626 /* make sure we cache the failures, too. */ | |
| 627 instance = Fmake_color_instance (instantiator, device, Qt); | |
| 628 Fputhash (instantiator, instance, d->color_instance_cache); | |
| 629 } | |
| 630 | |
| 631 return NILP (instance) ? Qunbound : instance; | |
| 632 } | |
| 633 else if (VECTORP (instantiator)) | |
| 634 { | |
| 635 switch (XVECTOR_LENGTH (instantiator)) | |
| 636 { | |
| 637 case 0: | |
| 638 if (DEVICE_TTY_P (d)) | |
| 639 return Vthe_null_color_instance; | |
| 640 else | |
| 563 | 641 gui_error ("Color instantiator [] only valid on TTY's", |
| 428 | 642 device); |
| 643 | |
| 644 case 1: | |
| 645 if (NILP (COLOR_SPECIFIER_FACE (XCOLOR_SPECIFIER (specifier)))) | |
| 563 | 646 gui_error ("Color specifier not attached to a face", |
| 428 | 647 instantiator); |
| 648 return (FACE_PROPERTY_INSTANCE_1 | |
| 649 (Fget_face (XVECTOR_DATA (instantiator)[0]), | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
650 COLOR_SPECIFIER_FACE_PROPERTY |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
651 (XCOLOR_SPECIFIER (specifier)), |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
652 domain, ERROR_ME, no_fallback, depth)); |
| 428 | 653 |
| 654 case 2: | |
| 655 return (FACE_PROPERTY_INSTANCE_1 | |
| 656 (Fget_face (XVECTOR_DATA (instantiator)[0]), | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
657 XVECTOR_DATA (instantiator)[1], domain, ERROR_ME, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
658 no_fallback, depth)); |
| 428 | 659 |
| 660 default: | |
| 2500 | 661 ABORT (); |
| 428 | 662 } |
| 663 } | |
| 664 else if (NILP (instantiator)) | |
| 665 { | |
| 666 if (DEVICE_TTY_P (d)) | |
| 667 return Vthe_null_color_instance; | |
| 668 else | |
| 563 | 669 gui_error ("Color instantiator [] only valid on TTY's", |
| 428 | 670 device); |
| 671 } | |
| 672 else | |
| 2500 | 673 ABORT (); /* The spec validation routines are screwed up. */ |
| 428 | 674 |
| 675 return Qunbound; | |
| 676 } | |
| 677 | |
| 678 static void | |
| 679 color_validate (Lisp_Object instantiator) | |
| 680 { | |
| 681 if (COLOR_INSTANCEP (instantiator) || STRINGP (instantiator)) | |
| 682 return; | |
| 683 if (VECTORP (instantiator)) | |
| 684 { | |
| 685 if (XVECTOR_LENGTH (instantiator) > 2) | |
| 563 | 686 sferror ("Inheritance vector must be of size 0 - 2", |
| 428 | 687 instantiator); |
| 688 else if (XVECTOR_LENGTH (instantiator) > 0) | |
| 689 { | |
| 690 Lisp_Object face = XVECTOR_DATA (instantiator)[0]; | |
| 691 | |
| 692 Fget_face (face); | |
| 693 if (XVECTOR_LENGTH (instantiator) == 2) | |
| 694 { | |
| 695 Lisp_Object field = XVECTOR_DATA (instantiator)[1]; | |
| 696 if (!EQ (field, Qforeground) && !EQ (field, Qbackground)) | |
| 563 | 697 invalid_constant |
| 428 | 698 ("Inheritance field must be `foreground' or `background'", |
| 699 field); | |
| 700 } | |
| 701 } | |
| 702 } | |
| 703 else | |
| 563 | 704 invalid_argument ("Invalid color instantiator", instantiator); |
| 428 | 705 } |
| 706 | |
| 707 static void | |
| 708 color_after_change (Lisp_Object specifier, Lisp_Object locale) | |
| 709 { | |
| 710 Lisp_Object face = COLOR_SPECIFIER_FACE (XCOLOR_SPECIFIER (specifier)); | |
| 711 Lisp_Object property = | |
| 712 COLOR_SPECIFIER_FACE_PROPERTY (XCOLOR_SPECIFIER (specifier)); | |
| 713 if (!NILP (face)) | |
| 448 | 714 { |
| 715 face_property_was_changed (face, property, locale); | |
| 716 if (BUFFERP (locale)) | |
| 717 XBUFFER (locale)->buffer_local_face_property = 1; | |
| 718 } | |
| 428 | 719 } |
| 720 | |
| 721 void | |
| 722 set_color_attached_to (Lisp_Object obj, Lisp_Object face, Lisp_Object property) | |
| 723 { | |
| 440 | 724 Lisp_Specifier *color = XCOLOR_SPECIFIER (obj); |
| 428 | 725 |
| 726 COLOR_SPECIFIER_FACE (color) = face; | |
| 727 COLOR_SPECIFIER_FACE_PROPERTY (color) = property; | |
| 728 } | |
| 729 | |
| 730 DEFUN ("color-specifier-p", Fcolor_specifier_p, 1, 1, 0, /* | |
| 731 Return t if OBJECT is a color specifier. | |
| 732 | |
| 442 | 733 See `make-color-specifier' for a description of possible color instantiators. |
| 428 | 734 */ |
| 735 (object)) | |
| 736 { | |
| 737 return COLOR_SPECIFIERP (object) ? Qt : Qnil; | |
| 738 } | |
| 739 | |
| 740 | |
| 741 /**************************************************************************** | |
| 742 Font Object | |
| 743 ***************************************************************************/ | |
| 1204 | 744 |
| 745 static const struct memory_description font_specifier_description[] = { | |
| 746 { XD_LISP_OBJECT, offsetof (struct font_specifier, face) }, | |
| 747 { XD_LISP_OBJECT, offsetof (struct font_specifier, face_property) }, | |
| 748 { XD_END } | |
| 749 }; | |
| 750 | |
| 751 DEFINE_SPECIFIER_TYPE_WITH_DATA (font); | |
| 428 | 752 /* Qfont defined in general.c */ |
| 753 | |
| 754 static void | |
| 755 font_create (Lisp_Object obj) | |
| 756 { | |
| 440 | 757 Lisp_Specifier *font = XFONT_SPECIFIER (obj); |
| 428 | 758 |
| 759 FONT_SPECIFIER_FACE (font) = Qnil; | |
| 760 FONT_SPECIFIER_FACE_PROPERTY (font) = Qnil; | |
| 761 } | |
| 762 | |
| 763 static void | |
| 764 font_mark (Lisp_Object obj) | |
| 765 { | |
| 440 | 766 Lisp_Specifier *font = XFONT_SPECIFIER (obj); |
| 428 | 767 |
| 768 mark_object (FONT_SPECIFIER_FACE (font)); | |
| 769 mark_object (FONT_SPECIFIER_FACE_PROPERTY (font)); | |
| 770 } | |
| 771 | |
| 772 /* No equal or hash methods; ignore the face the font is based off | |
| 773 of for `equal' */ | |
| 774 | |
| 775 #ifdef MULE | |
| 776 | |
| 872 | 777 /* Given a truename font spec (i.e. the font spec should have its registry |
| 778 field filled in), does it support displaying characters from CHARSET? */ | |
| 779 | |
| 780 static int | |
| 428 | 781 font_spec_matches_charset (struct device *d, Lisp_Object charset, |
| 867 | 782 const Ibyte *nonreloc, Lisp_Object reloc, |
| 872 | 783 Bytecount offset, Bytecount length, |
| 3659 | 784 enum font_specifier_matchspec_stages stage) |
| 428 | 785 { |
| 786 return DEVMETH_OR_GIVEN (d, font_spec_matches_charset, | |
| 872 | 787 (d, charset, nonreloc, reloc, offset, length, |
| 788 stage), | |
| 428 | 789 1); |
| 790 } | |
| 791 | |
| 792 static void | |
| 793 font_validate_matchspec (Lisp_Object matchspec) | |
| 794 { | |
| 872 | 795 CHECK_CONS (matchspec); |
| 796 Fget_charset (XCAR (matchspec)); | |
| 3659 | 797 |
| 798 do | |
| 799 { | |
| 800 if (EQ(XCDR(matchspec), Qinitial)) | |
| 801 { | |
| 802 break; | |
| 803 } | |
| 804 if (EQ(XCDR(matchspec), Qfinal)) | |
| 805 { | |
| 806 break; | |
| 807 } | |
| 808 | |
| 809 invalid_argument("Invalid font matchspec stage", | |
| 810 XCDR(matchspec)); | |
| 811 } while (0); | |
| 428 | 812 } |
| 813 | |
| 872 | 814 void |
| 815 initialize_charset_font_caches (struct device *d) | |
| 816 { | |
| 817 /* Note that the following tables are bi-level. */ | |
| 818 d->charset_font_cache_stage_1 = | |
| 819 make_lisp_hash_table (20, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); | |
| 820 d->charset_font_cache_stage_2 = | |
| 821 make_lisp_hash_table (20, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); | |
| 822 } | |
| 823 | |
| 824 void | |
| 825 invalidate_charset_font_caches (Lisp_Object charset) | |
| 826 { | |
| 827 /* Invalidate font cache entries for charset on all devices. */ | |
| 828 Lisp_Object devcons, concons, hash_table; | |
| 829 DEVICE_LOOP_NO_BREAK (devcons, concons) | |
| 830 { | |
| 831 struct device *d = XDEVICE (XCAR (devcons)); | |
| 832 hash_table = Fgethash (charset, d->charset_font_cache_stage_1, | |
| 833 Qunbound); | |
| 834 if (!UNBOUNDP (hash_table)) | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
835 Fclrhash (hash_table); |
| 872 | 836 hash_table = Fgethash (charset, d->charset_font_cache_stage_2, |
| 837 Qunbound); | |
| 838 if (!UNBOUNDP (hash_table)) | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
839 Fclrhash (hash_table); |
| 872 | 840 } |
| 841 } | |
| 428 | 842 |
| 874 | 843 #endif /* MULE */ |
| 844 | |
| 845 | |
| 428 | 846 static Lisp_Object |
| 2333 | 847 font_instantiate (Lisp_Object UNUSED (specifier), |
| 848 Lisp_Object USED_IF_MULE (matchspec), | |
| 428 | 849 Lisp_Object domain, Lisp_Object instantiator, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
850 Lisp_Object depth, int no_fallback) |
| 428 | 851 { |
| 852 /* When called, we're inside of call_with_suspended_errors(), | |
| 853 so we can freely error. */ | |
| 442 | 854 Lisp_Object device = DOMAIN_DEVICE (domain); |
| 428 | 855 struct device *d = XDEVICE (device); |
| 856 Lisp_Object instance; | |
| 872 | 857 Lisp_Object charset = Qnil; |
| 1204 | 858 #ifdef MULE |
| 3659 | 859 enum font_specifier_matchspec_stages stage = initial; |
| 428 | 860 |
| 861 if (!UNBOUNDP (matchspec)) | |
| 872 | 862 { |
| 863 charset = Fget_charset (XCAR (matchspec)); | |
| 3659 | 864 |
| 865 #define FROB(new_stage) if (EQ(Q##new_stage, XCDR(matchspec))) \ | |
| 866 { \ | |
| 867 stage = new_stage; \ | |
| 868 } | |
| 869 | |
| 870 FROB(initial) | |
| 871 else FROB(final) | |
| 872 else assert(0); | |
| 873 | |
| 874 #undef FROB | |
| 875 | |
| 872 | 876 } |
| 428 | 877 #endif |
| 878 | |
| 879 if (FONT_INSTANCEP (instantiator)) | |
| 880 { | |
| 881 if (NILP (device) | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
882 || EQ (device, XFONT_INSTANCE (instantiator)->device)) |
| 428 | 883 { |
| 884 #ifdef MULE | |
| 872 | 885 if (font_spec_matches_charset (d, charset, 0, |
| 428 | 886 Ffont_instance_truename |
| 887 (instantiator), | |
| 872 | 888 0, -1, stage)) |
| 1204 | 889 #endif |
| 428 | 890 return instantiator; |
| 891 } | |
| 892 instantiator = Ffont_instance_name (instantiator); | |
| 893 } | |
| 894 | |
| 895 if (STRINGP (instantiator)) | |
| 896 { | |
| 874 | 897 #ifdef MULE |
| 3659 | 898 /* #### rename these caches. */ |
| 872 | 899 Lisp_Object cache = stage ? d->charset_font_cache_stage_2 : |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
900 d->charset_font_cache_stage_1; |
| 874 | 901 #else |
| 902 Lisp_Object cache = d->font_instance_cache; | |
| 903 #endif | |
| 872 | 904 |
| 428 | 905 #ifdef MULE |
| 872 | 906 if (!NILP (charset)) |
| 428 | 907 { |
| 908 /* The instantiator is a font spec that could match many | |
| 909 different fonts. We need to find one of those fonts | |
| 910 whose registry matches the registry of the charset in | |
| 911 MATCHSPEC. This is potentially a very slow operation, | |
| 912 as it involves doing an XListFonts() or equivalent to | |
| 913 iterate over all possible fonts, and a regexp match | |
| 914 on each one. So we cache the results. */ | |
| 915 Lisp_Object matching_font = Qunbound; | |
| 872 | 916 Lisp_Object hash_table = Fgethash (charset, cache, Qunbound); |
| 428 | 917 if (UNBOUNDP (hash_table)) |
| 918 { | |
| 919 /* need to make a sub hash table. */ | |
| 920 hash_table = make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, | |
| 921 HASH_TABLE_EQUAL); | |
| 872 | 922 Fputhash (charset, hash_table, cache); |
| 428 | 923 } |
| 924 else | |
| 925 matching_font = Fgethash (instantiator, hash_table, Qunbound); | |
| 926 | |
| 927 if (UNBOUNDP (matching_font)) | |
| 928 { | |
| 929 /* make sure we cache the failures, too. */ | |
| 930 matching_font = | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
931 DEVMETH_OR_GIVEN (d, find_charset_font, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
932 (device, instantiator, charset, stage), |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
933 instantiator); |
| 428 | 934 Fputhash (instantiator, matching_font, hash_table); |
| 935 } | |
| 936 if (NILP (matching_font)) | |
| 937 return Qunbound; | |
| 938 instantiator = matching_font; | |
| 939 } | |
| 940 #endif /* MULE */ | |
| 941 | |
| 942 /* First, look to see if we can retrieve a cached value. */ | |
| 872 | 943 instance = Fgethash (instantiator, cache, Qunbound); |
| 428 | 944 /* Otherwise, make a new one. */ |
| 945 if (UNBOUNDP (instance)) | |
| 946 { | |
| 947 /* make sure we cache the failures, too. */ | |
| 3094 | 948 instance = Fmake_font_instance (instantiator, device, Qt, charset); |
| 872 | 949 Fputhash (instantiator, instance, cache); |
| 428 | 950 } |
| 951 | |
| 952 return NILP (instance) ? Qunbound : instance; | |
| 953 } | |
| 954 else if (VECTORP (instantiator)) | |
| 955 { | |
| 3659 | 956 Lisp_Object match_inst = Qunbound; |
| 428 | 957 assert (XVECTOR_LENGTH (instantiator) == 1); |
| 3659 | 958 |
| 959 match_inst = face_property_matching_instance | |
| 960 (Fget_face (XVECTOR_DATA (instantiator)[0]), Qfont, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
961 charset, domain, ERROR_ME, no_fallback, depth, initial); |
| 3659 | 962 |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
963 if (UNBOUNDP(match_inst)) |
| 3659 | 964 { |
| 965 match_inst = face_property_matching_instance | |
| 966 (Fget_face (XVECTOR_DATA (instantiator)[0]), Qfont, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
967 charset, domain, ERROR_ME, no_fallback, depth, final); |
| 3659 | 968 } |
| 969 | |
| 970 return match_inst; | |
| 971 | |
| 428 | 972 } |
| 973 else if (NILP (instantiator)) | |
| 974 return Qunbound; | |
| 975 else | |
| 2500 | 976 ABORT (); /* Eh? */ |
| 428 | 977 |
| 978 return Qunbound; | |
| 979 } | |
| 980 | |
| 981 static void | |
| 982 font_validate (Lisp_Object instantiator) | |
| 983 { | |
| 984 if (FONT_INSTANCEP (instantiator) || STRINGP (instantiator)) | |
| 985 return; | |
| 986 if (VECTORP (instantiator)) | |
| 987 { | |
| 988 if (XVECTOR_LENGTH (instantiator) != 1) | |
| 989 { | |
| 563 | 990 sferror |
| 428 | 991 ("Vector length must be one for font inheritance", instantiator); |
| 992 } | |
| 993 Fget_face (XVECTOR_DATA (instantiator)[0]); | |
| 994 } | |
| 995 else | |
| 563 | 996 invalid_argument ("Must be string, vector, or font-instance", |
| 428 | 997 instantiator); |
| 998 } | |
| 999 | |
| 1000 static void | |
| 1001 font_after_change (Lisp_Object specifier, Lisp_Object locale) | |
| 1002 { | |
| 1003 Lisp_Object face = FONT_SPECIFIER_FACE (XFONT_SPECIFIER (specifier)); | |
| 1004 Lisp_Object property = | |
| 1005 FONT_SPECIFIER_FACE_PROPERTY (XFONT_SPECIFIER (specifier)); | |
| 1006 if (!NILP (face)) | |
| 448 | 1007 { |
| 1008 face_property_was_changed (face, property, locale); | |
| 1009 if (BUFFERP (locale)) | |
| 1010 XBUFFER (locale)->buffer_local_face_property = 1; | |
| 1011 } | |
| 428 | 1012 } |
| 1013 | |
| 1014 void | |
| 1015 set_font_attached_to (Lisp_Object obj, Lisp_Object face, Lisp_Object property) | |
| 1016 { | |
| 440 | 1017 Lisp_Specifier *font = XFONT_SPECIFIER (obj); |
| 428 | 1018 |
| 1019 FONT_SPECIFIER_FACE (font) = face; | |
| 1020 FONT_SPECIFIER_FACE_PROPERTY (font) = property; | |
| 1021 } | |
| 1022 | |
| 1023 DEFUN ("font-specifier-p", Ffont_specifier_p, 1, 1, 0, /* | |
| 1024 Return non-nil if OBJECT is a font specifier. | |
| 1025 | |
| 442 | 1026 See `make-font-specifier' for a description of possible font instantiators. |
| 428 | 1027 */ |
| 1028 (object)) | |
| 1029 { | |
| 1030 return FONT_SPECIFIERP (object) ? Qt : Qnil; | |
| 1031 } | |
| 1032 | |
| 1033 | |
| 1034 /***************************************************************************** | |
| 1035 Face Boolean Object | |
| 1036 ****************************************************************************/ | |
| 1204 | 1037 |
| 1038 static const struct memory_description face_boolean_specifier_description[] = { | |
| 1039 { XD_LISP_OBJECT, offsetof (struct face_boolean_specifier, face) }, | |
| 1040 { XD_LISP_OBJECT, offsetof (struct face_boolean_specifier, face_property) }, | |
| 1041 { XD_END } | |
| 1042 }; | |
| 1043 | |
| 1044 DEFINE_SPECIFIER_TYPE_WITH_DATA (face_boolean); | |
| 428 | 1045 Lisp_Object Qface_boolean; |
| 1046 | |
| 1047 static void | |
| 1048 face_boolean_create (Lisp_Object obj) | |
| 1049 { | |
| 440 | 1050 Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj); |
| 428 | 1051 |
| 1052 FACE_BOOLEAN_SPECIFIER_FACE (face_boolean) = Qnil; | |
| 1053 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean) = Qnil; | |
| 1054 } | |
| 1055 | |
| 1056 static void | |
| 1057 face_boolean_mark (Lisp_Object obj) | |
| 1058 { | |
| 440 | 1059 Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj); |
| 428 | 1060 |
| 1061 mark_object (FACE_BOOLEAN_SPECIFIER_FACE (face_boolean)); | |
| 1062 mark_object (FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean)); | |
| 1063 } | |
| 1064 | |
| 1065 /* No equal or hash methods; ignore the face the face-boolean is based off | |
| 1066 of for `equal' */ | |
| 1067 | |
| 1068 static Lisp_Object | |
| 2286 | 1069 face_boolean_instantiate (Lisp_Object specifier, |
| 1070 Lisp_Object UNUSED (matchspec), | |
| 428 | 1071 Lisp_Object domain, Lisp_Object instantiator, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
1072 Lisp_Object depth, int no_fallback) |
| 428 | 1073 { |
| 1074 /* When called, we're inside of call_with_suspended_errors(), | |
| 1075 so we can freely error. */ | |
| 1076 if (NILP (instantiator) || EQ (instantiator, Qt)) | |
| 1077 return instantiator; | |
| 1078 else if (VECTORP (instantiator)) | |
| 1079 { | |
| 1080 Lisp_Object retval; | |
| 1081 Lisp_Object prop; | |
| 1082 int instantiator_len = XVECTOR_LENGTH (instantiator); | |
| 1083 | |
| 1084 assert (instantiator_len >= 1 && instantiator_len <= 3); | |
| 1085 if (instantiator_len > 1) | |
| 1086 prop = XVECTOR_DATA (instantiator)[1]; | |
| 1087 else | |
| 1088 { | |
| 1089 if (NILP (FACE_BOOLEAN_SPECIFIER_FACE | |
| 1090 (XFACE_BOOLEAN_SPECIFIER (specifier)))) | |
| 563 | 1091 gui_error |
| 428 | 1092 ("Face-boolean specifier not attached to a face", instantiator); |
| 1093 prop = FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY | |
| 1094 (XFACE_BOOLEAN_SPECIFIER (specifier)); | |
| 1095 } | |
| 1096 | |
| 1097 retval = (FACE_PROPERTY_INSTANCE_1 | |
| 1098 (Fget_face (XVECTOR_DATA (instantiator)[0]), | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
1099 prop, domain, ERROR_ME, no_fallback, depth)); |
| 428 | 1100 |
| 1101 if (instantiator_len == 3 && !NILP (XVECTOR_DATA (instantiator)[2])) | |
| 1102 retval = NILP (retval) ? Qt : Qnil; | |
| 1103 | |
| 1104 return retval; | |
| 1105 } | |
| 1106 else | |
| 2500 | 1107 ABORT (); /* Eh? */ |
| 428 | 1108 |
| 1109 return Qunbound; | |
| 1110 } | |
| 1111 | |
| 1112 static void | |
| 1113 face_boolean_validate (Lisp_Object instantiator) | |
| 1114 { | |
| 1115 if (NILP (instantiator) || EQ (instantiator, Qt)) | |
| 1116 return; | |
| 1117 else if (VECTORP (instantiator) && | |
| 1118 (XVECTOR_LENGTH (instantiator) >= 1 && | |
| 1119 XVECTOR_LENGTH (instantiator) <= 3)) | |
| 1120 { | |
| 1121 Lisp_Object face = XVECTOR_DATA (instantiator)[0]; | |
| 1122 | |
| 1123 Fget_face (face); | |
| 1124 | |
| 1125 if (XVECTOR_LENGTH (instantiator) > 1) | |
| 1126 { | |
| 1127 Lisp_Object field = XVECTOR_DATA (instantiator)[1]; | |
| 1128 if (!EQ (field, Qunderline) | |
| 1129 && !EQ (field, Qstrikethru) | |
| 1130 && !EQ (field, Qhighlight) | |
| 1131 && !EQ (field, Qdim) | |
| 1132 && !EQ (field, Qblinking) | |
| 1133 && !EQ (field, Qreverse)) | |
| 563 | 1134 invalid_constant ("Invalid face-boolean inheritance field", |
| 428 | 1135 field); |
| 1136 } | |
| 1137 } | |
| 1138 else if (VECTORP (instantiator)) | |
| 563 | 1139 sferror ("Wrong length for face-boolean inheritance spec", |
| 428 | 1140 instantiator); |
| 1141 else | |
| 563 | 1142 invalid_argument ("Face-boolean instantiator must be nil, t, or vector", |
| 428 | 1143 instantiator); |
| 1144 } | |
| 1145 | |
| 1146 static void | |
| 1147 face_boolean_after_change (Lisp_Object specifier, Lisp_Object locale) | |
| 1148 { | |
| 1149 Lisp_Object face = | |
| 1150 FACE_BOOLEAN_SPECIFIER_FACE (XFACE_BOOLEAN_SPECIFIER (specifier)); | |
| 1151 Lisp_Object property = | |
| 1152 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (XFACE_BOOLEAN_SPECIFIER (specifier)); | |
| 1153 if (!NILP (face)) | |
| 448 | 1154 { |
| 1155 face_property_was_changed (face, property, locale); | |
| 1156 if (BUFFERP (locale)) | |
| 1157 XBUFFER (locale)->buffer_local_face_property = 1; | |
| 1158 } | |
| 428 | 1159 } |
| 1160 | |
| 1161 void | |
| 1162 set_face_boolean_attached_to (Lisp_Object obj, Lisp_Object face, | |
| 1163 Lisp_Object property) | |
| 1164 { | |
| 440 | 1165 Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj); |
| 428 | 1166 |
| 1167 FACE_BOOLEAN_SPECIFIER_FACE (face_boolean) = face; | |
| 1168 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean) = property; | |
| 1169 } | |
| 1170 | |
| 1171 DEFUN ("face-boolean-specifier-p", Fface_boolean_specifier_p, 1, 1, 0, /* | |
| 1172 Return non-nil if OBJECT is a face-boolean specifier. | |
| 1173 | |
| 442 | 1174 See `make-face-boolean-specifier' for a description of possible |
| 1175 face-boolean instantiators. | |
| 428 | 1176 */ |
| 1177 (object)) | |
| 1178 { | |
| 1179 return FACE_BOOLEAN_SPECIFIERP (object) ? Qt : Qnil; | |
| 1180 } | |
| 1181 | |
| 1182 | |
| 1183 /************************************************************************/ | |
| 1184 /* initialization */ | |
| 1185 /************************************************************************/ | |
| 1186 | |
| 1187 void | |
| 1188 syms_of_objects (void) | |
| 1189 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1190 INIT_LISP_OBJECT (color_instance); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1191 INIT_LISP_OBJECT (font_instance); |
| 442 | 1192 |
| 428 | 1193 DEFSUBR (Fcolor_specifier_p); |
| 1194 DEFSUBR (Ffont_specifier_p); | |
| 1195 DEFSUBR (Fface_boolean_specifier_p); | |
| 1196 | |
| 563 | 1197 DEFSYMBOL_MULTIWORD_PREDICATE (Qcolor_instancep); |
| 428 | 1198 DEFSUBR (Fmake_color_instance); |
| 1199 DEFSUBR (Fcolor_instance_p); | |
| 1200 DEFSUBR (Fcolor_instance_name); | |
| 1201 DEFSUBR (Fcolor_instance_rgb_components); | |
| 1202 DEFSUBR (Fvalid_color_name_p); | |
| 2527 | 1203 DEFSUBR (Fcolor_list); |
| 428 | 1204 |
| 563 | 1205 DEFSYMBOL_MULTIWORD_PREDICATE (Qfont_instancep); |
| 428 | 1206 DEFSUBR (Fmake_font_instance); |
| 1207 DEFSUBR (Ffont_instance_p); | |
| 1208 DEFSUBR (Ffont_instance_name); | |
| 1209 DEFSUBR (Ffont_instance_ascent); | |
| 1210 DEFSUBR (Ffont_instance_descent); | |
| 1211 DEFSUBR (Ffont_instance_width); | |
| 3094 | 1212 DEFSUBR (Ffont_instance_charset); |
| 428 | 1213 DEFSUBR (Ffont_instance_proportional_p); |
| 1214 DEFSUBR (Ffont_instance_truename); | |
| 1215 DEFSUBR (Ffont_instance_properties); | |
| 2527 | 1216 DEFSUBR (Ffont_list); |
| 428 | 1217 |
| 1218 /* Qcolor, Qfont defined in general.c */ | |
| 563 | 1219 DEFSYMBOL (Qface_boolean); |
| 428 | 1220 } |
| 1221 | |
| 1222 void | |
| 1223 specifier_type_create_objects (void) | |
| 1224 { | |
| 1225 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (color, "color", "color-specifier-p"); | |
| 1226 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (font, "font", "font-specifier-p"); | |
| 1227 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (face_boolean, "face-boolean", | |
| 1228 "face-boolean-specifier-p"); | |
| 1229 | |
| 1230 SPECIFIER_HAS_METHOD (color, instantiate); | |
| 1231 SPECIFIER_HAS_METHOD (font, instantiate); | |
| 1232 SPECIFIER_HAS_METHOD (face_boolean, instantiate); | |
| 1233 | |
| 1234 SPECIFIER_HAS_METHOD (color, validate); | |
| 1235 SPECIFIER_HAS_METHOD (font, validate); | |
| 1236 SPECIFIER_HAS_METHOD (face_boolean, validate); | |
| 1237 | |
| 1238 SPECIFIER_HAS_METHOD (color, create); | |
| 1239 SPECIFIER_HAS_METHOD (font, create); | |
| 1240 SPECIFIER_HAS_METHOD (face_boolean, create); | |
| 1241 | |
| 1242 SPECIFIER_HAS_METHOD (color, mark); | |
| 1243 SPECIFIER_HAS_METHOD (font, mark); | |
| 1244 SPECIFIER_HAS_METHOD (face_boolean, mark); | |
| 1245 | |
| 1246 SPECIFIER_HAS_METHOD (color, after_change); | |
| 1247 SPECIFIER_HAS_METHOD (font, after_change); | |
| 1248 SPECIFIER_HAS_METHOD (face_boolean, after_change); | |
| 1249 | |
| 1250 #ifdef MULE | |
| 1251 SPECIFIER_HAS_METHOD (font, validate_matchspec); | |
| 1252 #endif | |
| 1253 } | |
| 1254 | |
| 1255 void | |
| 1256 reinit_specifier_type_create_objects (void) | |
| 1257 { | |
| 1258 REINITIALIZE_SPECIFIER_TYPE (color); | |
| 1259 REINITIALIZE_SPECIFIER_TYPE (font); | |
| 1260 REINITIALIZE_SPECIFIER_TYPE (face_boolean); | |
| 1261 } | |
| 1262 | |
| 1263 void | |
| 1264 reinit_vars_of_objects (void) | |
| 1265 { | |
| 1266 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1267 Lisp_Object obj = ALLOC_LISP_OBJECT (color_instance); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1268 Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); |
| 428 | 1269 c->name = Qnil; |
| 1270 c->device = Qnil; | |
| 1271 c->data = 0; | |
| 1272 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1273 Vthe_null_color_instance = obj; |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1274 staticpro_nodump (&Vthe_null_color_instance); |
| 428 | 1275 } |
| 1276 | |
| 1277 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1278 Lisp_Object obj = ALLOC_LISP_OBJECT (font_instance); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1279 Lisp_Font_Instance *f = XFONT_INSTANCE (obj); |
| 428 | 1280 f->name = Qnil; |
| 872 | 1281 f->truename = Qnil; |
| 428 | 1282 f->device = Qnil; |
| 1283 f->data = 0; | |
| 1284 | |
| 1285 f->ascent = f->height = 0; | |
| 1286 f->descent = 0; | |
| 1287 f->width = 0; | |
| 1288 f->proportional_p = 0; | |
| 1289 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1290 Vthe_null_font_instance = obj; |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1291 staticpro_nodump (&Vthe_null_font_instance); |
| 428 | 1292 } |
| 1293 } | |
| 1294 | |
| 1295 void | |
| 1296 vars_of_objects (void) | |
| 1297 { | |
| 1298 } |