Mercurial > hg > xemacs-beta
annotate src/fontcolor.c @ 5724:ede80ef92a74
Make soft links in src for module source files, if built in to the executable.
This ensures that those files are built with the same compiler flags as all
other source files.
See these xemacs-beta messages:
<CAHCOHQn+q=Xuwq+y68dvqi7afAP9f-TdB7=8YiZ8VYO816sjHg@mail.gmail.com>
<f5by5ejqiyk.fsf@calexico.inf.ed.ac.uk>
| author | Jerry James <james@xemacs.org> |
|---|---|
| date | Sat, 02 Mar 2013 14:32:37 -0700 |
| parents | c39052c921b5 |
| children |
| 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. | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
4 Copyright (C) 1995, 1996, 2002, 2004, 2005, 2010 Ben Wing. |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
5 Copyright (C) 2010 Didier Verna |
| 428 | 6 |
| 7 This file is part of XEmacs. | |
| 8 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5191
diff
changeset
|
9 XEmacs is free software: you can redistribute it and/or modify it |
| 428 | 10 under the terms of the GNU General Public License as published by the |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5191
diff
changeset
|
11 Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5191
diff
changeset
|
12 option) any later version. |
| 428 | 13 |
| 14 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 15 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 17 for more details. | |
| 18 | |
| 19 You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5191
diff
changeset
|
20 along with XEmacs. If not, see <http://www.gnu.org/licenses/>. */ |
| 428 | 21 |
| 22 /* Synched up with: Not in FSF. */ | |
| 23 | |
| 24 #include <config.h> | |
| 25 #include "lisp.h" | |
| 26 | |
| 771 | 27 #include "buffer.h" |
| 872 | 28 #include "device-impl.h" |
| 428 | 29 #include "elhash.h" |
| 30 #include "faces.h" | |
| 31 #include "frame.h" | |
| 800 | 32 #include "glyphs.h" |
|
5176
8b2f75cecb89
rename objects* (.c, .h and .el files) to fontcolor*
Ben Wing <ben@xemacs.org>
parents:
5015
diff
changeset
|
33 #include "fontcolor-impl.h" |
| 428 | 34 #include "specifier.h" |
| 35 #include "window.h" | |
| 36 | |
| 1204 | 37 #ifdef HAVE_TTY |
| 38 #include "console-tty.h" | |
| 39 #endif | |
| 934 | 40 |
| 428 | 41 /* Objects that are substituted when an instantiation fails. |
| 42 If we leave in the Qunbound value, we will probably get crashes. */ | |
| 43 Lisp_Object Vthe_null_color_instance, Vthe_null_font_instance; | |
| 44 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
45 /* Author: Ben Wing; some earlier code from Chuck Thompson, Jamie |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
46 Zawinski. */ |
| 428 | 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) |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
105 printing_unreadable_lisp_object (obj, 0); |
| 800 | 106 write_fmt_string_lisp (printcharfun, "#<color-instance %s", 1, c->name); |
| 107 write_fmt_string_lisp (printcharfun, " on %s", 1, c->device); | |
| 428 | 108 if (!NILP (c->device)) /* Vthe_null_color_instance */ |
| 109 MAYBE_DEVMETH (XDEVICE (c->device), print_color_instance, | |
| 110 (c, printcharfun, escapeflag)); | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
111 write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); |
| 428 | 112 } |
| 113 | |
| 114 static void | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
115 finalize_color_instance (Lisp_Object obj) |
| 428 | 116 { |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
117 Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); |
| 428 | 118 |
| 119 if (!NILP (c->device)) | |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
120 MAYBE_DEVMETH (XDEVICE (c->device), finalize_color_instance, (c)); |
| 428 | 121 } |
| 122 | |
| 123 static int | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
124 color_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
125 int UNUSED (foldcase)) |
| 428 | 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 |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5178
diff
changeset
|
138 color_instance_hash (Lisp_Object obj, int depth, Boolint UNUSED (equalp)) |
| 428 | 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 |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
182 obj = ALLOC_NORMAL_LISP_OBJECT (color_instance); |
|
5117
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) |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
320 printing_unreadable_lisp_object (obj, 0); |
| 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 } | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
329 write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); |
| 428 | 330 } |
| 331 | |
| 332 static void | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
333 finalize_font_instance (Lisp_Object obj) |
| 428 | 334 { |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
335 Lisp_Font_Instance *f = XFONT_INSTANCE (obj); |
| 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 | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
348 font_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
349 int UNUSED (foldcase)) |
| 428 | 350 { |
| 351 /* #### should this be moved into a device method? */ | |
| 793 | 352 return internal_equal (font_instance_truename_internal |
| 353 (obj1, ERROR_ME_DEBUG_WARN), | |
| 354 font_instance_truename_internal | |
| 355 (obj2, ERROR_ME_DEBUG_WARN), | |
| 428 | 356 depth + 1); |
| 357 } | |
| 358 | |
| 2515 | 359 static Hashcode |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5178
diff
changeset
|
360 font_instance_hash (Lisp_Object obj, int depth, Boolint UNUSED (equalp)) |
| 428 | 361 { |
| 793 | 362 return internal_hash (font_instance_truename_internal |
| 363 (obj, ERROR_ME_DEBUG_WARN), | |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5178
diff
changeset
|
364 depth + 1, 0); |
| 428 | 365 } |
| 366 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
367 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
|
368 mark_font_instance, print_font_instance, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
369 finalize_font_instance, font_instance_equal, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
370 font_instance_hash, font_instance_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
371 Lisp_Font_Instance); |
| 934 | 372 |
| 428 | 373 |
| 3094 | 374 /* #### Why is this exposed to Lisp? Used in: |
| 375 x-frob-font-size, gtk-font-menu-load-font, x-font-menu-load-font-xft, | |
| 376 x-font-menu-load-font-core, mswindows-font-menu-load-font, | |
| 377 mswindows-frob-font-style-and-sizify, mswindows-frob-font-size. */ | |
| 378 DEFUN ("make-font-instance", Fmake_font_instance, 1, 4, 0, /* | |
| 428 | 379 Return a new `font-instance' object named NAME. |
| 380 DEVICE specifies the device this object applies to and defaults to the | |
| 381 selected device. An error is signalled if the font is unknown or cannot | |
| 382 be allocated; however, if NOERROR is non-nil, nil is simply returned in | |
| 3094 | 383 this case. CHARSET is used internally. #### make helper function? |
| 428 | 384 |
| 385 The returned object is a normal, first-class lisp object. The way you | |
| 386 `deallocate' the font is the way you deallocate any other lisp object: | |
| 387 you drop all pointers to it and allow it to be garbage collected. When | |
| 3094 | 388 these objects are GCed, the underlying GUI data is deallocated as well. |
| 428 | 389 */ |
| 3094 | 390 (name, device, noerror, charset)) |
| 428 | 391 { |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
392 Lisp_Object obj; |
| 440 | 393 Lisp_Font_Instance *f; |
| 428 | 394 int retval = 0; |
| 578 | 395 Error_Behavior errb = decode_error_behavior_flag (noerror); |
| 428 | 396 |
| 397 if (ERRB_EQ (errb, ERROR_ME)) | |
| 398 CHECK_STRING (name); | |
| 399 else if (!STRINGP (name)) | |
| 400 return Qnil; | |
| 401 | |
| 793 | 402 device = wrap_device (decode_device (device)); |
| 428 | 403 |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
404 obj = ALLOC_NORMAL_LISP_OBJECT (font_instance); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
405 f = XFONT_INSTANCE (obj); |
| 428 | 406 f->name = name; |
| 872 | 407 f->truename = Qnil; |
| 428 | 408 f->device = device; |
| 409 | |
| 410 f->data = 0; | |
| 1204 | 411 f->font_instance_type = get_console_variant (XDEVICE_TYPE (f->device)); |
| 428 | 412 |
| 413 /* Stick some default values here ... */ | |
| 414 f->ascent = f->height = 1; | |
| 415 f->descent = 0; | |
| 416 f->width = 1; | |
| 3094 | 417 f->charset = charset; |
| 428 | 418 f->proportional_p = 0; |
| 419 | |
| 420 retval = MAYBE_INT_DEVMETH (XDEVICE (device), initialize_font_instance, | |
| 421 (f, name, device, errb)); | |
| 422 | |
| 423 if (!retval) | |
| 424 return Qnil; | |
| 425 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
426 return obj; |
| 428 | 427 } |
| 428 | |
| 429 DEFUN ("font-instance-p", Ffont_instance_p, 1, 1, 0, /* | |
| 430 Return non-nil if OBJECT is a font instance. | |
| 431 */ | |
| 432 (object)) | |
| 433 { | |
| 434 return FONT_INSTANCEP (object) ? Qt : Qnil; | |
| 435 } | |
| 436 | |
| 437 DEFUN ("font-instance-name", Ffont_instance_name, 1, 1, 0, /* | |
| 438 Return the name used to allocate FONT-INSTANCE. | |
| 439 */ | |
| 440 (font_instance)) | |
| 441 { | |
| 442 CHECK_FONT_INSTANCE (font_instance); | |
| 443 return XFONT_INSTANCE (font_instance)->name; | |
| 444 } | |
| 445 | |
| 446 DEFUN ("font-instance-ascent", Ffont_instance_ascent, 1, 1, 0, /* | |
| 447 Return the ascent in pixels of FONT-INSTANCE. | |
| 448 The returned value is the maximum ascent for all characters in the font, | |
| 449 where a character's ascent is the number of pixels above (and including) | |
| 450 the baseline. | |
| 451 */ | |
| 452 (font_instance)) | |
| 453 { | |
| 454 CHECK_FONT_INSTANCE (font_instance); | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
455 return make_fixnum (XFONT_INSTANCE (font_instance)->ascent); |
| 428 | 456 } |
| 457 | |
| 458 DEFUN ("font-instance-descent", Ffont_instance_descent, 1, 1, 0, /* | |
| 459 Return the descent in pixels of FONT-INSTANCE. | |
| 460 The returned value is the maximum descent for all characters in the font, | |
| 461 where a character's descent is the number of pixels below the baseline. | |
| 462 \(Many characters to do not have any descent. Typical characters with a | |
| 463 descent are lowercase p and lowercase g.) | |
| 464 */ | |
| 465 (font_instance)) | |
| 466 { | |
| 467 CHECK_FONT_INSTANCE (font_instance); | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
468 return make_fixnum (XFONT_INSTANCE (font_instance)->descent); |
| 428 | 469 } |
| 470 | |
| 471 DEFUN ("font-instance-width", Ffont_instance_width, 1, 1, 0, /* | |
| 472 Return the width in pixels of FONT-INSTANCE. | |
| 473 The returned value is the average width for all characters in the font. | |
| 474 */ | |
| 475 (font_instance)) | |
| 476 { | |
| 477 CHECK_FONT_INSTANCE (font_instance); | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
478 return make_fixnum (XFONT_INSTANCE (font_instance)->width); |
| 428 | 479 } |
| 480 | |
| 481 DEFUN ("font-instance-proportional-p", Ffont_instance_proportional_p, 1, 1, 0, /* | |
| 482 Return whether FONT-INSTANCE is proportional. | |
| 483 This means that different characters in the font have different widths. | |
| 484 */ | |
| 485 (font_instance)) | |
| 486 { | |
| 487 CHECK_FONT_INSTANCE (font_instance); | |
| 488 return XFONT_INSTANCE (font_instance)->proportional_p ? Qt : Qnil; | |
| 489 } | |
| 490 | |
| 491 static Lisp_Object | |
| 492 font_instance_truename_internal (Lisp_Object font_instance, | |
| 578 | 493 Error_Behavior errb) |
| 428 | 494 { |
| 440 | 495 Lisp_Font_Instance *f = XFONT_INSTANCE (font_instance); |
| 496 | |
| 428 | 497 if (NILP (f->device)) |
| 498 { | |
|
4757
a23ac8f90a49
Improve warning and error messages from Xft.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4426
diff
changeset
|
499 maybe_signal_error (Qgui_error, |
|
a23ac8f90a49
Improve warning and error messages from Xft.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4426
diff
changeset
|
500 "can't determine truename: " |
|
a23ac8f90a49
Improve warning and error messages from Xft.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4426
diff
changeset
|
501 "no device for font instance", |
|
a23ac8f90a49
Improve warning and error messages from Xft.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4426
diff
changeset
|
502 font_instance, Qfont, errb); |
| 428 | 503 return Qnil; |
| 504 } | |
| 440 | 505 |
| 428 | 506 return DEVMETH_OR_GIVEN (XDEVICE (f->device), |
| 507 font_instance_truename, (f, errb), f->name); | |
| 508 } | |
| 509 | |
| 510 DEFUN ("font-instance-truename", Ffont_instance_truename, 1, 1, 0, /* | |
| 511 Return the canonical name of FONT-INSTANCE. | |
| 512 Font names are patterns which may match any number of fonts, of which | |
| 513 the first found is used. This returns an unambiguous name for that font | |
| 514 \(but not necessarily its only unambiguous name). | |
| 515 */ | |
| 516 (font_instance)) | |
| 517 { | |
| 518 CHECK_FONT_INSTANCE (font_instance); | |
| 519 return font_instance_truename_internal (font_instance, ERROR_ME); | |
| 520 } | |
| 521 | |
| 3094 | 522 DEFUN ("font-instance-charset", Ffont_instance_charset, 1, 1, 0, /* |
| 523 Return the Mule charset that FONT-INSTANCE was allocated to handle. | |
| 524 */ | |
| 525 (font_instance)) | |
| 526 { | |
| 527 CHECK_FONT_INSTANCE (font_instance); | |
| 528 return XFONT_INSTANCE (font_instance)->charset; | |
| 529 } | |
| 530 | |
| 428 | 531 DEFUN ("font-instance-properties", Ffont_instance_properties, 1, 1, 0, /* |
| 532 Return the properties (an alist or nil) of FONT-INSTANCE. | |
| 533 */ | |
| 534 (font_instance)) | |
| 535 { | |
| 440 | 536 Lisp_Font_Instance *f; |
| 428 | 537 |
| 538 CHECK_FONT_INSTANCE (font_instance); | |
| 539 f = XFONT_INSTANCE (font_instance); | |
| 540 | |
| 541 if (NILP (f->device)) | |
| 542 return Qnil; | |
| 543 | |
| 544 return MAYBE_LISP_DEVMETH (XDEVICE (f->device), | |
| 545 font_instance_properties, (f)); | |
| 546 } | |
| 547 | |
| 2527 | 548 DEFUN ("font-list", Ffont_list, 1, 3, 0, /* |
| 428 | 549 Return a list of font names matching the given pattern. |
| 550 DEVICE specifies which device to search for names, and defaults to the | |
| 551 currently selected device. | |
| 552 */ | |
| 1701 | 553 (pattern, device, maxnumber)) |
| 428 | 554 { |
| 555 CHECK_STRING (pattern); | |
| 793 | 556 device = wrap_device (decode_device (device)); |
| 428 | 557 |
| 2527 | 558 return MAYBE_LISP_DEVMETH (XDEVICE (device), font_list, (pattern, device, |
| 1701 | 559 maxnumber)); |
| 428 | 560 } |
| 561 | |
| 562 | |
| 563 /**************************************************************************** | |
| 564 Color Object | |
| 565 ***************************************************************************/ | |
| 1204 | 566 |
| 567 static const struct memory_description color_specifier_description[] = { | |
| 568 { XD_LISP_OBJECT, offsetof (struct color_specifier, face) }, | |
| 569 { XD_LISP_OBJECT, offsetof (struct color_specifier, face_property) }, | |
| 570 { XD_END } | |
| 571 }; | |
| 572 | |
| 573 DEFINE_SPECIFIER_TYPE_WITH_DATA (color); | |
| 428 | 574 /* Qcolor defined in general.c */ |
| 575 | |
| 576 static void | |
| 577 color_create (Lisp_Object obj) | |
| 578 { | |
| 440 | 579 Lisp_Specifier *color = XCOLOR_SPECIFIER (obj); |
| 428 | 580 |
| 581 COLOR_SPECIFIER_FACE (color) = Qnil; | |
| 582 COLOR_SPECIFIER_FACE_PROPERTY (color) = Qnil; | |
| 583 } | |
| 584 | |
| 585 static void | |
| 586 color_mark (Lisp_Object obj) | |
| 587 { | |
| 440 | 588 Lisp_Specifier *color = XCOLOR_SPECIFIER (obj); |
| 428 | 589 |
| 590 mark_object (COLOR_SPECIFIER_FACE (color)); | |
| 591 mark_object (COLOR_SPECIFIER_FACE_PROPERTY (color)); | |
| 592 } | |
| 593 | |
| 594 /* No equal or hash methods; ignore the face the color is based off | |
| 595 of for `equal' */ | |
| 596 | |
| 597 static Lisp_Object | |
| 2286 | 598 color_instantiate (Lisp_Object specifier, Lisp_Object UNUSED (matchspec), |
| 428 | 599 Lisp_Object domain, Lisp_Object instantiator, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
600 Lisp_Object depth, int no_fallback) |
| 428 | 601 { |
| 602 /* When called, we're inside of call_with_suspended_errors(), | |
| 603 so we can freely error. */ | |
| 442 | 604 Lisp_Object device = DOMAIN_DEVICE (domain); |
| 428 | 605 struct device *d = XDEVICE (device); |
| 606 | |
| 607 if (COLOR_INSTANCEP (instantiator)) | |
| 608 { | |
| 609 /* 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
|
610 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
|
611 STRINGP case deal with it. */ |
| 428 | 612 if (NILP (device) /* Vthe_null_color_instance */ |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
613 || EQ (device, XCOLOR_INSTANCE (instantiator)->device)) |
| 428 | 614 return instantiator; |
| 615 else | |
| 616 instantiator = Fcolor_instance_name (instantiator); | |
| 617 } | |
| 618 | |
| 619 if (STRINGP (instantiator)) | |
| 620 { | |
| 621 /* First, look to see if we can retrieve a cached value. */ | |
| 622 Lisp_Object instance = | |
| 623 Fgethash (instantiator, d->color_instance_cache, Qunbound); | |
| 624 /* Otherwise, make a new one. */ | |
| 625 if (UNBOUNDP (instance)) | |
| 626 { | |
| 627 /* make sure we cache the failures, too. */ | |
| 628 instance = Fmake_color_instance (instantiator, device, Qt); | |
| 629 Fputhash (instantiator, instance, d->color_instance_cache); | |
| 630 } | |
| 631 | |
| 632 return NILP (instance) ? Qunbound : instance; | |
| 633 } | |
| 634 else if (VECTORP (instantiator)) | |
| 635 { | |
| 636 switch (XVECTOR_LENGTH (instantiator)) | |
| 637 { | |
| 638 case 0: | |
| 639 if (DEVICE_TTY_P (d)) | |
| 640 return Vthe_null_color_instance; | |
| 641 else | |
| 563 | 642 gui_error ("Color instantiator [] only valid on TTY's", |
| 428 | 643 device); |
| 644 | |
| 645 case 1: | |
| 646 if (NILP (COLOR_SPECIFIER_FACE (XCOLOR_SPECIFIER (specifier)))) | |
| 563 | 647 gui_error ("Color specifier not attached to a face", |
| 428 | 648 instantiator); |
| 649 return (FACE_PROPERTY_INSTANCE_1 | |
| 650 (Fget_face (XVECTOR_DATA (instantiator)[0]), | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
651 COLOR_SPECIFIER_FACE_PROPERTY |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
652 (XCOLOR_SPECIFIER (specifier)), |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
653 domain, ERROR_ME, no_fallback, depth)); |
| 428 | 654 |
| 655 case 2: | |
| 656 return (FACE_PROPERTY_INSTANCE_1 | |
| 657 (Fget_face (XVECTOR_DATA (instantiator)[0]), | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
658 XVECTOR_DATA (instantiator)[1], domain, ERROR_ME, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
659 no_fallback, depth)); |
| 428 | 660 |
| 661 default: | |
| 2500 | 662 ABORT (); |
| 428 | 663 } |
| 664 } | |
| 665 else if (NILP (instantiator)) | |
| 666 { | |
| 667 if (DEVICE_TTY_P (d)) | |
| 668 return Vthe_null_color_instance; | |
| 669 else | |
| 563 | 670 gui_error ("Color instantiator [] only valid on TTY's", |
| 428 | 671 device); |
| 672 } | |
| 673 else | |
| 2500 | 674 ABORT (); /* The spec validation routines are screwed up. */ |
| 428 | 675 |
| 676 return Qunbound; | |
| 677 } | |
| 678 | |
| 679 static void | |
| 680 color_validate (Lisp_Object instantiator) | |
| 681 { | |
| 682 if (COLOR_INSTANCEP (instantiator) || STRINGP (instantiator)) | |
| 683 return; | |
| 684 if (VECTORP (instantiator)) | |
| 685 { | |
| 686 if (XVECTOR_LENGTH (instantiator) > 2) | |
| 563 | 687 sferror ("Inheritance vector must be of size 0 - 2", |
| 428 | 688 instantiator); |
| 689 else if (XVECTOR_LENGTH (instantiator) > 0) | |
| 690 { | |
| 691 Lisp_Object face = XVECTOR_DATA (instantiator)[0]; | |
| 692 | |
| 693 Fget_face (face); | |
| 694 if (XVECTOR_LENGTH (instantiator) == 2) | |
| 695 { | |
| 696 Lisp_Object field = XVECTOR_DATA (instantiator)[1]; | |
|
5624
c39052c921b5
New "foreback" face property.
Didier Verna <didier@xemacs.org>
parents:
5619
diff
changeset
|
697 if (!EQ (field, Qforeground) |
|
c39052c921b5
New "foreback" face property.
Didier Verna <didier@xemacs.org>
parents:
5619
diff
changeset
|
698 && !EQ (field, Qforeback) |
|
c39052c921b5
New "foreback" face property.
Didier Verna <didier@xemacs.org>
parents:
5619
diff
changeset
|
699 && !EQ (field, Qbackground)) |
| 563 | 700 invalid_constant |
|
5624
c39052c921b5
New "foreback" face property.
Didier Verna <didier@xemacs.org>
parents:
5619
diff
changeset
|
701 ("Inheritance field must be `foreground', `foreback' or `background'", |
|
c39052c921b5
New "foreback" face property.
Didier Verna <didier@xemacs.org>
parents:
5619
diff
changeset
|
702 field); |
| 428 | 703 } |
| 704 } | |
| 705 } | |
| 706 else | |
| 563 | 707 invalid_argument ("Invalid color instantiator", instantiator); |
| 428 | 708 } |
| 709 | |
| 710 static void | |
| 711 color_after_change (Lisp_Object specifier, Lisp_Object locale) | |
| 712 { | |
| 713 Lisp_Object face = COLOR_SPECIFIER_FACE (XCOLOR_SPECIFIER (specifier)); | |
| 714 Lisp_Object property = | |
| 715 COLOR_SPECIFIER_FACE_PROPERTY (XCOLOR_SPECIFIER (specifier)); | |
| 716 if (!NILP (face)) | |
| 448 | 717 { |
| 718 face_property_was_changed (face, property, locale); | |
| 719 if (BUFFERP (locale)) | |
| 720 XBUFFER (locale)->buffer_local_face_property = 1; | |
| 721 } | |
| 428 | 722 } |
| 723 | |
| 724 void | |
| 725 set_color_attached_to (Lisp_Object obj, Lisp_Object face, Lisp_Object property) | |
| 726 { | |
| 440 | 727 Lisp_Specifier *color = XCOLOR_SPECIFIER (obj); |
| 428 | 728 |
| 729 COLOR_SPECIFIER_FACE (color) = face; | |
| 730 COLOR_SPECIFIER_FACE_PROPERTY (color) = property; | |
| 731 } | |
| 732 | |
| 733 DEFUN ("color-specifier-p", Fcolor_specifier_p, 1, 1, 0, /* | |
| 734 Return t if OBJECT is a color specifier. | |
| 735 | |
| 442 | 736 See `make-color-specifier' for a description of possible color instantiators. |
| 428 | 737 */ |
| 738 (object)) | |
| 739 { | |
| 740 return COLOR_SPECIFIERP (object) ? Qt : Qnil; | |
| 741 } | |
| 742 | |
| 743 | |
| 744 /**************************************************************************** | |
| 745 Font Object | |
| 746 ***************************************************************************/ | |
| 1204 | 747 |
| 748 static const struct memory_description font_specifier_description[] = { | |
| 749 { XD_LISP_OBJECT, offsetof (struct font_specifier, face) }, | |
| 750 { XD_LISP_OBJECT, offsetof (struct font_specifier, face_property) }, | |
| 751 { XD_END } | |
| 752 }; | |
| 753 | |
| 754 DEFINE_SPECIFIER_TYPE_WITH_DATA (font); | |
| 428 | 755 /* Qfont defined in general.c */ |
| 756 | |
| 757 static void | |
| 758 font_create (Lisp_Object obj) | |
| 759 { | |
| 440 | 760 Lisp_Specifier *font = XFONT_SPECIFIER (obj); |
| 428 | 761 |
| 762 FONT_SPECIFIER_FACE (font) = Qnil; | |
| 763 FONT_SPECIFIER_FACE_PROPERTY (font) = Qnil; | |
| 764 } | |
| 765 | |
| 766 static void | |
| 767 font_mark (Lisp_Object obj) | |
| 768 { | |
| 440 | 769 Lisp_Specifier *font = XFONT_SPECIFIER (obj); |
| 428 | 770 |
| 771 mark_object (FONT_SPECIFIER_FACE (font)); | |
| 772 mark_object (FONT_SPECIFIER_FACE_PROPERTY (font)); | |
| 773 } | |
| 774 | |
| 775 /* No equal or hash methods; ignore the face the font is based off | |
| 776 of for `equal' */ | |
| 777 | |
| 778 #ifdef MULE | |
| 779 | |
| 872 | 780 /* Given a truename font spec (i.e. the font spec should have its registry |
| 781 field filled in), does it support displaying characters from CHARSET? */ | |
| 782 | |
| 783 static int | |
| 428 | 784 font_spec_matches_charset (struct device *d, Lisp_Object charset, |
| 867 | 785 const Ibyte *nonreloc, Lisp_Object reloc, |
| 872 | 786 Bytecount offset, Bytecount length, |
| 3659 | 787 enum font_specifier_matchspec_stages stage) |
| 428 | 788 { |
| 789 return DEVMETH_OR_GIVEN (d, font_spec_matches_charset, | |
| 872 | 790 (d, charset, nonreloc, reloc, offset, length, |
| 791 stage), | |
| 428 | 792 1); |
| 793 } | |
| 794 | |
| 795 static void | |
| 796 font_validate_matchspec (Lisp_Object matchspec) | |
| 797 { | |
| 872 | 798 CHECK_CONS (matchspec); |
| 799 Fget_charset (XCAR (matchspec)); | |
| 3659 | 800 |
| 801 do | |
| 802 { | |
| 803 if (EQ(XCDR(matchspec), Qinitial)) | |
| 804 { | |
| 805 break; | |
| 806 } | |
| 807 if (EQ(XCDR(matchspec), Qfinal)) | |
| 808 { | |
| 809 break; | |
| 810 } | |
| 811 | |
| 812 invalid_argument("Invalid font matchspec stage", | |
| 813 XCDR(matchspec)); | |
| 814 } while (0); | |
| 428 | 815 } |
| 816 | |
| 872 | 817 void |
| 818 initialize_charset_font_caches (struct device *d) | |
| 819 { | |
| 820 /* Note that the following tables are bi-level. */ | |
| 821 d->charset_font_cache_stage_1 = | |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5178
diff
changeset
|
822 make_lisp_hash_table (20, HASH_TABLE_NON_WEAK, Qeq); |
| 872 | 823 d->charset_font_cache_stage_2 = |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5178
diff
changeset
|
824 make_lisp_hash_table (20, HASH_TABLE_NON_WEAK, Qeq); |
| 872 | 825 } |
| 826 | |
| 827 void | |
| 828 invalidate_charset_font_caches (Lisp_Object charset) | |
| 829 { | |
| 830 /* Invalidate font cache entries for charset on all devices. */ | |
| 831 Lisp_Object devcons, concons, hash_table; | |
| 832 DEVICE_LOOP_NO_BREAK (devcons, concons) | |
| 833 { | |
| 834 struct device *d = XDEVICE (XCAR (devcons)); | |
| 835 hash_table = Fgethash (charset, d->charset_font_cache_stage_1, | |
| 836 Qunbound); | |
| 837 if (!UNBOUNDP (hash_table)) | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
838 Fclrhash (hash_table); |
| 872 | 839 hash_table = Fgethash (charset, d->charset_font_cache_stage_2, |
| 840 Qunbound); | |
| 841 if (!UNBOUNDP (hash_table)) | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
842 Fclrhash (hash_table); |
| 872 | 843 } |
| 844 } | |
| 428 | 845 |
| 874 | 846 #endif /* MULE */ |
| 847 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
848 /* It's a little non-obvious what's going on here. Specifically: |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
849 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
850 MATCHSPEC is a somewhat bogus way in the specifier mechanism of passing |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
851 in additional information needed to instantiate some object. For fonts, |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
852 it's a cons of (CHARSET . SECOND-STAGE-P). SECOND-STAGE-P, if set, |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
853 means "try harder to find an appropriate font" and is a very bogus way |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
854 of dealing with the fact that it may not be possible to may a charset |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
855 directly onto a font; it's used esp. under Windows. @@#### We need to |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
856 change this so that MATCHSPEC is just a character. |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
857 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
858 When redisplay is building up its structure, and needs font info, it |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
859 calls functions in faces.c such as ensure_face_cachel_complete() (map |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
860 fonts needed for a string of text) or |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
861 ensure_face_cachel_contains_charset() (map fonts needed for a charset |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
862 derived from a single character). The former function calls the latter; |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
863 the latter calls face_property_matching_instance(); this constructs the |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
864 MATCHSPEC and calls specifier_instance_no_quit() twice (first stage and |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
865 second stage, updating MATCHSPEC appropriately). That function, in |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
866 turn, looks up the appropriate specifier method to do the instantiation, |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
867 which, lo and behold, is this function here (because we set it in |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
868 initialization using `SPECIFIER_HAS_METHOD (font, instantiate);'). We |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
869 in turn call the device method `find_charset_font', which maps to |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
870 mswindows_find_charset_font(), x_find_charset_font(), or similar, in |
|
5176
8b2f75cecb89
rename objects* (.c, .h and .el files) to fontcolor*
Ben Wing <ben@xemacs.org>
parents:
5015
diff
changeset
|
871 fontcolor-msw.c or the like. |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
872 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
873 --ben */ |
| 874 | 874 |
| 428 | 875 static Lisp_Object |
| 2333 | 876 font_instantiate (Lisp_Object UNUSED (specifier), |
| 877 Lisp_Object USED_IF_MULE (matchspec), | |
| 428 | 878 Lisp_Object domain, Lisp_Object instantiator, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
879 Lisp_Object depth, int no_fallback) |
| 428 | 880 { |
| 881 /* When called, we're inside of call_with_suspended_errors(), | |
| 882 so we can freely error. */ | |
| 442 | 883 Lisp_Object device = DOMAIN_DEVICE (domain); |
| 428 | 884 struct device *d = XDEVICE (device); |
| 885 Lisp_Object instance; | |
| 872 | 886 Lisp_Object charset = Qnil; |
| 1204 | 887 #ifdef MULE |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
888 enum font_specifier_matchspec_stages stage = STAGE_INITIAL; |
| 428 | 889 |
| 890 if (!UNBOUNDP (matchspec)) | |
| 872 | 891 { |
| 892 charset = Fget_charset (XCAR (matchspec)); | |
| 3659 | 893 |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
894 #define FROB(new_stage, enumstage) \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
895 if (EQ(Q##new_stage, XCDR(matchspec))) \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
896 { \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
897 stage = enumstage; \ |
| 3659 | 898 } |
| 899 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
900 FROB (initial, STAGE_INITIAL) |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
901 else FROB (final, STAGE_FINAL) |
| 3659 | 902 else assert(0); |
| 903 | |
| 904 #undef FROB | |
| 905 | |
| 872 | 906 } |
| 428 | 907 #endif |
| 908 | |
| 909 if (FONT_INSTANCEP (instantiator)) | |
| 910 { | |
| 911 if (NILP (device) | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
912 || EQ (device, XFONT_INSTANCE (instantiator)->device)) |
| 428 | 913 { |
| 914 #ifdef MULE | |
| 872 | 915 if (font_spec_matches_charset (d, charset, 0, |
| 428 | 916 Ffont_instance_truename |
| 917 (instantiator), | |
| 872 | 918 0, -1, stage)) |
| 1204 | 919 #endif |
| 428 | 920 return instantiator; |
| 921 } | |
| 922 instantiator = Ffont_instance_name (instantiator); | |
| 923 } | |
| 924 | |
| 925 if (STRINGP (instantiator)) | |
| 926 { | |
| 874 | 927 #ifdef MULE |
| 3659 | 928 /* #### rename these caches. */ |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
929 Lisp_Object cache = stage == STAGE_FINAL ? |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
930 d->charset_font_cache_stage_2 : |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
931 d->charset_font_cache_stage_1; |
| 874 | 932 #else |
| 933 Lisp_Object cache = d->font_instance_cache; | |
| 934 #endif | |
| 872 | 935 |
| 428 | 936 #ifdef MULE |
| 872 | 937 if (!NILP (charset)) |
| 428 | 938 { |
| 939 /* The instantiator is a font spec that could match many | |
| 940 different fonts. We need to find one of those fonts | |
| 941 whose registry matches the registry of the charset in | |
| 942 MATCHSPEC. This is potentially a very slow operation, | |
| 943 as it involves doing an XListFonts() or equivalent to | |
| 944 iterate over all possible fonts, and a regexp match | |
| 945 on each one. So we cache the results. */ | |
| 946 Lisp_Object matching_font = Qunbound; | |
| 872 | 947 Lisp_Object hash_table = Fgethash (charset, cache, Qunbound); |
| 428 | 948 if (UNBOUNDP (hash_table)) |
| 949 { | |
| 950 /* need to make a sub hash table. */ | |
| 951 hash_table = make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, | |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5178
diff
changeset
|
952 Qequal); |
| 872 | 953 Fputhash (charset, hash_table, cache); |
| 428 | 954 } |
| 955 else | |
| 956 matching_font = Fgethash (instantiator, hash_table, Qunbound); | |
| 957 | |
| 958 if (UNBOUNDP (matching_font)) | |
| 959 { | |
| 960 /* make sure we cache the failures, too. */ | |
| 961 matching_font = | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
962 DEVMETH_OR_GIVEN (d, find_charset_font, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
963 (device, instantiator, charset, stage), |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
964 instantiator); |
| 428 | 965 Fputhash (instantiator, matching_font, hash_table); |
| 966 } | |
| 967 if (NILP (matching_font)) | |
| 968 return Qunbound; | |
| 969 instantiator = matching_font; | |
| 970 } | |
| 971 #endif /* MULE */ | |
| 972 | |
| 973 /* First, look to see if we can retrieve a cached value. */ | |
| 872 | 974 instance = Fgethash (instantiator, cache, Qunbound); |
| 428 | 975 /* Otherwise, make a new one. */ |
| 976 if (UNBOUNDP (instance)) | |
| 977 { | |
| 978 /* make sure we cache the failures, too. */ | |
| 3094 | 979 instance = Fmake_font_instance (instantiator, device, Qt, charset); |
| 872 | 980 Fputhash (instantiator, instance, cache); |
| 428 | 981 } |
| 982 | |
| 983 return NILP (instance) ? Qunbound : instance; | |
| 984 } | |
| 985 else if (VECTORP (instantiator)) | |
| 986 { | |
| 3659 | 987 Lisp_Object match_inst = Qunbound; |
| 428 | 988 assert (XVECTOR_LENGTH (instantiator) == 1); |
| 3659 | 989 |
| 990 match_inst = face_property_matching_instance | |
| 991 (Fget_face (XVECTOR_DATA (instantiator)[0]), Qfont, | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
992 charset, domain, ERROR_ME, no_fallback, depth, STAGE_INITIAL); |
| 3659 | 993 |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
994 if (UNBOUNDP(match_inst)) |
| 3659 | 995 { |
| 996 match_inst = face_property_matching_instance | |
| 997 (Fget_face (XVECTOR_DATA (instantiator)[0]), Qfont, | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
998 charset, domain, ERROR_ME, no_fallback, depth, STAGE_FINAL); |
| 3659 | 999 } |
| 1000 | |
| 1001 return match_inst; | |
| 1002 | |
| 428 | 1003 } |
| 1004 else if (NILP (instantiator)) | |
| 1005 return Qunbound; | |
| 1006 else | |
| 2500 | 1007 ABORT (); /* Eh? */ |
| 428 | 1008 |
| 1009 return Qunbound; | |
| 1010 } | |
| 1011 | |
| 1012 static void | |
| 1013 font_validate (Lisp_Object instantiator) | |
| 1014 { | |
| 1015 if (FONT_INSTANCEP (instantiator) || STRINGP (instantiator)) | |
| 1016 return; | |
| 1017 if (VECTORP (instantiator)) | |
| 1018 { | |
| 1019 if (XVECTOR_LENGTH (instantiator) != 1) | |
| 1020 { | |
| 563 | 1021 sferror |
| 428 | 1022 ("Vector length must be one for font inheritance", instantiator); |
| 1023 } | |
| 1024 Fget_face (XVECTOR_DATA (instantiator)[0]); | |
| 1025 } | |
| 1026 else | |
| 563 | 1027 invalid_argument ("Must be string, vector, or font-instance", |
| 428 | 1028 instantiator); |
| 1029 } | |
| 1030 | |
| 1031 static void | |
| 1032 font_after_change (Lisp_Object specifier, Lisp_Object locale) | |
| 1033 { | |
| 1034 Lisp_Object face = FONT_SPECIFIER_FACE (XFONT_SPECIFIER (specifier)); | |
| 1035 Lisp_Object property = | |
| 1036 FONT_SPECIFIER_FACE_PROPERTY (XFONT_SPECIFIER (specifier)); | |
| 1037 if (!NILP (face)) | |
| 448 | 1038 { |
| 1039 face_property_was_changed (face, property, locale); | |
| 1040 if (BUFFERP (locale)) | |
| 1041 XBUFFER (locale)->buffer_local_face_property = 1; | |
| 1042 } | |
| 428 | 1043 } |
| 1044 | |
| 1045 void | |
| 1046 set_font_attached_to (Lisp_Object obj, Lisp_Object face, Lisp_Object property) | |
| 1047 { | |
| 440 | 1048 Lisp_Specifier *font = XFONT_SPECIFIER (obj); |
| 428 | 1049 |
| 1050 FONT_SPECIFIER_FACE (font) = face; | |
| 1051 FONT_SPECIFIER_FACE_PROPERTY (font) = property; | |
| 1052 } | |
| 1053 | |
| 1054 DEFUN ("font-specifier-p", Ffont_specifier_p, 1, 1, 0, /* | |
| 1055 Return non-nil if OBJECT is a font specifier. | |
| 1056 | |
| 442 | 1057 See `make-font-specifier' for a description of possible font instantiators. |
| 428 | 1058 */ |
| 1059 (object)) | |
| 1060 { | |
| 1061 return FONT_SPECIFIERP (object) ? Qt : Qnil; | |
| 1062 } | |
| 1063 | |
| 1064 | |
| 1065 /***************************************************************************** | |
| 1066 Face Boolean Object | |
| 1067 ****************************************************************************/ | |
| 1204 | 1068 |
| 1069 static const struct memory_description face_boolean_specifier_description[] = { | |
| 1070 { XD_LISP_OBJECT, offsetof (struct face_boolean_specifier, face) }, | |
| 1071 { XD_LISP_OBJECT, offsetof (struct face_boolean_specifier, face_property) }, | |
| 1072 { XD_END } | |
| 1073 }; | |
| 1074 | |
| 1075 DEFINE_SPECIFIER_TYPE_WITH_DATA (face_boolean); | |
| 428 | 1076 Lisp_Object Qface_boolean; |
| 1077 | |
| 1078 static void | |
| 1079 face_boolean_create (Lisp_Object obj) | |
| 1080 { | |
| 440 | 1081 Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj); |
| 428 | 1082 |
| 1083 FACE_BOOLEAN_SPECIFIER_FACE (face_boolean) = Qnil; | |
| 1084 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean) = Qnil; | |
| 1085 } | |
| 1086 | |
| 1087 static void | |
| 1088 face_boolean_mark (Lisp_Object obj) | |
| 1089 { | |
| 440 | 1090 Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj); |
| 428 | 1091 |
| 1092 mark_object (FACE_BOOLEAN_SPECIFIER_FACE (face_boolean)); | |
| 1093 mark_object (FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean)); | |
| 1094 } | |
| 1095 | |
| 1096 /* No equal or hash methods; ignore the face the face-boolean is based off | |
| 1097 of for `equal' */ | |
| 1098 | |
| 1099 static Lisp_Object | |
| 2286 | 1100 face_boolean_instantiate (Lisp_Object specifier, |
| 1101 Lisp_Object UNUSED (matchspec), | |
| 428 | 1102 Lisp_Object domain, Lisp_Object instantiator, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
1103 Lisp_Object depth, int no_fallback) |
| 428 | 1104 { |
| 1105 /* When called, we're inside of call_with_suspended_errors(), | |
| 1106 so we can freely error. */ | |
| 1107 if (NILP (instantiator) || EQ (instantiator, Qt)) | |
| 1108 return instantiator; | |
| 1109 else if (VECTORP (instantiator)) | |
| 1110 { | |
| 1111 Lisp_Object retval; | |
| 1112 Lisp_Object prop; | |
| 1113 int instantiator_len = XVECTOR_LENGTH (instantiator); | |
| 1114 | |
| 1115 assert (instantiator_len >= 1 && instantiator_len <= 3); | |
| 1116 if (instantiator_len > 1) | |
| 1117 prop = XVECTOR_DATA (instantiator)[1]; | |
| 1118 else | |
| 1119 { | |
| 1120 if (NILP (FACE_BOOLEAN_SPECIFIER_FACE | |
| 1121 (XFACE_BOOLEAN_SPECIFIER (specifier)))) | |
| 563 | 1122 gui_error |
| 428 | 1123 ("Face-boolean specifier not attached to a face", instantiator); |
| 1124 prop = FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY | |
| 1125 (XFACE_BOOLEAN_SPECIFIER (specifier)); | |
| 1126 } | |
| 1127 | |
| 1128 retval = (FACE_PROPERTY_INSTANCE_1 | |
| 1129 (Fget_face (XVECTOR_DATA (instantiator)[0]), | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
1130 prop, domain, ERROR_ME, no_fallback, depth)); |
| 428 | 1131 |
| 1132 if (instantiator_len == 3 && !NILP (XVECTOR_DATA (instantiator)[2])) | |
| 1133 retval = NILP (retval) ? Qt : Qnil; | |
| 1134 | |
| 1135 return retval; | |
| 1136 } | |
| 1137 else | |
| 2500 | 1138 ABORT (); /* Eh? */ |
| 428 | 1139 |
| 1140 return Qunbound; | |
| 1141 } | |
| 1142 | |
| 1143 static void | |
| 1144 face_boolean_validate (Lisp_Object instantiator) | |
| 1145 { | |
| 1146 if (NILP (instantiator) || EQ (instantiator, Qt)) | |
| 1147 return; | |
| 1148 else if (VECTORP (instantiator) && | |
| 1149 (XVECTOR_LENGTH (instantiator) >= 1 && | |
| 1150 XVECTOR_LENGTH (instantiator) <= 3)) | |
| 1151 { | |
| 1152 Lisp_Object face = XVECTOR_DATA (instantiator)[0]; | |
| 1153 | |
| 1154 Fget_face (face); | |
| 1155 | |
| 1156 if (XVECTOR_LENGTH (instantiator) > 1) | |
| 1157 { | |
| 1158 Lisp_Object field = XVECTOR_DATA (instantiator)[1]; | |
| 1159 if (!EQ (field, Qunderline) | |
| 1160 && !EQ (field, Qstrikethru) | |
| 1161 && !EQ (field, Qhighlight) | |
| 1162 && !EQ (field, Qdim) | |
| 1163 && !EQ (field, Qblinking) | |
|
5617
b0d712bbc2a6
The "flush" face property.
Didier Verna <didier@xemacs.org>
parents:
5581
diff
changeset
|
1164 && !EQ (field, Qreverse) |
|
5619
75ad4969a16d
Replace the 'flush face property with the opposite 'shrink one.
Didier Verna <didier@xemacs.org>
parents:
5617
diff
changeset
|
1165 && !EQ (field, Qshrink)) |
| 563 | 1166 invalid_constant ("Invalid face-boolean inheritance field", |
|
5619
75ad4969a16d
Replace the 'flush face property with the opposite 'shrink one.
Didier Verna <didier@xemacs.org>
parents:
5617
diff
changeset
|
1167 field); |
| 428 | 1168 } |
| 1169 } | |
| 1170 else if (VECTORP (instantiator)) | |
| 563 | 1171 sferror ("Wrong length for face-boolean inheritance spec", |
| 428 | 1172 instantiator); |
| 1173 else | |
| 563 | 1174 invalid_argument ("Face-boolean instantiator must be nil, t, or vector", |
| 428 | 1175 instantiator); |
| 1176 } | |
| 1177 | |
| 1178 static void | |
| 1179 face_boolean_after_change (Lisp_Object specifier, Lisp_Object locale) | |
| 1180 { | |
| 1181 Lisp_Object face = | |
| 1182 FACE_BOOLEAN_SPECIFIER_FACE (XFACE_BOOLEAN_SPECIFIER (specifier)); | |
| 1183 Lisp_Object property = | |
| 1184 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (XFACE_BOOLEAN_SPECIFIER (specifier)); | |
| 1185 if (!NILP (face)) | |
| 448 | 1186 { |
| 1187 face_property_was_changed (face, property, locale); | |
| 1188 if (BUFFERP (locale)) | |
| 1189 XBUFFER (locale)->buffer_local_face_property = 1; | |
| 1190 } | |
| 428 | 1191 } |
| 1192 | |
| 1193 void | |
| 1194 set_face_boolean_attached_to (Lisp_Object obj, Lisp_Object face, | |
| 1195 Lisp_Object property) | |
| 1196 { | |
| 440 | 1197 Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj); |
| 428 | 1198 |
| 1199 FACE_BOOLEAN_SPECIFIER_FACE (face_boolean) = face; | |
| 1200 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean) = property; | |
| 1201 } | |
| 1202 | |
| 1203 DEFUN ("face-boolean-specifier-p", Fface_boolean_specifier_p, 1, 1, 0, /* | |
| 1204 Return non-nil if OBJECT is a face-boolean specifier. | |
| 1205 | |
| 442 | 1206 See `make-face-boolean-specifier' for a description of possible |
| 1207 face-boolean instantiators. | |
| 428 | 1208 */ |
| 1209 (object)) | |
| 1210 { | |
| 1211 return FACE_BOOLEAN_SPECIFIERP (object) ? Qt : Qnil; | |
| 1212 } | |
| 1213 | |
| 1214 | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1215 /***************************************************************************** |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1216 Face Background Placement Object |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1217 ****************************************************************************/ |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1218 Lisp_Object Qabsolute, Qrelative; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1219 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1220 static const struct memory_description |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1221 face_background_placement_specifier_description[] = { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1222 { XD_LISP_OBJECT, offsetof (struct face_background_placement_specifier, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1223 face) }, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1224 { XD_END } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1225 }; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1226 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1227 DEFINE_SPECIFIER_TYPE_WITH_DATA (face_background_placement); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1228 Lisp_Object Qface_background_placement; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1229 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1230 static void |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1231 face_background_placement_create (Lisp_Object obj) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1232 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1233 Lisp_Specifier *face_background_placement |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1234 = XFACE_BACKGROUND_PLACEMENT_SPECIFIER (obj); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1235 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1236 FACE_BACKGROUND_PLACEMENT_SPECIFIER_FACE (face_background_placement) = Qnil; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1237 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1238 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1239 static void |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1240 face_background_placement_mark (Lisp_Object obj) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1241 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1242 Lisp_Specifier *face_background_placement |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1243 = XFACE_BACKGROUND_PLACEMENT_SPECIFIER (obj); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1244 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1245 mark_object |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1246 (FACE_BACKGROUND_PLACEMENT_SPECIFIER_FACE (face_background_placement)); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1247 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1248 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1249 /* No equal or hash methods; ignore the face the background-placement is based |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1250 off of for `equal' */ |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1251 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1252 extern Lisp_Object Qbackground_placement; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1253 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1254 static Lisp_Object |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1255 face_background_placement_instantiate (Lisp_Object UNUSED (specifier), |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1256 Lisp_Object UNUSED (matchspec), |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1257 Lisp_Object domain, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1258 Lisp_Object instantiator, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1259 Lisp_Object depth, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1260 int no_fallback) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1261 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1262 /* When called, we're inside of call_with_suspended_errors(), |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1263 so we can freely error. */ |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1264 if (EQ (instantiator, Qabsolute) || EQ (instantiator, Qrelative)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1265 return instantiator; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1266 else if (VECTORP (instantiator)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1267 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1268 assert (XVECTOR_LENGTH (instantiator) == 1); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1269 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1270 return FACE_PROPERTY_INSTANCE_1 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1271 (Fget_face (XVECTOR_DATA (instantiator)[0]), |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1272 Qbackground_placement, domain, ERROR_ME, no_fallback, depth); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1273 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1274 else |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1275 ABORT (); /* Eh? */ |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1276 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1277 return Qunbound; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1278 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1279 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1280 static void |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1281 face_background_placement_validate (Lisp_Object instantiator) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1282 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1283 if (EQ (instantiator, Qabsolute) || EQ (instantiator, Qrelative)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1284 return; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1285 else if (VECTORP (instantiator) && |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1286 (XVECTOR_LENGTH (instantiator) == 1)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1287 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1288 Lisp_Object face = XVECTOR_DATA (instantiator)[0]; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1289 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1290 Fget_face (face); /* just to check that the face exists -- dvl */ |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1291 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1292 else if (VECTORP (instantiator)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1293 sferror ("Wrong length for background-placement inheritance spec", |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1294 instantiator); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1295 else |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1296 invalid_argument |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1297 ("\ |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1298 Background-placement instantiator must be absolute, relative or vector", |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1299 instantiator); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1300 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1301 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1302 static void |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1303 face_background_placement_after_change (Lisp_Object specifier, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1304 Lisp_Object locale) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1305 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1306 Lisp_Object face |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1307 = FACE_BACKGROUND_PLACEMENT_SPECIFIER_FACE |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1308 (XFACE_BACKGROUND_PLACEMENT_SPECIFIER (specifier)); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1309 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1310 if (!NILP (face)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1311 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1312 face_property_was_changed (face, Qbackground_placement, locale); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1313 if (BUFFERP (locale)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1314 XBUFFER (locale)->buffer_local_face_property = 1; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1315 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1316 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1317 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1318 void |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1319 set_face_background_placement_attached_to (Lisp_Object obj, Lisp_Object face) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1320 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1321 Lisp_Specifier *face_background_placement |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1322 = XFACE_BACKGROUND_PLACEMENT_SPECIFIER (obj); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1323 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1324 FACE_BACKGROUND_PLACEMENT_SPECIFIER_FACE (face_background_placement) = face; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1325 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1326 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1327 DEFUN ("face-background-placement-specifier-p", Fface_background_placement_specifier_p, 1, 1, 0, /* |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1328 Return non-nil if OBJECT is a face-background-placement specifier. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1329 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1330 See `make-face-background-placement-specifier' for a description of possible |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1331 face-background-placement instantiators. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1332 */ |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1333 (object)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1334 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1335 return FACE_BACKGROUND_PLACEMENT_SPECIFIERP (object) ? Qt : Qnil; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1336 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1337 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1338 |
| 428 | 1339 /************************************************************************/ |
| 1340 /* initialization */ | |
| 1341 /************************************************************************/ | |
| 1342 | |
| 1343 void | |
|
5176
8b2f75cecb89
rename objects* (.c, .h and .el files) to fontcolor*
Ben Wing <ben@xemacs.org>
parents:
5015
diff
changeset
|
1344 syms_of_fontcolor (void) |
| 428 | 1345 { |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1346 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
|
1347 INIT_LISP_OBJECT (font_instance); |
| 442 | 1348 |
| 428 | 1349 DEFSUBR (Fcolor_specifier_p); |
| 1350 DEFSUBR (Ffont_specifier_p); | |
| 1351 DEFSUBR (Fface_boolean_specifier_p); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1352 DEFSUBR (Fface_background_placement_specifier_p); |
| 428 | 1353 |
| 563 | 1354 DEFSYMBOL_MULTIWORD_PREDICATE (Qcolor_instancep); |
| 428 | 1355 DEFSUBR (Fmake_color_instance); |
| 1356 DEFSUBR (Fcolor_instance_p); | |
| 1357 DEFSUBR (Fcolor_instance_name); | |
| 1358 DEFSUBR (Fcolor_instance_rgb_components); | |
| 1359 DEFSUBR (Fvalid_color_name_p); | |
| 2527 | 1360 DEFSUBR (Fcolor_list); |
| 428 | 1361 |
| 563 | 1362 DEFSYMBOL_MULTIWORD_PREDICATE (Qfont_instancep); |
| 428 | 1363 DEFSUBR (Fmake_font_instance); |
| 1364 DEFSUBR (Ffont_instance_p); | |
| 1365 DEFSUBR (Ffont_instance_name); | |
| 1366 DEFSUBR (Ffont_instance_ascent); | |
| 1367 DEFSUBR (Ffont_instance_descent); | |
| 1368 DEFSUBR (Ffont_instance_width); | |
| 3094 | 1369 DEFSUBR (Ffont_instance_charset); |
| 428 | 1370 DEFSUBR (Ffont_instance_proportional_p); |
| 1371 DEFSUBR (Ffont_instance_truename); | |
| 1372 DEFSUBR (Ffont_instance_properties); | |
| 2527 | 1373 DEFSUBR (Ffont_list); |
| 428 | 1374 |
| 1375 /* Qcolor, Qfont defined in general.c */ | |
| 563 | 1376 DEFSYMBOL (Qface_boolean); |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1377 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1378 DEFSYMBOL (Qface_background_placement); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1379 DEFSYMBOL (Qabsolute); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1380 DEFSYMBOL (Qrelative); |
| 428 | 1381 } |
| 1382 | |
| 1383 void | |
|
5176
8b2f75cecb89
rename objects* (.c, .h and .el files) to fontcolor*
Ben Wing <ben@xemacs.org>
parents:
5015
diff
changeset
|
1384 specifier_type_create_fontcolor (void) |
| 428 | 1385 { |
| 1386 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (color, "color", "color-specifier-p"); | |
| 1387 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (font, "font", "font-specifier-p"); | |
| 1388 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (face_boolean, "face-boolean", | |
| 1389 "face-boolean-specifier-p"); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1390 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (face_background_placement, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1391 "face-background-placement", |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1392 "\ |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1393 face-background-placement-specifier-p"); |
| 428 | 1394 |
| 1395 SPECIFIER_HAS_METHOD (color, instantiate); | |
| 1396 SPECIFIER_HAS_METHOD (font, instantiate); | |
| 1397 SPECIFIER_HAS_METHOD (face_boolean, instantiate); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1398 SPECIFIER_HAS_METHOD (face_background_placement, instantiate); |
| 428 | 1399 |
| 1400 SPECIFIER_HAS_METHOD (color, validate); | |
| 1401 SPECIFIER_HAS_METHOD (font, validate); | |
| 1402 SPECIFIER_HAS_METHOD (face_boolean, validate); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1403 SPECIFIER_HAS_METHOD (face_background_placement, validate); |
| 428 | 1404 |
| 1405 SPECIFIER_HAS_METHOD (color, create); | |
| 1406 SPECIFIER_HAS_METHOD (font, create); | |
| 1407 SPECIFIER_HAS_METHOD (face_boolean, create); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1408 SPECIFIER_HAS_METHOD (face_background_placement, create); |
| 428 | 1409 |
| 1410 SPECIFIER_HAS_METHOD (color, mark); | |
| 1411 SPECIFIER_HAS_METHOD (font, mark); | |
| 1412 SPECIFIER_HAS_METHOD (face_boolean, mark); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1413 SPECIFIER_HAS_METHOD (face_background_placement, mark); |
| 428 | 1414 |
| 1415 SPECIFIER_HAS_METHOD (color, after_change); | |
| 1416 SPECIFIER_HAS_METHOD (font, after_change); | |
| 1417 SPECIFIER_HAS_METHOD (face_boolean, after_change); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1418 SPECIFIER_HAS_METHOD (face_background_placement, after_change); |
| 428 | 1419 |
| 1420 #ifdef MULE | |
| 1421 SPECIFIER_HAS_METHOD (font, validate_matchspec); | |
| 1422 #endif | |
| 1423 } | |
| 1424 | |
| 1425 void | |
|
5176
8b2f75cecb89
rename objects* (.c, .h and .el files) to fontcolor*
Ben Wing <ben@xemacs.org>
parents:
5015
diff
changeset
|
1426 reinit_specifier_type_create_fontcolor (void) |
| 428 | 1427 { |
| 1428 REINITIALIZE_SPECIFIER_TYPE (color); | |
| 1429 REINITIALIZE_SPECIFIER_TYPE (font); | |
| 1430 REINITIALIZE_SPECIFIER_TYPE (face_boolean); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1431 REINITIALIZE_SPECIFIER_TYPE (face_background_placement); |
| 428 | 1432 } |
| 1433 | |
| 1434 void | |
|
5176
8b2f75cecb89
rename objects* (.c, .h and .el files) to fontcolor*
Ben Wing <ben@xemacs.org>
parents:
5015
diff
changeset
|
1435 reinit_vars_of_fontcolor (void) |
| 428 | 1436 { |
| 1437 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
1438 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (color_instance); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1439 Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); |
| 428 | 1440 c->name = Qnil; |
| 1441 c->device = Qnil; | |
| 1442 c->data = 0; | |
| 1443 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1444 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
|
1445 staticpro_nodump (&Vthe_null_color_instance); |
| 428 | 1446 } |
| 1447 | |
| 1448 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
1449 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (font_instance); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1450 Lisp_Font_Instance *f = XFONT_INSTANCE (obj); |
| 428 | 1451 f->name = Qnil; |
| 872 | 1452 f->truename = Qnil; |
| 428 | 1453 f->device = Qnil; |
| 1454 f->data = 0; | |
| 1455 | |
| 1456 f->ascent = f->height = 0; | |
| 1457 f->descent = 0; | |
| 1458 f->width = 0; | |
| 1459 f->proportional_p = 0; | |
| 1460 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1461 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
|
1462 staticpro_nodump (&Vthe_null_font_instance); |
| 428 | 1463 } |
| 1464 } | |
| 1465 | |
| 1466 void | |
|
5176
8b2f75cecb89
rename objects* (.c, .h and .el files) to fontcolor*
Ben Wing <ben@xemacs.org>
parents:
5015
diff
changeset
|
1467 vars_of_fontcolor (void) |
| 428 | 1468 { |
| 1469 } |