cgit.sxemacs.org Git - sxemacs/blob - src/objects.c

   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.
   5
   6 This file is part of SXEmacs
   7
   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.
  12
  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.
  17
  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/>. */
  20
  21
  22 /* Synched up with: Not in FSF. */
  23
  24 #include <config.h>
  25 #include "lisp.h"
  26
  27 #include "ui/device.h"
  28 #include "elhash.h"
  29 #include "ui/faces.h"
  30 #include "ui/frame.h"
  31 #include "ui/objects.h"
  32 #include "specifier.h"
  33 #include "ui/window.h"
  34
  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;
  38
  39 /* Authors: Ben Wing, Chuck Thompson */
  40
  41 void finalose(void *ptr)
  42 {
  43         Lisp_Object obj;
  44         XSETOBJ(obj, ptr);
  45
  46         signal_simple_error
  47             ("Can't dump an emacs containing window system objects", obj);
  48 }
  49 \f
  50 /****************************************************************************
  51  *                       Color-Instance Object                              *
  52  ****************************************************************************/
  53
  54 Lisp_Object Qcolor_instancep;
  55
  56 static Lisp_Object mark_color_instance(Lisp_Object obj)
  57 {
  58         Lisp_Color_Instance *c = XCOLOR_INSTANCE(obj);
  59         mark_object(c->name);
  60         if (!NILP(c->device))   /* Vthe_null_color_instance */
  61                 MAYBE_DEVMETH(XDEVICE(c->device), mark_color_instance, (c));
  62
  63         return c->device;
  64 }
  65
  66 static void
  67 print_color_instance(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
  68 {
  69         char buf[100];
  70         Lisp_Color_Instance *c = XCOLOR_INSTANCE(obj);
  71         if (print_readably)
  72                 error("printing unreadable object #<color-instance 0x%x>",
  73                       c->header.uid);
  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);
  83 }
  84
  85 static void finalize_color_instance(void *header, int for_disksave)
  86 {
  87         Lisp_Color_Instance *c = (Lisp_Color_Instance *) header;
  88
  89         if (!NILP(c->device)) {
  90                 if (for_disksave)
  91                         finalose(c);
  92                 MAYBE_DEVMETH(XDEVICE(c->device), finalize_color_instance, (c));
  93         }
  94 }
  95
  96 static int color_instance_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
  97 {
  98         Lisp_Color_Instance *c1 = XCOLOR_INSTANCE(obj1);
  99         Lisp_Color_Instance *c2 = XCOLOR_INSTANCE(obj2);
 100
 101         return (c1 == c2) ||
 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,
 106                      (c1, c2, depth)));
 107 }
 108
 109 static unsigned long color_instance_hash(Lisp_Object obj, int depth)
 110 {
 111         Lisp_Color_Instance *c = XCOLOR_INSTANCE(obj);
 112         struct device *d = DEVICEP(c->device) ? XDEVICE(c->device) : 0;
 113
 114         return HASH2((unsigned long)d, !d ? LISP_HASH(obj)
 115                      : DEVMETH_OR_GIVEN(d, color_instance_hash, (c, depth),
 116                                         LISP_HASH(obj)));
 117 }
 118
 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);
 123 \f
 124 DEFUN("make-color-instance", Fmake_color_instance, 1, 3, 0,     /*
 125 Return a new `color-instance' object named NAME (a string).
 126
 127 Optional argument DEVICE specifies the device this object applies to
 128 and defaults to the selected device.
 129
 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
 133 be issued.)
 134
 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.
 140 */
 141       (name, device, noerror))
 142 {
 143         Lisp_Color_Instance *c;
 144         Lisp_Object val = Qnil;
 145         Lisp_Object dev = Qnil;
 146         int retval = 0;
 147         int count = specpdl_depth();
 148         struct gcpro gcpro1, gcpro2;
 149
 150         CHECK_STRING(name);
 151         XSETDEVICE(dev, decode_device(device));
 152
 153         c = alloc_lcrecord_type(Lisp_Color_Instance, &lrecord_color_instance);
 154         c->name = name;
 155         c->device = dev;
 156         c->data = 0;
 157
 158         XSETCOLOR_INSTANCE(val, c);
 159         GCPRO2(val,dev);
 160         retval = MAYBE_INT_DEVMETH(XDEVICE(dev), initialize_color_instance,
 161                                    (c, name, dev,
 162                                     decode_error_behavior_flag(noerror)));
 163         if (!retval) {
 164           unbind_to(count, Qnil);
 165           UNGCPRO;
 166           return Qnil;
 167         }
 168
 169         XSETCOLOR_INSTANCE(val, c);
 170         unbind_to(count, Qnil);
 171         UNGCPRO;
 172         return val;
 173 }
 174
 175 DEFUN("color-instance-p", Fcolor_instance_p, 1, 1, 0,   /*
 176 Return non-nil if OBJECT is a color instance.
 177 */
 178       (object))
 179 {
 180         return COLOR_INSTANCEP(object) ? Qt : Qnil;
 181 }
 182
 183 DEFUN("color-instance-name", Fcolor_instance_name, 1, 1, 0,     /*
 184 Return the name used to allocate COLOR-INSTANCE.
 185 */
 186       (color_instance))
 187 {
 188         CHECK_COLOR_INSTANCE(color_instance);
 189         return XCOLOR_INSTANCE(color_instance)->name;
 190 }
 191
 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.
 196 */
 197       (color_instance))
 198 {
 199         Lisp_Color_Instance *c;
 200
 201         CHECK_COLOR_INSTANCE(color_instance);
 202         c = XCOLOR_INSTANCE(color_instance);
 203
 204         if (NILP(c->device))
 205                 return Qnil;
 206
 207         return MAYBE_LISP_DEVMETH(XDEVICE(c->device),
 208                                   color_instance_rgb_components, (c));
 209 }
 210
 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.
 213
 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.
 216
 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
 219 such as `blink'.
 220 */
 221       (color, device))
 222 {
 223         struct device *d = decode_device(device);
 224
 225         CHECK_STRING(color);
 226         return MAYBE_INT_DEVMETH(d, valid_color_name_p, (d, color)) ? Qt : Qnil;
 227 }
 228 \f
 229 /***************************************************************************
 230  *                       Font-Instance Object                              *
 231  ***************************************************************************/
 232
 233 Lisp_Object Qfont_instancep;
 234
 235 static Lisp_Object font_instance_truename_internal(Lisp_Object xfont,
 236                                                    Error_behavior errb);
 237
 238 static Lisp_Object mark_font_instance(Lisp_Object obj)
 239 {
 240         Lisp_Font_Instance *f = XFONT_INSTANCE(obj);
 241
 242         mark_object(f->name);
 243         if (!NILP(f->device))   /* Vthe_null_font_instance */
 244                 MAYBE_DEVMETH(XDEVICE(f->device), mark_font_instance, (f));
 245
 246         return f->device;
 247 }
 248
 249 static void
 250 print_font_instance(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 251 {
 252         char buf[200];
 253         Lisp_Font_Instance *f = XFONT_INSTANCE(obj);
 254         if (print_readably)
 255                 error("printing unreadable object #<font-instance 0x%x>",
 256                       f->header.uid);
 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);
 266 }
 267
 268 static void finalize_font_instance(void *header, int for_disksave)
 269 {
 270         Lisp_Font_Instance *f = (Lisp_Font_Instance *) header;
 271
 272         if (!NILP(f->device)) {
 273                 if (for_disksave)
 274                         finalose(f);
 275                 MAYBE_DEVMETH(XDEVICE(f->device), finalize_font_instance, (f));
 276         }
 277 }
 278
 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.
 282  */
 283 static int font_instance_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
 284 {
 285         /* #### should this be moved into a device method? */
 286         return
 287             internal_equal(font_instance_truename_internal(obj1, ERROR_ME_NOT),
 288                            font_instance_truename_internal(obj2, ERROR_ME_NOT),
 289                            depth + 1);
 290 }
 291
 292 static unsigned long font_instance_hash(Lisp_Object obj, int depth)
 293 {
 294         return internal_hash(font_instance_truename_internal(obj, ERROR_ME_NOT),
 295                              depth + 1);
 296 }
 297
 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);
 302 \f
 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
 308 this case.
 309
 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.
 314 */
 315       (name, device, noerror))
 316 {
 317         Lisp_Font_Instance *f;
 318         Lisp_Object val;
 319         int retval = 0;
 320         Error_behavior errb = decode_error_behavior_flag(noerror);
 321
 322         if (ERRB_EQ(errb, ERROR_ME))
 323                 CHECK_STRING(name);
 324         else if (!STRINGP(name))
 325                 return Qnil;
 326
 327         XSETDEVICE(device, decode_device(device));
 328
 329         f = alloc_lcrecord_type(Lisp_Font_Instance, &lrecord_font_instance);
 330         f->name = name;
 331         f->device = device;
 332
 333         f->data = 0;
 334
 335         /* Stick some default values here ... */
 336         f->ascent = f->height = 1;
 337         f->descent = 0;
 338         f->width = 1;
 339         f->proportional_p = 0;
 340
 341         retval = MAYBE_INT_DEVMETH(XDEVICE(device), initialize_font_instance,
 342                                    (f, name, device, errb));
 343
 344         if (!retval)
 345                 return Qnil;
 346
 347         XSETFONT_INSTANCE(val, f);
 348         return val;
 349 }
 350
 351 DEFUN("font-instance-p", Ffont_instance_p, 1, 1, 0,     /*
 352 Return non-nil if OBJECT is a font instance.
 353 */
 354       (object))
 355 {
 356         return FONT_INSTANCEP(object) ? Qt : Qnil;
 357 }
 358
 359 DEFUN("font-instance-name", Ffont_instance_name, 1, 1, 0,       /*
 360 Return the name used to allocate FONT-INSTANCE.
 361 */
 362       (font_instance))
 363 {
 364         CHECK_FONT_INSTANCE(font_instance);
 365         return XFONT_INSTANCE(font_instance)->name;
 366 }
 367
 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)
 372 the baseline.
 373 */
 374       (font_instance))
 375 {
 376         CHECK_FONT_INSTANCE(font_instance);
 377         return make_int(XFONT_INSTANCE(font_instance)->ascent);
 378 }
 379
 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.)
 386 */
 387       (font_instance))
 388 {
 389         CHECK_FONT_INSTANCE(font_instance);
 390         return make_int(XFONT_INSTANCE(font_instance)->descent);
 391 }
 392
 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.
 396 */
 397       (font_instance))
 398 {
 399         CHECK_FONT_INSTANCE(font_instance);
 400         return make_int(XFONT_INSTANCE(font_instance)->width);
 401 }
 402
 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.
 406 */
 407       (font_instance))
 408 {
 409         CHECK_FONT_INSTANCE(font_instance);
 410         return XFONT_INSTANCE(font_instance)->proportional_p ? Qt : Qnil;
 411 }
 412
 413 static Lisp_Object
 414 font_instance_truename_internal(Lisp_Object font_instance, Error_behavior errb)
 415 {
 416         Lisp_Font_Instance *f = XFONT_INSTANCE(font_instance);
 417
 418         if (NILP(f->device)) {
 419                 maybe_signal_simple_error("Couldn't determine font truename",
 420                                           font_instance, Qfont, errb);
 421                 return Qnil;
 422         }
 423
 424         return DEVMETH_OR_GIVEN(XDEVICE(f->device),
 425                                 font_instance_truename, (f, errb), f->name);
 426 }
 427
 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).
 433 */
 434       (font_instance))
 435 {
 436         CHECK_FONT_INSTANCE(font_instance);
 437         return font_instance_truename_internal(font_instance, ERROR_ME);
 438 }
 439
 440 DEFUN("font-instance-properties", Ffont_instance_properties, 1, 1, 0,   /*
 441 Return the properties (an alist or nil) of FONT-INSTANCE.
 442 */
 443       (font_instance))
 444 {
 445         Lisp_Font_Instance *f;
 446
 447         CHECK_FONT_INSTANCE(font_instance);
 448         f = XFONT_INSTANCE(font_instance);
 449
 450         if (NILP(f->device))
 451                 return Qnil;
 452
 453         return MAYBE_LISP_DEVMETH(XDEVICE(f->device),
 454                                   font_instance_properties, (f));
 455 }
 456
 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.
 461 */
 462       (pattern, device))
 463 {
 464         CHECK_STRING(pattern);
 465         XSETDEVICE(device, decode_device(device));
 466
 467         return MAYBE_LISP_DEVMETH(XDEVICE(device), list_fonts,
 468                                   (pattern, device));
 469 }
 470 \f
 471 /****************************************************************************
 472  Color Object
 473  ***************************************************************************/
 474 DEFINE_SPECIFIER_TYPE(color);
 475 /* Qcolor defined in general.c */
 476
 477 static void color_create(Lisp_Object obj)
 478 {
 479         Lisp_Specifier *color = XCOLOR_SPECIFIER(obj);
 480
 481         COLOR_SPECIFIER_FACE(color) = Qnil;
 482         COLOR_SPECIFIER_FACE_PROPERTY(color) = Qnil;
 483 }
 484
 485 static void color_mark(Lisp_Object obj)
 486 {
 487         Lisp_Specifier *color = XCOLOR_SPECIFIER(obj);
 488
 489         mark_object(COLOR_SPECIFIER_FACE(color));
 490         mark_object(COLOR_SPECIFIER_FACE_PROPERTY(color));
 491 }
 492
 493 /* No equal or hash methods; ignore the face the color is based off
 494    of for `equal' */
 495
 496 static Lisp_Object
 497 color_instantiate(Lisp_Object specifier, Lisp_Object matchspec,
 498                   Lisp_Object domain, Lisp_Object instantiator,
 499                   Lisp_Object depth)
 500 {
 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);
 505
 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))
 512                         return instantiator;
 513                 else
 514                         instantiator = Fcolor_instance_name(instantiator);
 515         }
 516
 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. */
 524                         instance =
 525                             Fmake_color_instance(instantiator, device, Qt);
 526                         Fputhash(instantiator, instance,
 527                                  d->color_instance_cache);
 528                 }
 529
 530                 return NILP(instance) ? Qunbound : instance;
 531         } else if (VECTORP(instantiator)) {
 532                 switch (XVECTOR_LENGTH(instantiator)) {
 533                 case 0:
 534                         if (DEVICE_TTY_P(d))
 535                                 return Vthe_null_color_instance;
 536                         else
 537                                 signal_simple_error
 538                                     ("Color instantiator [] only valid on TTY's",
 539                                      device);
 540
 541                 case 1:
 542                         if (NILP
 543                             (COLOR_SPECIFIER_FACE(XCOLOR_SPECIFIER(specifier))))
 544                                 signal_simple_error
 545                                     ("Color specifier not attached to a face",
 546                                      instantiator);
 547                         return (FACE_PROPERTY_INSTANCE_1
 548                                 (Fget_face(XVECTOR_DATA(instantiator)[0]),
 549                                  COLOR_SPECIFIER_FACE_PROPERTY(XCOLOR_SPECIFIER
 550                                                                (specifier)),
 551                                  domain, ERROR_ME, 0, depth));
 552
 553                 case 2:
 554                         return (FACE_PROPERTY_INSTANCE_1
 555                                 (Fget_face(XVECTOR_DATA(instantiator)[0]),
 556                                  XVECTOR_DATA(instantiator)[1], domain,
 557                                  ERROR_ME, 0, depth));
 558
 559                 default:
 560                         abort();
 561                 }
 562         } else if (NILP(instantiator)) {
 563                 if (DEVICE_TTY_P(d))
 564                         return Vthe_null_color_instance;
 565                 else
 566                         signal_simple_error
 567                             ("Color instantiator [] only valid on TTY's",
 568                              device);
 569         } else
 570                 abort();        /* The spec validation routines are screwed up. */
 571
 572         return Qunbound;
 573 }
 574
 575 static void color_validate(Lisp_Object instantiator)
 576 {
 577         if (COLOR_INSTANCEP(instantiator) || STRINGP(instantiator))
 578                 return;
 579         if (VECTORP(instantiator)) {
 580                 if (XVECTOR_LENGTH(instantiator) > 2)
 581                         signal_simple_error
 582                             ("Inheritance vector must be of size 0 - 2",
 583                              instantiator);
 584                 else if (XVECTOR_LENGTH(instantiator) > 0) {
 585                         Lisp_Object face = XVECTOR_DATA(instantiator)[0];
 586
 587                         Fget_face(face);
 588                         if (XVECTOR_LENGTH(instantiator) == 2) {
 589                                 Lisp_Object field =
 590                                     XVECTOR_DATA(instantiator)[1];
 591                                 if (!EQ(field, Qforeground)
 592                                     && !EQ(field, Qbackground))
 593                                         signal_simple_error
 594                                             ("Inheritance field must be `foreground' or `background'",
 595                                              field);
 596                         }
 597                 }
 598         } else
 599                 signal_simple_error("Invalid color instantiator", instantiator);
 600 }
 601
 602 static void color_after_change(Lisp_Object specifier, Lisp_Object locale)
 603 {
 604         Lisp_Object face = COLOR_SPECIFIER_FACE(XCOLOR_SPECIFIER(specifier));
 605         Lisp_Object property =
 606             COLOR_SPECIFIER_FACE_PROPERTY(XCOLOR_SPECIFIER(specifier));
 607         if (!NILP(face)) {
 608                 face_property_was_changed(face, property, locale);
 609                 if (BUFFERP(locale))
 610                         XBUFFER(locale)->buffer_local_face_property = 1;
 611         }
 612 }
 613
 614 void
 615 set_color_attached_to(Lisp_Object obj, Lisp_Object face, Lisp_Object property)
 616 {
 617         Lisp_Specifier *color = XCOLOR_SPECIFIER(obj);
 618
 619         COLOR_SPECIFIER_FACE(color) = face;
 620         COLOR_SPECIFIER_FACE_PROPERTY(color) = property;
 621 }
 622
 623 DEFUN("color-specifier-p", Fcolor_specifier_p, 1, 1, 0, /*
 624 Return t if OBJECT is a color specifier.
 625
 626 See `make-color-specifier' for a description of possible color instantiators.
 627 */
 628       (object))
 629 {
 630         return COLOR_SPECIFIERP(object) ? Qt : Qnil;
 631 }
 632 \f
 633 /****************************************************************************
 634  Font Object
 635  ***************************************************************************/
 636 DEFINE_SPECIFIER_TYPE(font);
 637 /* Qfont defined in general.c */
 638
 639 static void font_create(Lisp_Object obj)
 640 {
 641         Lisp_Specifier *font = XFONT_SPECIFIER(obj);
 642
 643         FONT_SPECIFIER_FACE(font) = Qnil;
 644         FONT_SPECIFIER_FACE_PROPERTY(font) = Qnil;
 645 }
 646
 647 static void font_mark(Lisp_Object obj)
 648 {
 649         Lisp_Specifier *font = XFONT_SPECIFIER(obj);
 650
 651         mark_object(FONT_SPECIFIER_FACE(font));
 652         mark_object(FONT_SPECIFIER_FACE_PROPERTY(font));
 653 }
 654
 655 /* No equal or hash methods; ignore the face the font is based off
 656    of for `equal' */
 657
 658 #ifdef MULE
 659
 660 int
 661 font_spec_matches_charset(struct device *d, Lisp_Object charset,
 662                           const Bufbyte * nonreloc, Lisp_Object reloc,
 663                           Bytecount offset, Bytecount length)
 664 {
 665         return DEVMETH_OR_GIVEN(d, font_spec_matches_charset,
 666                                 (d, charset, nonreloc, reloc, offset, length),
 667                                 1);
 668 }
 669
 670 static void font_validate_matchspec(Lisp_Object matchspec)
 671 {
 672         Fget_charset(matchspec);
 673 }
 674
 675 #endif                          /* MULE */
 676
 677 static Lisp_Object
 678 font_instantiate(Lisp_Object specifier, Lisp_Object matchspec,
 679                  Lisp_Object domain, Lisp_Object instantiator,
 680                  Lisp_Object depth)
 681 {
 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;
 687
 688 #ifdef MULE
 689         if (!UNBOUNDP(matchspec))
 690                 matchspec = Fget_charset(matchspec);
 691 #endif
 692
 693         if (FONT_INSTANCEP(instantiator)) {
 694                 if (NILP(device)
 695                     || EQ(device, XFONT_INSTANCE(instantiator)->device)) {
 696 #ifdef MULE
 697                         if (font_spec_matches_charset(d, matchspec, 0,
 698                                                       Ffont_instance_truename
 699                                                       (instantiator), 0, -1))
 700                                 return instantiator;
 701 #else
 702                         return instantiator;
 703 #endif
 704                 }
 705                 instantiator = Ffont_instance_name(instantiator);
 706         }
 707
 708         if (STRINGP(instantiator)) {
 709 #ifdef MULE
 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,
 721                                      Qunbound);
 722                         if (UNBOUNDP(hash_table)) {
 723                                 /* need to make a sub hash table. */
 724                                 hash_table =
 725                                     make_lisp_hash_table(20,
 726                                                          HASH_TABLE_KEY_WEAK,
 727                                                          HASH_TABLE_EQUAL);
 728                                 Fputhash(matchspec, hash_table,
 729                                          d->charset_font_cache);
 730                         } else
 731                                 matching_font =
 732                                     Fgethash(instantiator, hash_table,
 733                                              Qunbound);
 734
 735                         if (UNBOUNDP(matching_font)) {
 736                                 /* make sure we cache the failures, too. */
 737                                 matching_font =
 738                                     DEVMETH_OR_GIVEN(d, find_charset_font,
 739                                                      (device, instantiator,
 740                                                       matchspec), instantiator);
 741                                 Fputhash(instantiator, matching_font,
 742                                          hash_table);
 743                         }
 744                         if (NILP(matching_font))
 745                                 return Qunbound;
 746                         instantiator = matching_font;
 747                 }
 748 #endif                          /* MULE */
 749
 750                 /* First, look to see if we can retrieve a cached value. */
 751                 instance =
 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. */
 756                         instance =
 757                             Fmake_font_instance(instantiator, device, Qt);
 758                         Fputhash(instantiator, instance,
 759                                  d->font_instance_cache);
 760                 }
 761
 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))
 769                 return Qunbound;
 770         else
 771                 abort();        /* Eh? */
 772
 773         return Qunbound;
 774 }
 775
 776 static void font_validate(Lisp_Object instantiator)
 777 {
 778         if (FONT_INSTANCEP(instantiator) || STRINGP(instantiator))
 779                 return;
 780         if (VECTORP(instantiator)) {
 781                 if (XVECTOR_LENGTH(instantiator) != 1) {
 782                         signal_simple_error
 783                             ("Vector length must be one for font inheritance",
 784                              instantiator);
 785                 }
 786                 Fget_face(XVECTOR_DATA(instantiator)[0]);
 787         } else
 788                 signal_simple_error("Must be string, vector, or font-instance",
 789                                     instantiator);
 790 }
 791
 792 static void font_after_change(Lisp_Object specifier, Lisp_Object locale)
 793 {
 794         Lisp_Object face = FONT_SPECIFIER_FACE(XFONT_SPECIFIER(specifier));
 795         Lisp_Object property =
 796             FONT_SPECIFIER_FACE_PROPERTY(XFONT_SPECIFIER(specifier));
 797         if (!NILP(face)) {
 798                 face_property_was_changed(face, property, locale);
 799                 if (BUFFERP(locale))
 800                         XBUFFER(locale)->buffer_local_face_property = 1;
 801         }
 802 }
 803
 804 void
 805 set_font_attached_to(Lisp_Object obj, Lisp_Object face, Lisp_Object property)
 806 {
 807         Lisp_Specifier *font = XFONT_SPECIFIER(obj);
 808
 809         FONT_SPECIFIER_FACE(font) = face;
 810         FONT_SPECIFIER_FACE_PROPERTY(font) = property;
 811 }
 812
 813 DEFUN("font-specifier-p", Ffont_specifier_p, 1, 1, 0,   /*
 814 Return non-nil if OBJECT is a font specifier.
 815
 816 See `make-font-specifier' for a description of possible font instantiators.
 817 */
 818       (object))
 819 {
 820         return FONT_SPECIFIERP(object) ? Qt : Qnil;
 821 }
 822 \f
 823 /*****************************************************************************
 824  Face Boolean Object
 825  ****************************************************************************/
 826 DEFINE_SPECIFIER_TYPE(face_boolean);
 827 Lisp_Object Qface_boolean;
 828
 829 static void face_boolean_create(Lisp_Object obj)
 830 {
 831         Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER(obj);
 832
 833         FACE_BOOLEAN_SPECIFIER_FACE(face_boolean) = Qnil;
 834         FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY(face_boolean) = Qnil;
 835 }
 836
 837 static void face_boolean_mark(Lisp_Object obj)
 838 {
 839         Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER(obj);
 840
 841         mark_object(FACE_BOOLEAN_SPECIFIER_FACE(face_boolean));
 842         mark_object(FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY(face_boolean));
 843 }
 844
 845 /* No equal or hash methods; ignore the face the face-boolean is based off
 846    of for `equal' */
 847
 848 static Lisp_Object
 849 face_boolean_instantiate(Lisp_Object specifier, Lisp_Object matchspec,
 850                          Lisp_Object domain, Lisp_Object instantiator,
 851                          Lisp_Object depth)
 852 {
 853         /* When called, we're inside of call_with_suspended_errors(),
 854            so we can freely error. */
 855         if (NILP(instantiator) || EQ(instantiator, Qt))
 856                 return instantiator;
 857         else if (VECTORP(instantiator)) {
 858                 Lisp_Object retval;
 859                 Lisp_Object prop;
 860                 int instantiator_len = XVECTOR_LENGTH(instantiator);
 861
 862                 assert(instantiator_len >= 1 && instantiator_len <= 3);
 863                 if (instantiator_len > 1)
 864                         prop = XVECTOR_DATA(instantiator)[1];
 865                 else {
 866                         if (NILP(FACE_BOOLEAN_SPECIFIER_FACE
 867                                  (XFACE_BOOLEAN_SPECIFIER(specifier))))
 868                                 signal_simple_error
 869                                     ("Face-boolean specifier not attached to a face",
 870                                      instantiator);
 871                         prop =
 872                             FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY
 873                             (XFACE_BOOLEAN_SPECIFIER(specifier));
 874                 }
 875
 876                 retval = (FACE_PROPERTY_INSTANCE_1
 877                           (Fget_face(XVECTOR_DATA(instantiator)[0]),
 878                            prop, domain, ERROR_ME, 0, depth));
 879
 880                 if (instantiator_len == 3
 881                     && !NILP(XVECTOR_DATA(instantiator)[2]))
 882                         retval = NILP(retval) ? Qt : Qnil;
 883
 884                 return retval;
 885         } else
 886                 abort();        /* Eh? */
 887
 888         return Qunbound;
 889 }
 890
 891 static void face_boolean_validate(Lisp_Object instantiator)
 892 {
 893         if (NILP(instantiator) || EQ(instantiator, Qt))
 894                 return;
 895         else if (VECTORP(instantiator) &&
 896                  (XVECTOR_LENGTH(instantiator) >= 1 &&
 897                   XVECTOR_LENGTH(instantiator) <= 3)) {
 898                 Lisp_Object face = XVECTOR_DATA(instantiator)[0];
 899
 900                 Fget_face(face);
 901
 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)
 907                             && !EQ(field, Qdim)
 908                             && !EQ(field, Qblinking)
 909                             && !EQ(field, Qreverse))
 910                                 signal_simple_error
 911                                     ("Invalid face-boolean inheritance field",
 912                                      field);
 913                 }
 914         } else if (VECTORP(instantiator))
 915                 signal_simple_error
 916                     ("Wrong length for face-boolean inheritance spec",
 917                      instantiator);
 918         else
 919                 signal_simple_error
 920                     ("Face-boolean instantiator must be nil, t, or vector",
 921                      instantiator);
 922 }
 923
 924 static void face_boolean_after_change(Lisp_Object specifier, Lisp_Object locale)
 925 {
 926         Lisp_Object face =
 927             FACE_BOOLEAN_SPECIFIER_FACE(XFACE_BOOLEAN_SPECIFIER(specifier));
 928         Lisp_Object property =
 929             FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY(XFACE_BOOLEAN_SPECIFIER
 930                                                  (specifier));
 931         if (!NILP(face)) {
 932                 face_property_was_changed(face, property, locale);
 933                 if (BUFFERP(locale))
 934                         XBUFFER(locale)->buffer_local_face_property = 1;
 935         }
 936 }
 937
 938 void
 939 set_face_boolean_attached_to(Lisp_Object obj, Lisp_Object face,
 940                              Lisp_Object property)
 941 {
 942         Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER(obj);
 943
 944         FACE_BOOLEAN_SPECIFIER_FACE(face_boolean) = face;
 945         FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY(face_boolean) = property;
 946 }
 947
 948 DEFUN("face-boolean-specifier-p", Fface_boolean_specifier_p, 1, 1, 0,   /*
 949 Return non-nil if OBJECT is a face-boolean specifier.
 950
 951 See `make-face-boolean-specifier' for a description of possible
 952 face-boolean instantiators.
 953 */
 954       (object))
 955 {
 956         return FACE_BOOLEAN_SPECIFIERP(object) ? Qt : Qnil;
 957 }
 958 \f
 959 /************************************************************************/
 960 /*                            initialization                            */
 961 /************************************************************************/
 962
 963 void syms_of_objects(void)
 964 {
 965         INIT_LRECORD_IMPLEMENTATION(color_instance);
 966         INIT_LRECORD_IMPLEMENTATION(font_instance);
 967
 968         DEFSUBR(Fcolor_specifier_p);
 969         DEFSUBR(Ffont_specifier_p);
 970         DEFSUBR(Fface_boolean_specifier_p);
 971
 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);
 978
 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);
 990
 991         /* Qcolor, Qfont defined in general.c */
 992         defsymbol(&Qface_boolean, "face-boolean");
 993 }
 994
 995 static const struct lrecord_description color_specifier_description[] = {
 996         {XD_LISP_OBJECT,
 997          specifier_data_offset + offsetof(struct color_specifier, face)},
 998         {XD_LISP_OBJECT,
 999          specifier_data_offset + offsetof(struct color_specifier,
1000                                           face_property)},
1001         {XD_END}
1002 };
1003
1004 static const struct lrecord_description font_specifier_description[] = {
1005         {XD_LISP_OBJECT,
1006          specifier_data_offset + offsetof(struct font_specifier, face)},
1007         {XD_LISP_OBJECT,
1008          specifier_data_offset + offsetof(struct font_specifier,
1009                                           face_property)},
1010         {XD_END}
1011 };
1012
1013 static const struct lrecord_description face_boolean_specifier_description[] = {
1014         {XD_LISP_OBJECT,
1015          specifier_data_offset + offsetof(struct face_boolean_specifier, face)},
1016         {XD_LISP_OBJECT,
1017          specifier_data_offset + offsetof(struct face_boolean_specifier,
1018                                           face_property)},
1019         {XD_END}
1020 };
1021
1022 void specifier_type_create_objects(void)
1023 {
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");
1029
1030         SPECIFIER_HAS_METHOD(color, instantiate);
1031         SPECIFIER_HAS_METHOD(font, instantiate);
1032         SPECIFIER_HAS_METHOD(face_boolean, instantiate);
1033
1034         SPECIFIER_HAS_METHOD(color, validate);
1035         SPECIFIER_HAS_METHOD(font, validate);
1036         SPECIFIER_HAS_METHOD(face_boolean, validate);
1037
1038         SPECIFIER_HAS_METHOD(color, create);
1039         SPECIFIER_HAS_METHOD(font, create);
1040         SPECIFIER_HAS_METHOD(face_boolean, create);
1041
1042         SPECIFIER_HAS_METHOD(color, mark);
1043         SPECIFIER_HAS_METHOD(font, mark);
1044         SPECIFIER_HAS_METHOD(face_boolean, mark);
1045
1046         SPECIFIER_HAS_METHOD(color, after_change);
1047         SPECIFIER_HAS_METHOD(font, after_change);
1048         SPECIFIER_HAS_METHOD(face_boolean, after_change);
1049
1050 #ifdef MULE
1051         SPECIFIER_HAS_METHOD(font, validate_matchspec);
1052 #endif
1053 }
1054
1055 void reinit_specifier_type_create_objects(void)
1056 {
1057         REINITIALIZE_SPECIFIER_TYPE(color);
1058         REINITIALIZE_SPECIFIER_TYPE(font);
1059         REINITIALIZE_SPECIFIER_TYPE(face_boolean);
1060 }
1061
1062 void reinit_vars_of_objects(void)
1063 {
1064         staticpro_nodump(&Vthe_null_color_instance);
1065         {
1066                 Lisp_Color_Instance *c =
1067                     alloc_lcrecord_type(Lisp_Color_Instance,
1068                                         &lrecord_color_instance);
1069                 c->name = Qnil;
1070                 c->device = Qnil;
1071                 c->data = 0;
1072
1073                 XSETCOLOR_INSTANCE(Vthe_null_color_instance, c);
1074         }
1075
1076         staticpro_nodump(&Vthe_null_font_instance);
1077         {
1078                 Lisp_Font_Instance *f =
1079                     alloc_lcrecord_type(Lisp_Font_Instance,
1080                                         &lrecord_font_instance);
1081                 f->name = Qnil;
1082                 f->device = Qnil;
1083                 f->data = 0;
1084
1085                 f->ascent = f->height = 0;
1086                 f->descent = 0;
1087                 f->width = 0;
1088                 f->proportional_p = 0;
1089
1090                 XSETFONT_INSTANCE(Vthe_null_font_instance, f);
1091         }
1092 }
1093
1094 void vars_of_objects(void)
1095 {
1096         reinit_vars_of_objects();
1097 }