1 /* Generic Objects and Functions.
2 Copyright (C) 1995 Free Software Foundation, Inc.
3 Copyright (C) 1995 Board of Trustees, University of Illinois.
4 Copyright (C) 1995, 1996 Ben Wing.
6 This file is part of SXEmacs
8 SXEmacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 SXEmacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program. If not, see <http://www.gnu.org/licenses/>. */
22 /* Synched up with: Not in FSF. */
27 #include "ui/device.h"
31 #include "ui/objects.h"
32 #include "specifier.h"
33 #include "ui/window.h"
35 /* Objects that are substituted when an instantiation fails.
36 If we leave in the Qunbound value, we will probably get crashes. */
37 Lisp_Object Vthe_null_color_instance, Vthe_null_font_instance;
39 /* Authors: Ben Wing, Chuck Thompson */
41 void finalose(void *ptr)
47 ("Can't dump an emacs containing window system objects", obj);
50 /****************************************************************************
51 * Color-Instance Object *
52 ****************************************************************************/
54 Lisp_Object Qcolor_instancep;
56 static Lisp_Object mark_color_instance(Lisp_Object obj)
58 Lisp_Color_Instance *c = XCOLOR_INSTANCE(obj);
60 if (!NILP(c->device)) /* Vthe_null_color_instance */
61 MAYBE_DEVMETH(XDEVICE(c->device), mark_color_instance, (c));
67 print_color_instance(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
70 Lisp_Color_Instance *c = XCOLOR_INSTANCE(obj);
72 error("printing unreadable object #<color-instance 0x%x>",
74 write_c_string("#<color-instance ", printcharfun);
75 print_internal(c->name, printcharfun, 0);
76 write_c_string(" on ", printcharfun);
77 print_internal(c->device, printcharfun, 0);
78 if (!NILP(c->device)) /* Vthe_null_color_instance */
79 MAYBE_DEVMETH(XDEVICE(c->device), print_color_instance,
80 (c, printcharfun, escapeflag));
81 sprintf(buf, " 0x%x>", c->header.uid);
82 write_c_string(buf, printcharfun);
85 static void finalize_color_instance(void *header, int for_disksave)
87 Lisp_Color_Instance *c = (Lisp_Color_Instance *) header;
89 if (!NILP(c->device)) {
92 MAYBE_DEVMETH(XDEVICE(c->device), finalize_color_instance, (c));
96 static int color_instance_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
98 Lisp_Color_Instance *c1 = XCOLOR_INSTANCE(obj1);
99 Lisp_Color_Instance *c2 = XCOLOR_INSTANCE(obj2);
102 (EQ(c1->device, c2->device) &&
103 DEVICEP(c1->device) &&
104 HAS_DEVMETH_P(XDEVICE(c1->device), color_instance_equal) &&
105 DEVMETH(XDEVICE(c1->device), color_instance_equal,
109 static unsigned long color_instance_hash(Lisp_Object obj, int depth)
111 Lisp_Color_Instance *c = XCOLOR_INSTANCE(obj);
112 struct device *d = DEVICEP(c->device) ? XDEVICE(c->device) : 0;
114 return HASH2((unsigned long)d, !d ? LISP_HASH(obj)
115 : DEVMETH_OR_GIVEN(d, color_instance_hash, (c, depth),
119 DEFINE_LRECORD_IMPLEMENTATION("color-instance", color_instance,
120 mark_color_instance, print_color_instance,
121 finalize_color_instance, color_instance_equal,
122 color_instance_hash, 0, Lisp_Color_Instance);
124 DEFUN("make-color-instance", Fmake_color_instance, 1, 3, 0, /*
125 Return a new `color-instance' object named NAME (a string).
127 Optional argument DEVICE specifies the device this object applies to
128 and defaults to the selected device.
130 An error is signaled if the color is unknown or cannot be allocated;
131 however, if optional argument NOERROR is non-nil, nil is simply
132 returned in this case. (And if NOERROR is other than t, a warning may
135 The returned object is a normal, first-class lisp object. The way you
136 `deallocate' the color is the way you deallocate any other lisp object:
137 you drop all pointers to it and allow it to be garbage collected. When
138 these objects are GCed, the underlying window-system data (e.g. X object)
139 is deallocated as well.
141 (name, device, noerror))
143 Lisp_Color_Instance *c;
144 Lisp_Object val = Qnil;
145 Lisp_Object dev = Qnil;
147 int count = specpdl_depth();
148 struct gcpro gcpro1, gcpro2;
151 XSETDEVICE(dev, decode_device(device));
153 c = alloc_lcrecord_type(Lisp_Color_Instance, &lrecord_color_instance);
158 XSETCOLOR_INSTANCE(val, c);
160 retval = MAYBE_INT_DEVMETH(XDEVICE(dev), initialize_color_instance,
162 decode_error_behavior_flag(noerror)));
164 unbind_to(count, Qnil);
169 XSETCOLOR_INSTANCE(val, c);
170 unbind_to(count, Qnil);
175 DEFUN("color-instance-p", Fcolor_instance_p, 1, 1, 0, /*
176 Return non-nil if OBJECT is a color instance.
180 return COLOR_INSTANCEP(object) ? Qt : Qnil;
183 DEFUN("color-instance-name", Fcolor_instance_name, 1, 1, 0, /*
184 Return the name used to allocate COLOR-INSTANCE.
188 CHECK_COLOR_INSTANCE(color_instance);
189 return XCOLOR_INSTANCE(color_instance)->name;
192 DEFUN("color-instance-rgb-components", Fcolor_instance_rgb_components, 1, 1, 0, /*
193 Return a three element list containing the red, green, and blue
194 color components of COLOR-INSTANCE, or nil if unknown.
195 Component values range from 0 to 65535.
199 Lisp_Color_Instance *c;
201 CHECK_COLOR_INSTANCE(color_instance);
202 c = XCOLOR_INSTANCE(color_instance);
207 return MAYBE_LISP_DEVMETH(XDEVICE(c->device),
208 color_instance_rgb_components, (c));
211 DEFUN("valid-color-name-p", Fvalid_color_name_p, 1, 2, 0, /*
212 Return true if COLOR names a valid color for the current device.
214 Valid color names for X are listed in the file /usr/lib/X11/rgb.txt, or
215 whatever the equivalent is on your system.
217 Valid color names for TTY are those which have an ISO 6429 (ANSI) sequence.
218 In addition to being a color this may be one of a number of attributes
223 struct device *d = decode_device(device);
226 return MAYBE_INT_DEVMETH(d, valid_color_name_p, (d, color)) ? Qt : Qnil;
229 /***************************************************************************
230 * Font-Instance Object *
231 ***************************************************************************/
233 Lisp_Object Qfont_instancep;
235 static Lisp_Object font_instance_truename_internal(Lisp_Object xfont,
236 Error_behavior errb);
238 static Lisp_Object mark_font_instance(Lisp_Object obj)
240 Lisp_Font_Instance *f = XFONT_INSTANCE(obj);
242 mark_object(f->name);
243 if (!NILP(f->device)) /* Vthe_null_font_instance */
244 MAYBE_DEVMETH(XDEVICE(f->device), mark_font_instance, (f));
250 print_font_instance(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
253 Lisp_Font_Instance *f = XFONT_INSTANCE(obj);
255 error("printing unreadable object #<font-instance 0x%x>",
257 write_c_string("#<font-instance ", printcharfun);
258 print_internal(f->name, printcharfun, 1);
259 write_c_string(" on ", printcharfun);
260 print_internal(f->device, printcharfun, 0);
261 if (!NILP(f->device))
262 MAYBE_DEVMETH(XDEVICE(f->device), print_font_instance,
263 (f, printcharfun, escapeflag));
264 sprintf(buf, " 0x%x>", f->header.uid);
265 write_c_string(buf, printcharfun);
268 static void finalize_font_instance(void *header, int for_disksave)
270 Lisp_Font_Instance *f = (Lisp_Font_Instance *) header;
272 if (!NILP(f->device)) {
275 MAYBE_DEVMETH(XDEVICE(f->device), finalize_font_instance, (f));
279 /* Fonts are equal if they resolve to the same name.
280 Since we call `font-truename' to do this, and since font-truename is lazy,
281 this means the `equal' could cause XListFonts to be run the first time.
283 static int font_instance_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
285 /* #### should this be moved into a device method? */
287 internal_equal(font_instance_truename_internal(obj1, ERROR_ME_NOT),
288 font_instance_truename_internal(obj2, ERROR_ME_NOT),
292 static unsigned long font_instance_hash(Lisp_Object obj, int depth)
294 return internal_hash(font_instance_truename_internal(obj, ERROR_ME_NOT),
298 DEFINE_LRECORD_IMPLEMENTATION("font-instance", font_instance,
299 mark_font_instance, print_font_instance,
300 finalize_font_instance, font_instance_equal,
301 font_instance_hash, 0, Lisp_Font_Instance);
303 DEFUN("make-font-instance", Fmake_font_instance, 1, 3, 0, /*
304 Return a new `font-instance' object named NAME.
305 DEVICE specifies the device this object applies to and defaults to the
306 selected device. An error is signalled if the font is unknown or cannot
307 be allocated; however, if NOERROR is non-nil, nil is simply returned in
310 The returned object is a normal, first-class lisp object. The way you
311 `deallocate' the font is the way you deallocate any other lisp object:
312 you drop all pointers to it and allow it to be garbage collected. When
313 these objects are GCed, the underlying X data is deallocated as well.
315 (name, device, noerror))
317 Lisp_Font_Instance *f;
320 Error_behavior errb = decode_error_behavior_flag(noerror);
322 if (ERRB_EQ(errb, ERROR_ME))
324 else if (!STRINGP(name))
327 XSETDEVICE(device, decode_device(device));
329 f = alloc_lcrecord_type(Lisp_Font_Instance, &lrecord_font_instance);
335 /* Stick some default values here ... */
336 f->ascent = f->height = 1;
339 f->proportional_p = 0;
341 retval = MAYBE_INT_DEVMETH(XDEVICE(device), initialize_font_instance,
342 (f, name, device, errb));
347 XSETFONT_INSTANCE(val, f);
351 DEFUN("font-instance-p", Ffont_instance_p, 1, 1, 0, /*
352 Return non-nil if OBJECT is a font instance.
356 return FONT_INSTANCEP(object) ? Qt : Qnil;
359 DEFUN("font-instance-name", Ffont_instance_name, 1, 1, 0, /*
360 Return the name used to allocate FONT-INSTANCE.
364 CHECK_FONT_INSTANCE(font_instance);
365 return XFONT_INSTANCE(font_instance)->name;
368 DEFUN("font-instance-ascent", Ffont_instance_ascent, 1, 1, 0, /*
369 Return the ascent in pixels of FONT-INSTANCE.
370 The returned value is the maximum ascent for all characters in the font,
371 where a character's ascent is the number of pixels above (and including)
376 CHECK_FONT_INSTANCE(font_instance);
377 return make_int(XFONT_INSTANCE(font_instance)->ascent);
380 DEFUN("font-instance-descent", Ffont_instance_descent, 1, 1, 0, /*
381 Return the descent in pixels of FONT-INSTANCE.
382 The returned value is the maximum descent for all characters in the font,
383 where a character's descent is the number of pixels below the baseline.
384 \(Many characters to do not have any descent. Typical characters with a
385 descent are lowercase p and lowercase g.)
389 CHECK_FONT_INSTANCE(font_instance);
390 return make_int(XFONT_INSTANCE(font_instance)->descent);
393 DEFUN("font-instance-width", Ffont_instance_width, 1, 1, 0, /*
394 Return the width in pixels of FONT-INSTANCE.
395 The returned value is the average width for all characters in the font.
399 CHECK_FONT_INSTANCE(font_instance);
400 return make_int(XFONT_INSTANCE(font_instance)->width);
403 DEFUN("font-instance-proportional-p", Ffont_instance_proportional_p, 1, 1, 0, /*
404 Return whether FONT-INSTANCE is proportional.
405 This means that different characters in the font have different widths.
409 CHECK_FONT_INSTANCE(font_instance);
410 return XFONT_INSTANCE(font_instance)->proportional_p ? Qt : Qnil;
414 font_instance_truename_internal(Lisp_Object font_instance, Error_behavior errb)
416 Lisp_Font_Instance *f = XFONT_INSTANCE(font_instance);
418 if (NILP(f->device)) {
419 maybe_signal_simple_error("Couldn't determine font truename",
420 font_instance, Qfont, errb);
424 return DEVMETH_OR_GIVEN(XDEVICE(f->device),
425 font_instance_truename, (f, errb), f->name);
428 DEFUN("font-instance-truename", Ffont_instance_truename, 1, 1, 0, /*
429 Return the canonical name of FONT-INSTANCE.
430 Font names are patterns which may match any number of fonts, of which
431 the first found is used. This returns an unambiguous name for that font
432 \(but not necessarily its only unambiguous name).
436 CHECK_FONT_INSTANCE(font_instance);
437 return font_instance_truename_internal(font_instance, ERROR_ME);
440 DEFUN("font-instance-properties", Ffont_instance_properties, 1, 1, 0, /*
441 Return the properties (an alist or nil) of FONT-INSTANCE.
445 Lisp_Font_Instance *f;
447 CHECK_FONT_INSTANCE(font_instance);
448 f = XFONT_INSTANCE(font_instance);
453 return MAYBE_LISP_DEVMETH(XDEVICE(f->device),
454 font_instance_properties, (f));
457 DEFUN("list-fonts", Flist_fonts, 1, 2, 0, /*
458 Return a list of font names matching the given pattern.
459 DEVICE specifies which device to search for names, and defaults to the
460 currently selected device.
464 CHECK_STRING(pattern);
465 XSETDEVICE(device, decode_device(device));
467 return MAYBE_LISP_DEVMETH(XDEVICE(device), list_fonts,
471 /****************************************************************************
473 ***************************************************************************/
474 DEFINE_SPECIFIER_TYPE(color);
475 /* Qcolor defined in general.c */
477 static void color_create(Lisp_Object obj)
479 Lisp_Specifier *color = XCOLOR_SPECIFIER(obj);
481 COLOR_SPECIFIER_FACE(color) = Qnil;
482 COLOR_SPECIFIER_FACE_PROPERTY(color) = Qnil;
485 static void color_mark(Lisp_Object obj)
487 Lisp_Specifier *color = XCOLOR_SPECIFIER(obj);
489 mark_object(COLOR_SPECIFIER_FACE(color));
490 mark_object(COLOR_SPECIFIER_FACE_PROPERTY(color));
493 /* No equal or hash methods; ignore the face the color is based off
497 color_instantiate(Lisp_Object specifier, Lisp_Object matchspec,
498 Lisp_Object domain, Lisp_Object instantiator,
501 /* When called, we're inside of call_with_suspended_errors(),
502 so we can freely error. */
503 Lisp_Object device = DOMAIN_DEVICE(domain);
504 struct device *d = XDEVICE(device);
506 if (COLOR_INSTANCEP(instantiator)) {
507 /* If we are on the same device then we're done. Otherwise change
508 the instantiator to the name used to generate the pixel and let the
509 STRINGP case deal with it. */
510 if (NILP(device) /* Vthe_null_color_instance */
511 ||EQ(device, XCOLOR_INSTANCE(instantiator)->device))
514 instantiator = Fcolor_instance_name(instantiator);
517 if (STRINGP(instantiator)) {
518 /* First, look to see if we can retrieve a cached value. */
519 Lisp_Object instance =
520 Fgethash(instantiator, d->color_instance_cache, Qunbound);
521 /* Otherwise, make a new one. */
522 if (UNBOUNDP(instance)) {
523 /* make sure we cache the failures, too. */
525 Fmake_color_instance(instantiator, device, Qt);
526 Fputhash(instantiator, instance,
527 d->color_instance_cache);
530 return NILP(instance) ? Qunbound : instance;
531 } else if (VECTORP(instantiator)) {
532 switch (XVECTOR_LENGTH(instantiator)) {
535 return Vthe_null_color_instance;
538 ("Color instantiator [] only valid on TTY's",
543 (COLOR_SPECIFIER_FACE(XCOLOR_SPECIFIER(specifier))))
545 ("Color specifier not attached to a face",
547 return (FACE_PROPERTY_INSTANCE_1
548 (Fget_face(XVECTOR_DATA(instantiator)[0]),
549 COLOR_SPECIFIER_FACE_PROPERTY(XCOLOR_SPECIFIER
551 domain, ERROR_ME, 0, depth));
554 return (FACE_PROPERTY_INSTANCE_1
555 (Fget_face(XVECTOR_DATA(instantiator)[0]),
556 XVECTOR_DATA(instantiator)[1], domain,
557 ERROR_ME, 0, depth));
562 } else if (NILP(instantiator)) {
564 return Vthe_null_color_instance;
567 ("Color instantiator [] only valid on TTY's",
570 abort(); /* The spec validation routines are screwed up. */
575 static void color_validate(Lisp_Object instantiator)
577 if (COLOR_INSTANCEP(instantiator) || STRINGP(instantiator))
579 if (VECTORP(instantiator)) {
580 if (XVECTOR_LENGTH(instantiator) > 2)
582 ("Inheritance vector must be of size 0 - 2",
584 else if (XVECTOR_LENGTH(instantiator) > 0) {
585 Lisp_Object face = XVECTOR_DATA(instantiator)[0];
588 if (XVECTOR_LENGTH(instantiator) == 2) {
590 XVECTOR_DATA(instantiator)[1];
591 if (!EQ(field, Qforeground)
592 && !EQ(field, Qbackground))
594 ("Inheritance field must be `foreground' or `background'",
599 signal_simple_error("Invalid color instantiator", instantiator);
602 static void color_after_change(Lisp_Object specifier, Lisp_Object locale)
604 Lisp_Object face = COLOR_SPECIFIER_FACE(XCOLOR_SPECIFIER(specifier));
605 Lisp_Object property =
606 COLOR_SPECIFIER_FACE_PROPERTY(XCOLOR_SPECIFIER(specifier));
608 face_property_was_changed(face, property, locale);
610 XBUFFER(locale)->buffer_local_face_property = 1;
615 set_color_attached_to(Lisp_Object obj, Lisp_Object face, Lisp_Object property)
617 Lisp_Specifier *color = XCOLOR_SPECIFIER(obj);
619 COLOR_SPECIFIER_FACE(color) = face;
620 COLOR_SPECIFIER_FACE_PROPERTY(color) = property;
623 DEFUN("color-specifier-p", Fcolor_specifier_p, 1, 1, 0, /*
624 Return t if OBJECT is a color specifier.
626 See `make-color-specifier' for a description of possible color instantiators.
630 return COLOR_SPECIFIERP(object) ? Qt : Qnil;
633 /****************************************************************************
635 ***************************************************************************/
636 DEFINE_SPECIFIER_TYPE(font);
637 /* Qfont defined in general.c */
639 static void font_create(Lisp_Object obj)
641 Lisp_Specifier *font = XFONT_SPECIFIER(obj);
643 FONT_SPECIFIER_FACE(font) = Qnil;
644 FONT_SPECIFIER_FACE_PROPERTY(font) = Qnil;
647 static void font_mark(Lisp_Object obj)
649 Lisp_Specifier *font = XFONT_SPECIFIER(obj);
651 mark_object(FONT_SPECIFIER_FACE(font));
652 mark_object(FONT_SPECIFIER_FACE_PROPERTY(font));
655 /* No equal or hash methods; ignore the face the font is based off
661 font_spec_matches_charset(struct device *d, Lisp_Object charset,
662 const Bufbyte * nonreloc, Lisp_Object reloc,
663 Bytecount offset, Bytecount length)
665 return DEVMETH_OR_GIVEN(d, font_spec_matches_charset,
666 (d, charset, nonreloc, reloc, offset, length),
670 static void font_validate_matchspec(Lisp_Object matchspec)
672 Fget_charset(matchspec);
678 font_instantiate(Lisp_Object specifier, Lisp_Object matchspec,
679 Lisp_Object domain, Lisp_Object instantiator,
682 /* When called, we're inside of call_with_suspended_errors(),
683 so we can freely error. */
684 Lisp_Object device = DOMAIN_DEVICE(domain);
685 struct device *d = XDEVICE(device);
686 Lisp_Object instance;
689 if (!UNBOUNDP(matchspec))
690 matchspec = Fget_charset(matchspec);
693 if (FONT_INSTANCEP(instantiator)) {
695 || EQ(device, XFONT_INSTANCE(instantiator)->device)) {
697 if (font_spec_matches_charset(d, matchspec, 0,
698 Ffont_instance_truename
699 (instantiator), 0, -1))
705 instantiator = Ffont_instance_name(instantiator);
708 if (STRINGP(instantiator)) {
710 if (!UNBOUNDP(matchspec)) {
711 /* The instantiator is a font spec that could match many
712 different fonts. We need to find one of those fonts
713 whose registry matches the registry of the charset in
714 MATCHSPEC. This is potentially a very slow operation,
715 as it involves doing an XListFonts() or equivalent to
716 iterate over all possible fonts, and a regexp match
717 on each one. So we cache the results. */
718 Lisp_Object matching_font = Qunbound;
719 Lisp_Object hash_table =
720 Fgethash(matchspec, d->charset_font_cache,
722 if (UNBOUNDP(hash_table)) {
723 /* need to make a sub hash table. */
725 make_lisp_hash_table(20,
728 Fputhash(matchspec, hash_table,
729 d->charset_font_cache);
732 Fgethash(instantiator, hash_table,
735 if (UNBOUNDP(matching_font)) {
736 /* make sure we cache the failures, too. */
738 DEVMETH_OR_GIVEN(d, find_charset_font,
739 (device, instantiator,
740 matchspec), instantiator);
741 Fputhash(instantiator, matching_font,
744 if (NILP(matching_font))
746 instantiator = matching_font;
750 /* First, look to see if we can retrieve a cached value. */
752 Fgethash(instantiator, d->font_instance_cache, Qunbound);
753 /* Otherwise, make a new one. */
754 if (UNBOUNDP(instance)) {
755 /* make sure we cache the failures, too. */
757 Fmake_font_instance(instantiator, device, Qt);
758 Fputhash(instantiator, instance,
759 d->font_instance_cache);
762 return NILP(instance) ? Qunbound : instance;
763 } else if (VECTORP(instantiator)) {
764 assert(XVECTOR_LENGTH(instantiator) == 1);
765 return (face_property_matching_instance
766 (Fget_face(XVECTOR_DATA(instantiator)[0]), Qfont,
767 matchspec, domain, ERROR_ME, 0, depth));
768 } else if (NILP(instantiator))
776 static void font_validate(Lisp_Object instantiator)
778 if (FONT_INSTANCEP(instantiator) || STRINGP(instantiator))
780 if (VECTORP(instantiator)) {
781 if (XVECTOR_LENGTH(instantiator) != 1) {
783 ("Vector length must be one for font inheritance",
786 Fget_face(XVECTOR_DATA(instantiator)[0]);
788 signal_simple_error("Must be string, vector, or font-instance",
792 static void font_after_change(Lisp_Object specifier, Lisp_Object locale)
794 Lisp_Object face = FONT_SPECIFIER_FACE(XFONT_SPECIFIER(specifier));
795 Lisp_Object property =
796 FONT_SPECIFIER_FACE_PROPERTY(XFONT_SPECIFIER(specifier));
798 face_property_was_changed(face, property, locale);
800 XBUFFER(locale)->buffer_local_face_property = 1;
805 set_font_attached_to(Lisp_Object obj, Lisp_Object face, Lisp_Object property)
807 Lisp_Specifier *font = XFONT_SPECIFIER(obj);
809 FONT_SPECIFIER_FACE(font) = face;
810 FONT_SPECIFIER_FACE_PROPERTY(font) = property;
813 DEFUN("font-specifier-p", Ffont_specifier_p, 1, 1, 0, /*
814 Return non-nil if OBJECT is a font specifier.
816 See `make-font-specifier' for a description of possible font instantiators.
820 return FONT_SPECIFIERP(object) ? Qt : Qnil;
823 /*****************************************************************************
825 ****************************************************************************/
826 DEFINE_SPECIFIER_TYPE(face_boolean);
827 Lisp_Object Qface_boolean;
829 static void face_boolean_create(Lisp_Object obj)
831 Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER(obj);
833 FACE_BOOLEAN_SPECIFIER_FACE(face_boolean) = Qnil;
834 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY(face_boolean) = Qnil;
837 static void face_boolean_mark(Lisp_Object obj)
839 Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER(obj);
841 mark_object(FACE_BOOLEAN_SPECIFIER_FACE(face_boolean));
842 mark_object(FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY(face_boolean));
845 /* No equal or hash methods; ignore the face the face-boolean is based off
849 face_boolean_instantiate(Lisp_Object specifier, Lisp_Object matchspec,
850 Lisp_Object domain, Lisp_Object instantiator,
853 /* When called, we're inside of call_with_suspended_errors(),
854 so we can freely error. */
855 if (NILP(instantiator) || EQ(instantiator, Qt))
857 else if (VECTORP(instantiator)) {
860 int instantiator_len = XVECTOR_LENGTH(instantiator);
862 assert(instantiator_len >= 1 && instantiator_len <= 3);
863 if (instantiator_len > 1)
864 prop = XVECTOR_DATA(instantiator)[1];
866 if (NILP(FACE_BOOLEAN_SPECIFIER_FACE
867 (XFACE_BOOLEAN_SPECIFIER(specifier))))
869 ("Face-boolean specifier not attached to a face",
872 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY
873 (XFACE_BOOLEAN_SPECIFIER(specifier));
876 retval = (FACE_PROPERTY_INSTANCE_1
877 (Fget_face(XVECTOR_DATA(instantiator)[0]),
878 prop, domain, ERROR_ME, 0, depth));
880 if (instantiator_len == 3
881 && !NILP(XVECTOR_DATA(instantiator)[2]))
882 retval = NILP(retval) ? Qt : Qnil;
891 static void face_boolean_validate(Lisp_Object instantiator)
893 if (NILP(instantiator) || EQ(instantiator, Qt))
895 else if (VECTORP(instantiator) &&
896 (XVECTOR_LENGTH(instantiator) >= 1 &&
897 XVECTOR_LENGTH(instantiator) <= 3)) {
898 Lisp_Object face = XVECTOR_DATA(instantiator)[0];
902 if (XVECTOR_LENGTH(instantiator) > 1) {
903 Lisp_Object field = XVECTOR_DATA(instantiator)[1];
904 if (!EQ(field, Qunderline)
905 && !EQ(field, Qstrikethru)
906 && !EQ(field, Qhighlight)
908 && !EQ(field, Qblinking)
909 && !EQ(field, Qreverse))
911 ("Invalid face-boolean inheritance field",
914 } else if (VECTORP(instantiator))
916 ("Wrong length for face-boolean inheritance spec",
920 ("Face-boolean instantiator must be nil, t, or vector",
924 static void face_boolean_after_change(Lisp_Object specifier, Lisp_Object locale)
927 FACE_BOOLEAN_SPECIFIER_FACE(XFACE_BOOLEAN_SPECIFIER(specifier));
928 Lisp_Object property =
929 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY(XFACE_BOOLEAN_SPECIFIER
932 face_property_was_changed(face, property, locale);
934 XBUFFER(locale)->buffer_local_face_property = 1;
939 set_face_boolean_attached_to(Lisp_Object obj, Lisp_Object face,
940 Lisp_Object property)
942 Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER(obj);
944 FACE_BOOLEAN_SPECIFIER_FACE(face_boolean) = face;
945 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY(face_boolean) = property;
948 DEFUN("face-boolean-specifier-p", Fface_boolean_specifier_p, 1, 1, 0, /*
949 Return non-nil if OBJECT is a face-boolean specifier.
951 See `make-face-boolean-specifier' for a description of possible
952 face-boolean instantiators.
956 return FACE_BOOLEAN_SPECIFIERP(object) ? Qt : Qnil;
959 /************************************************************************/
961 /************************************************************************/
963 void syms_of_objects(void)
965 INIT_LRECORD_IMPLEMENTATION(color_instance);
966 INIT_LRECORD_IMPLEMENTATION(font_instance);
968 DEFSUBR(Fcolor_specifier_p);
969 DEFSUBR(Ffont_specifier_p);
970 DEFSUBR(Fface_boolean_specifier_p);
972 defsymbol(&Qcolor_instancep, "color-instance-p");
973 DEFSUBR(Fmake_color_instance);
974 DEFSUBR(Fcolor_instance_p);
975 DEFSUBR(Fcolor_instance_name);
976 DEFSUBR(Fcolor_instance_rgb_components);
977 DEFSUBR(Fvalid_color_name_p);
979 defsymbol(&Qfont_instancep, "font-instance-p");
980 DEFSUBR(Fmake_font_instance);
981 DEFSUBR(Ffont_instance_p);
982 DEFSUBR(Ffont_instance_name);
983 DEFSUBR(Ffont_instance_ascent);
984 DEFSUBR(Ffont_instance_descent);
985 DEFSUBR(Ffont_instance_width);
986 DEFSUBR(Ffont_instance_proportional_p);
987 DEFSUBR(Ffont_instance_truename);
988 DEFSUBR(Ffont_instance_properties);
989 DEFSUBR(Flist_fonts);
991 /* Qcolor, Qfont defined in general.c */
992 defsymbol(&Qface_boolean, "face-boolean");
995 static const struct lrecord_description color_specifier_description[] = {
997 specifier_data_offset + offsetof(struct color_specifier, face)},
999 specifier_data_offset + offsetof(struct color_specifier,
1004 static const struct lrecord_description font_specifier_description[] = {
1006 specifier_data_offset + offsetof(struct font_specifier, face)},
1008 specifier_data_offset + offsetof(struct font_specifier,
1013 static const struct lrecord_description face_boolean_specifier_description[] = {
1015 specifier_data_offset + offsetof(struct face_boolean_specifier, face)},
1017 specifier_data_offset + offsetof(struct face_boolean_specifier,
1022 void specifier_type_create_objects(void)
1024 INITIALIZE_SPECIFIER_TYPE_WITH_DATA(color, "color",
1025 "color-specifier-p");
1026 INITIALIZE_SPECIFIER_TYPE_WITH_DATA(font, "font", "font-specifier-p");
1027 INITIALIZE_SPECIFIER_TYPE_WITH_DATA(face_boolean, "face-boolean",
1028 "face-boolean-specifier-p");
1030 SPECIFIER_HAS_METHOD(color, instantiate);
1031 SPECIFIER_HAS_METHOD(font, instantiate);
1032 SPECIFIER_HAS_METHOD(face_boolean, instantiate);
1034 SPECIFIER_HAS_METHOD(color, validate);
1035 SPECIFIER_HAS_METHOD(font, validate);
1036 SPECIFIER_HAS_METHOD(face_boolean, validate);
1038 SPECIFIER_HAS_METHOD(color, create);
1039 SPECIFIER_HAS_METHOD(font, create);
1040 SPECIFIER_HAS_METHOD(face_boolean, create);
1042 SPECIFIER_HAS_METHOD(color, mark);
1043 SPECIFIER_HAS_METHOD(font, mark);
1044 SPECIFIER_HAS_METHOD(face_boolean, mark);
1046 SPECIFIER_HAS_METHOD(color, after_change);
1047 SPECIFIER_HAS_METHOD(font, after_change);
1048 SPECIFIER_HAS_METHOD(face_boolean, after_change);
1051 SPECIFIER_HAS_METHOD(font, validate_matchspec);
1055 void reinit_specifier_type_create_objects(void)
1057 REINITIALIZE_SPECIFIER_TYPE(color);
1058 REINITIALIZE_SPECIFIER_TYPE(font);
1059 REINITIALIZE_SPECIFIER_TYPE(face_boolean);
1062 void reinit_vars_of_objects(void)
1064 staticpro_nodump(&Vthe_null_color_instance);
1066 Lisp_Color_Instance *c =
1067 alloc_lcrecord_type(Lisp_Color_Instance,
1068 &lrecord_color_instance);
1073 XSETCOLOR_INSTANCE(Vthe_null_color_instance, c);
1076 staticpro_nodump(&Vthe_null_font_instance);
1078 Lisp_Font_Instance *f =
1079 alloc_lcrecord_type(Lisp_Font_Instance,
1080 &lrecord_font_instance);
1085 f->ascent = f->height = 0;
1088 f->proportional_p = 0;
1090 XSETFONT_INSTANCE(Vthe_null_font_instance, f);
1094 void vars_of_objects(void)
1096 reinit_vars_of_objects();