git.chise.org Git - chise/xemacs-chise.git.1/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 XEmacs.
   7
   8 XEmacs is free software; you can redistribute it and/or modify it
   9 under the terms of the GNU General Public License as published by the
  10 Free Software Foundation; either version 2, or (at your option) any
  11 later version.
  12
  13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with XEmacs; see the file COPYING.  If not, write to
  20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  21 Boston, MA 02111-1307, USA.  */
  22
  23 /* Synched up with: Not in FSF. */
  24
  25 #include <config.h>
  26 #include "lisp.h"
  27
  28 #include "device.h"
  29 #include "elhash.h"
  30 #include "faces.h"
  31 #include "frame.h"
  32 #include "objects.h"
  33 #include "specifier.h"
  34 #include "window.h"
  35
  36 /* Objects that are substituted when an instantiation fails.
  37    If we leave in the Qunbound value, we will probably get crashes. */
  38 Lisp_Object Vthe_null_color_instance, Vthe_null_font_instance;
  39
  40 /* Authors: Ben Wing, Chuck Thompson */
  41
  42 void
  43 finalose (void *ptr)
  44 {
  45   Lisp_Object obj;
  46   XSETOBJ (obj, ptr);
  47
  48   signal_simple_error
  49     ("Can't dump an emacs containing window system objects", obj);
  50 }
  51
  52 \f
  53 /****************************************************************************
  54  *                       Color-Instance Object                              *
  55  ****************************************************************************/
  56
  57 Lisp_Object Qcolor_instancep;
  58
  59 static Lisp_Object
  60 mark_color_instance (Lisp_Object obj)
  61 {
  62   Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj);
  63   mark_object (c->name);
  64   if (!NILP (c->device)) /* Vthe_null_color_instance */
  65     MAYBE_DEVMETH (XDEVICE (c->device), mark_color_instance, (c));
  66
  67   return c->device;
  68 }
  69
  70 static void
  71 print_color_instance (Lisp_Object obj, Lisp_Object printcharfun,
  72                       int escapeflag)
  73 {
  74   char buf[100];
  75   Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj);
  76   if (print_readably)
  77     error ("printing unreadable object #<color-instance 0x%x>",
  78            c->header.uid);
  79   write_c_string ("#<color-instance ", printcharfun);
  80   print_internal (c->name, printcharfun, 0);
  81   write_c_string (" on ", printcharfun);
  82   print_internal (c->device, printcharfun, 0);
  83   if (!NILP (c->device)) /* Vthe_null_color_instance */
  84     MAYBE_DEVMETH (XDEVICE (c->device), print_color_instance,
  85                    (c, printcharfun, escapeflag));
  86   sprintf (buf, " 0x%x>", c->header.uid);
  87   write_c_string (buf, printcharfun);
  88 }
  89
  90 static void
  91 finalize_color_instance (void *header, int for_disksave)
  92 {
  93   Lisp_Color_Instance *c = (Lisp_Color_Instance *) header;
  94
  95   if (!NILP (c->device))
  96     {
  97       if (for_disksave) finalose (c);
  98       MAYBE_DEVMETH (XDEVICE (c->device), finalize_color_instance, (c));
  99     }
 100 }
 101
 102 static int
 103 color_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
 104 {
 105   Lisp_Color_Instance *c1 = XCOLOR_INSTANCE (obj1);
 106   Lisp_Color_Instance *c2 = XCOLOR_INSTANCE (obj2);
 107
 108   return (c1 == c2) ||
 109     (EQ (c1->device, c2->device) &&
 110      DEVICEP (c1->device) &&
 111      HAS_DEVMETH_P (XDEVICE (c1->device), color_instance_equal) &&
 112      DEVMETH (XDEVICE (c1->device), color_instance_equal, (c1, c2, depth)));
 113 }
 114
 115 static unsigned long
 116 color_instance_hash (Lisp_Object obj, int depth)
 117 {
 118   Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj);
 119   struct device *d = DEVICEP (c->device) ? XDEVICE (c->device) : 0;
 120
 121   return HASH2 ((unsigned long) d,
 122                 !d ? LISP_HASH (obj)
 123                 : DEVMETH_OR_GIVEN (d, color_instance_hash, (c, depth),
 124                                     LISP_HASH (obj)));
 125 }
 126
 127 DEFINE_LRECORD_IMPLEMENTATION ("color-instance", color_instance,
 128                                mark_color_instance, print_color_instance,
 129                                finalize_color_instance, color_instance_equal,
 130                                color_instance_hash, 0,
 131                                Lisp_Color_Instance);
 132 \f
 133 DEFUN ("make-color-instance", Fmake_color_instance, 1, 3, 0, /*
 134 Return a new `color-instance' object named NAME (a string).
 135
 136 Optional argument DEVICE specifies the device this object applies to
 137 and defaults to the selected device.
 138
 139 An error is signaled if the color is unknown or cannot be allocated;
 140 however, if optional argument NOERROR is non-nil, nil is simply
 141 returned in this case. (And if NOERROR is other than t, a warning may
 142 be issued.)
 143
 144 The returned object is a normal, first-class lisp object.  The way you
 145 `deallocate' the color is the way you deallocate any other lisp object:
 146 you drop all pointers to it and allow it to be garbage collected.  When
 147 these objects are GCed, the underlying window-system data (e.g. X object)
 148 is deallocated as well.
 149 */
 150        (name, device, noerror))
 151 {
 152   Lisp_Color_Instance *c;
 153   Lisp_Object val;
 154   int retval;
 155
 156   CHECK_STRING (name);
 157   XSETDEVICE (device, decode_device (device));
 158
 159   c = alloc_lcrecord_type (Lisp_Color_Instance, &lrecord_color_instance);
 160   c->name = name;
 161   c->device = device;
 162   c->data = 0;
 163
 164   retval = MAYBE_INT_DEVMETH (XDEVICE (device), initialize_color_instance,
 165                               (c, name, device,
 166                                decode_error_behavior_flag (noerror)));
 167   if (!retval)
 168     return Qnil;
 169
 170   XSETCOLOR_INSTANCE (val, c);
 171   return val;
 172 }
 173
 174 DEFUN ("color-instance-p", Fcolor_instance_p, 1, 1, 0, /*
 175 Return non-nil if OBJECT is a color instance.
 176 */
 177        (object))
 178 {
 179   return COLOR_INSTANCEP (object) ? Qt : Qnil;
 180 }
 181
 182 DEFUN ("color-instance-name", Fcolor_instance_name, 1, 1, 0, /*
 183 Return the name used to allocate COLOR-INSTANCE.
 184 */
 185        (color_instance))
 186 {
 187   CHECK_COLOR_INSTANCE (color_instance);
 188   return XCOLOR_INSTANCE (color_instance)->name;
 189 }
 190
 191 DEFUN ("color-instance-rgb-components", Fcolor_instance_rgb_components, 1, 1, 0, /*
 192 Return a three element list containing the red, green, and blue
 193 color components of COLOR-INSTANCE, or nil if unknown.
 194 Component values range from 0 to 65535.
 195 */
 196        (color_instance))
 197 {
 198   Lisp_Color_Instance *c;
 199
 200   CHECK_COLOR_INSTANCE (color_instance);
 201   c = XCOLOR_INSTANCE (color_instance);
 202
 203   if (NILP (c->device))
 204     return Qnil;
 205
 206   return MAYBE_LISP_DEVMETH (XDEVICE (c->device),
 207                              color_instance_rgb_components,
 208                              (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
 229 \f
 230 /***************************************************************************
 231  *                       Font-Instance Object                              *
 232  ***************************************************************************/
 233
 234 Lisp_Object Qfont_instancep;
 235
 236 static Lisp_Object font_instance_truename_internal (Lisp_Object xfont,
 237                                                     Error_behavior errb);
 238
 239 static Lisp_Object
 240 mark_font_instance (Lisp_Object obj)
 241 {
 242   Lisp_Font_Instance *f = XFONT_INSTANCE (obj);
 243
 244   mark_object (f->name);
 245   if (!NILP (f->device)) /* Vthe_null_font_instance */
 246     MAYBE_DEVMETH (XDEVICE (f->device), mark_font_instance, (f));
 247
 248   return f->device;
 249 }
 250
 251 static void
 252 print_font_instance (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 253 {
 254   char buf[200];
 255   Lisp_Font_Instance *f = XFONT_INSTANCE (obj);
 256   if (print_readably)
 257     error ("printing unreadable object #<font-instance 0x%x>", f->header.uid);
 258   write_c_string ("#<font-instance ", printcharfun);
 259   print_internal (f->name, printcharfun, 1);
 260   write_c_string (" on ", printcharfun);
 261   print_internal (f->device, printcharfun, 0);
 262   if (!NILP (f->device))
 263     MAYBE_DEVMETH (XDEVICE (f->device), print_font_instance,
 264                    (f, printcharfun, escapeflag));
 265   sprintf (buf, " 0x%x>", f->header.uid);
 266   write_c_string (buf, printcharfun);
 267 }
 268
 269 static void
 270 finalize_font_instance (void *header, int for_disksave)
 271 {
 272   Lisp_Font_Instance *f = (Lisp_Font_Instance *) header;
 273
 274   if (!NILP (f->device))
 275     {
 276       if (for_disksave) finalose (f);
 277       MAYBE_DEVMETH (XDEVICE (f->device), finalize_font_instance, (f));
 278     }
 279 }
 280
 281 /* Fonts are equal if they resolve to the same name.
 282    Since we call `font-truename' to do this, and since font-truename is lazy,
 283    this means the `equal' could cause XListFonts to be run the first time.
 284  */
 285 static int
 286 font_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
 287 {
 288   /* #### should this be moved into a device method? */
 289   return internal_equal (font_instance_truename_internal (obj1, ERROR_ME_NOT),
 290                          font_instance_truename_internal (obj2, ERROR_ME_NOT),
 291                          depth + 1);
 292 }
 293
 294 static unsigned long
 295 font_instance_hash (Lisp_Object obj, int depth)
 296 {
 297   return internal_hash (font_instance_truename_internal (obj, ERROR_ME_NOT),
 298                         depth + 1);
 299 }
 300
 301 DEFINE_LRECORD_IMPLEMENTATION ("font-instance", font_instance,
 302                                mark_font_instance, print_font_instance,
 303                                finalize_font_instance, font_instance_equal,
 304                                font_instance_hash, 0, Lisp_Font_Instance);
 305 \f
 306 DEFUN ("make-font-instance", Fmake_font_instance, 1, 3, 0, /*
 307 Return a new `font-instance' object named NAME.
 308 DEVICE specifies the device this object applies to and defaults to the
 309 selected device.  An error is signalled if the font is unknown or cannot
 310 be allocated; however, if NOERROR is non-nil, nil is simply returned in
 311 this case.
 312
 313 The returned object is a normal, first-class lisp object.  The way you
 314 `deallocate' the font is the way you deallocate any other lisp object:
 315 you drop all pointers to it and allow it to be garbage collected.  When
 316 these objects are GCed, the underlying X data is deallocated as well.
 317 */
 318        (name, device, noerror))
 319 {
 320   Lisp_Font_Instance *f;
 321   Lisp_Object val;
 322   int retval = 0;
 323   Error_behavior errb = decode_error_behavior_flag (noerror);
 324
 325   if (ERRB_EQ (errb, ERROR_ME))
 326     CHECK_STRING (name);
 327   else if (!STRINGP (name))
 328     return Qnil;
 329
 330   XSETDEVICE (device, decode_device (device));
 331
 332   f = alloc_lcrecord_type (Lisp_Font_Instance, &lrecord_font_instance);
 333   f->name = name;
 334   f->device = device;
 335
 336   f->data = 0;
 337
 338   /* Stick some default values here ... */
 339   f->ascent = f->height = 1;
 340   f->descent = 0;
 341   f->width = 1;
 342   f->proportional_p = 0;
 343
 344   retval = MAYBE_INT_DEVMETH (XDEVICE (device), initialize_font_instance,
 345                               (f, name, device, errb));
 346
 347   if (!retval)
 348     return Qnil;
 349
 350   XSETFONT_INSTANCE (val, f);
 351   return val;
 352 }
 353
 354 DEFUN ("font-instance-p", Ffont_instance_p, 1, 1, 0, /*
 355 Return non-nil if OBJECT is a font instance.
 356 */
 357        (object))
 358 {
 359   return FONT_INSTANCEP (object) ? Qt : Qnil;
 360 }
 361
 362 DEFUN ("font-instance-name", Ffont_instance_name, 1, 1, 0, /*
 363 Return the name used to allocate FONT-INSTANCE.
 364 */
 365        (font_instance))
 366 {
 367   CHECK_FONT_INSTANCE (font_instance);
 368   return XFONT_INSTANCE (font_instance)->name;
 369 }
 370
 371 DEFUN ("font-instance-ascent", Ffont_instance_ascent, 1, 1, 0, /*
 372 Return the ascent in pixels of FONT-INSTANCE.
 373 The returned value is the maximum ascent for all characters in the font,
 374 where a character's ascent is the number of pixels above (and including)
 375 the baseline.
 376 */
 377        (font_instance))
 378 {
 379   CHECK_FONT_INSTANCE (font_instance);
 380   return make_int (XFONT_INSTANCE (font_instance)->ascent);
 381 }
 382
 383 DEFUN ("font-instance-descent", Ffont_instance_descent, 1, 1, 0, /*
 384 Return the descent in pixels of FONT-INSTANCE.
 385 The returned value is the maximum descent for all characters in the font,
 386 where a character's descent is the number of pixels below the baseline.
 387 \(Many characters to do not have any descent.  Typical characters with a
 388 descent are lowercase p and lowercase g.)
 389 */
 390        (font_instance))
 391 {
 392   CHECK_FONT_INSTANCE (font_instance);
 393   return make_int (XFONT_INSTANCE (font_instance)->descent);
 394 }
 395
 396 DEFUN ("font-instance-width", Ffont_instance_width, 1, 1, 0, /*
 397 Return the width in pixels of FONT-INSTANCE.
 398 The returned value is the average width for all characters in the font.
 399 */
 400        (font_instance))
 401 {
 402   CHECK_FONT_INSTANCE (font_instance);
 403   return make_int (XFONT_INSTANCE (font_instance)->width);
 404 }
 405
 406 DEFUN ("font-instance-proportional-p", Ffont_instance_proportional_p, 1, 1, 0, /*
 407 Return whether FONT-INSTANCE is proportional.
 408 This means that different characters in the font have different widths.
 409 */
 410        (font_instance))
 411 {
 412   CHECK_FONT_INSTANCE (font_instance);
 413   return XFONT_INSTANCE (font_instance)->proportional_p ? Qt : Qnil;
 414 }
 415
 416 static Lisp_Object
 417 font_instance_truename_internal (Lisp_Object font_instance,
 418                                  Error_behavior errb)
 419 {
 420   Lisp_Font_Instance *f = XFONT_INSTANCE (font_instance);
 421
 422   if (NILP (f->device))
 423     {
 424       maybe_signal_simple_error ("Couldn't determine font truename",
 425                                  font_instance, Qfont, errb);
 426       return Qnil;
 427     }
 428
 429   return DEVMETH_OR_GIVEN (XDEVICE (f->device),
 430                            font_instance_truename, (f, errb), f->name);
 431 }
 432
 433 DEFUN ("font-instance-truename", Ffont_instance_truename, 1, 1, 0, /*
 434 Return the canonical name of FONT-INSTANCE.
 435 Font names are patterns which may match any number of fonts, of which
 436 the first found is used.  This returns an unambiguous name for that font
 437 \(but not necessarily its only unambiguous name).
 438 */
 439        (font_instance))
 440 {
 441   CHECK_FONT_INSTANCE (font_instance);
 442   return font_instance_truename_internal (font_instance, ERROR_ME);
 443 }
 444
 445 DEFUN ("font-instance-properties", Ffont_instance_properties, 1, 1, 0, /*
 446 Return the properties (an alist or nil) of FONT-INSTANCE.
 447 */
 448        (font_instance))
 449 {
 450   Lisp_Font_Instance *f;
 451
 452   CHECK_FONT_INSTANCE (font_instance);
 453   f = XFONT_INSTANCE (font_instance);
 454
 455   if (NILP (f->device))
 456     return Qnil;
 457
 458   return MAYBE_LISP_DEVMETH (XDEVICE (f->device),
 459                              font_instance_properties, (f));
 460 }
 461
 462 DEFUN ("list-fonts", Flist_fonts, 1, 2, 0, /*
 463 Return a list of font names matching the given pattern.
 464 DEVICE specifies which device to search for names, and defaults to the
 465 currently selected device.
 466 */
 467        (pattern, device))
 468 {
 469   CHECK_STRING (pattern);
 470   XSETDEVICE (device, decode_device (device));
 471
 472   return MAYBE_LISP_DEVMETH (XDEVICE (device), list_fonts, (pattern, device));
 473 }
 474
 475 \f
 476 /****************************************************************************
 477  Color Object
 478  ***************************************************************************/
 479 DEFINE_SPECIFIER_TYPE (color);
 480 /* Qcolor defined in general.c */
 481
 482 static void
 483 color_create (Lisp_Object obj)
 484 {
 485   Lisp_Specifier *color = XCOLOR_SPECIFIER (obj);
 486
 487   COLOR_SPECIFIER_FACE (color) = Qnil;
 488   COLOR_SPECIFIER_FACE_PROPERTY (color) = Qnil;
 489 }
 490
 491 static void
 492 color_mark (Lisp_Object obj)
 493 {
 494   Lisp_Specifier *color = XCOLOR_SPECIFIER (obj);
 495
 496   mark_object (COLOR_SPECIFIER_FACE (color));
 497   mark_object (COLOR_SPECIFIER_FACE_PROPERTY (color));
 498 }
 499
 500 /* No equal or hash methods; ignore the face the color is based off
 501    of for `equal' */
 502
 503 static Lisp_Object
 504 color_instantiate (Lisp_Object specifier, Lisp_Object matchspec,
 505                    Lisp_Object domain, Lisp_Object instantiator,
 506                    Lisp_Object depth)
 507 {
 508   /* When called, we're inside of call_with_suspended_errors(),
 509      so we can freely error. */
 510   Lisp_Object device = DOMAIN_DEVICE (domain);
 511   struct device *d = XDEVICE (device);
 512
 513   if (COLOR_INSTANCEP (instantiator))
 514     {
 515       /* If we are on the same device then we're done.  Otherwise change
 516          the instantiator to the name used to generate the pixel and let the
 517          STRINGP case deal with it. */
 518       if (NILP (device) /* Vthe_null_color_instance */
 519           || EQ (device, XCOLOR_INSTANCE (instantiator)->device))
 520         return instantiator;
 521       else
 522         instantiator = Fcolor_instance_name (instantiator);
 523     }
 524
 525   if (STRINGP (instantiator))
 526     {
 527       /* First, look to see if we can retrieve a cached value. */
 528       Lisp_Object instance =
 529         Fgethash (instantiator, d->color_instance_cache, Qunbound);
 530       /* Otherwise, make a new one. */
 531       if (UNBOUNDP (instance))
 532         {
 533           /* make sure we cache the failures, too. */
 534           instance = Fmake_color_instance (instantiator, device, Qt);
 535           Fputhash (instantiator, instance, d->color_instance_cache);
 536         }
 537
 538       return NILP (instance) ? Qunbound : instance;
 539     }
 540   else if (VECTORP (instantiator))
 541     {
 542       switch (XVECTOR_LENGTH (instantiator))
 543         {
 544         case 0:
 545           if (DEVICE_TTY_P (d))
 546             return Vthe_null_color_instance;
 547           else
 548             signal_simple_error ("Color instantiator [] only valid on TTY's",
 549                                  device);
 550
 551         case 1:
 552           if (NILP (COLOR_SPECIFIER_FACE (XCOLOR_SPECIFIER (specifier))))
 553             signal_simple_error ("Color specifier not attached to a face",
 554                                  instantiator);
 555           return (FACE_PROPERTY_INSTANCE_1
 556                   (Fget_face (XVECTOR_DATA (instantiator)[0]),
 557                    COLOR_SPECIFIER_FACE_PROPERTY (XCOLOR_SPECIFIER (specifier)),
 558                    domain, ERROR_ME, 0, depth));
 559
 560         case 2:
 561           return (FACE_PROPERTY_INSTANCE_1
 562                   (Fget_face (XVECTOR_DATA (instantiator)[0]),
 563                    XVECTOR_DATA (instantiator)[1], domain, ERROR_ME, 0, depth));
 564
 565         default:
 566           abort ();
 567         }
 568     }
 569   else if (NILP (instantiator))
 570     {
 571       if (DEVICE_TTY_P (d))
 572         return Vthe_null_color_instance;
 573       else
 574         signal_simple_error ("Color instantiator [] only valid on TTY's",
 575                              device);
 576     }
 577   else
 578     abort ();   /* The spec validation routines are screwed up. */
 579
 580   return Qunbound;
 581 }
 582
 583 static void
 584 color_validate (Lisp_Object instantiator)
 585 {
 586   if (COLOR_INSTANCEP (instantiator) || STRINGP (instantiator))
 587     return;
 588   if (VECTORP (instantiator))
 589     {
 590       if (XVECTOR_LENGTH (instantiator) > 2)
 591         signal_simple_error ("Inheritance vector must be of size 0 - 2",
 592                              instantiator);
 593       else if (XVECTOR_LENGTH (instantiator) > 0)
 594         {
 595           Lisp_Object face = XVECTOR_DATA (instantiator)[0];
 596
 597           Fget_face (face);
 598           if (XVECTOR_LENGTH (instantiator) == 2)
 599             {
 600               Lisp_Object field = XVECTOR_DATA (instantiator)[1];
 601               if (!EQ (field, Qforeground) && !EQ (field, Qbackground))
 602                 signal_simple_error
 603                   ("Inheritance field must be `foreground' or `background'",
 604                    field);
 605             }
 606         }
 607     }
 608   else
 609     signal_simple_error ("Invalid color instantiator", instantiator);
 610 }
 611
 612 static void
 613 color_after_change (Lisp_Object specifier, Lisp_Object locale)
 614 {
 615   Lisp_Object face = COLOR_SPECIFIER_FACE (XCOLOR_SPECIFIER (specifier));
 616   Lisp_Object property =
 617     COLOR_SPECIFIER_FACE_PROPERTY (XCOLOR_SPECIFIER (specifier));
 618   if (!NILP (face))
 619     {
 620       face_property_was_changed (face, property, locale);
 621       if (BUFFERP (locale))
 622         XBUFFER (locale)->buffer_local_face_property = 1;
 623     }
 624 }
 625
 626 void
 627 set_color_attached_to (Lisp_Object obj, Lisp_Object face, Lisp_Object property)
 628 {
 629   Lisp_Specifier *color = XCOLOR_SPECIFIER (obj);
 630
 631   COLOR_SPECIFIER_FACE (color) = face;
 632   COLOR_SPECIFIER_FACE_PROPERTY (color) = property;
 633 }
 634
 635 DEFUN ("color-specifier-p", Fcolor_specifier_p, 1, 1, 0, /*
 636 Return t if OBJECT is a color specifier.
 637
 638 See `make-color-specifier' for a description of possible color instantiators.
 639 */
 640        (object))
 641 {
 642   return COLOR_SPECIFIERP (object) ? Qt : Qnil;
 643 }
 644
 645 \f
 646 /****************************************************************************
 647  Font Object
 648  ***************************************************************************/
 649 DEFINE_SPECIFIER_TYPE (font);
 650 /* Qfont defined in general.c */
 651
 652 static void
 653 font_create (Lisp_Object obj)
 654 {
 655   Lisp_Specifier *font = XFONT_SPECIFIER (obj);
 656
 657   FONT_SPECIFIER_FACE (font) = Qnil;
 658   FONT_SPECIFIER_FACE_PROPERTY (font) = Qnil;
 659 }
 660
 661 static void
 662 font_mark (Lisp_Object obj)
 663 {
 664   Lisp_Specifier *font = XFONT_SPECIFIER (obj);
 665
 666   mark_object (FONT_SPECIFIER_FACE (font));
 667   mark_object (FONT_SPECIFIER_FACE_PROPERTY (font));
 668 }
 669
 670 /* No equal or hash methods; ignore the face the font is based off
 671    of for `equal' */
 672
 673 #ifdef MULE
 674
 675 int
 676 font_spec_matches_charset (struct device *d, Lisp_Object charset,
 677                            const Bufbyte *nonreloc, Lisp_Object reloc,
 678                            Bytecount offset, Bytecount length)
 679 {
 680   return DEVMETH_OR_GIVEN (d, font_spec_matches_charset,
 681                            (d, charset, nonreloc, reloc, offset, length),
 682                            1);
 683 }
 684
 685 static void
 686 font_validate_matchspec (Lisp_Object matchspec)
 687 {
 688   Fget_charset (matchspec);
 689 }
 690
 691 #endif /* MULE */
 692
 693
 694 static Lisp_Object
 695 font_instantiate (Lisp_Object specifier, Lisp_Object matchspec,
 696                   Lisp_Object domain, Lisp_Object instantiator,
 697                   Lisp_Object depth)
 698 {
 699   /* When called, we're inside of call_with_suspended_errors(),
 700      so we can freely error. */
 701   Lisp_Object device = DOMAIN_DEVICE (domain);
 702   struct device *d = XDEVICE (device);
 703   Lisp_Object instance;
 704
 705 #ifdef MULE
 706   if (!UNBOUNDP (matchspec))
 707     matchspec = Fget_charset (matchspec);
 708 #endif
 709
 710   if (FONT_INSTANCEP (instantiator))
 711     {
 712       if (NILP (device)
 713           || EQ (device, XFONT_INSTANCE (instantiator)->device))
 714         {
 715 #ifdef MULE
 716           if (font_spec_matches_charset (d, matchspec, 0,
 717                                          Ffont_instance_truename
 718                                          (instantiator),
 719                                          0, -1))
 720             return instantiator;
 721 #else
 722           return instantiator;
 723 #endif
 724         }
 725       instantiator = Ffont_instance_name (instantiator);
 726     }
 727
 728   if (STRINGP (instantiator))
 729     {
 730 #ifdef MULE
 731       if (!UNBOUNDP (matchspec))
 732         {
 733           /* The instantiator is a font spec that could match many
 734              different fonts.  We need to find one of those fonts
 735              whose registry matches the registry of the charset in
 736              MATCHSPEC.  This is potentially a very slow operation,
 737              as it involves doing an XListFonts() or equivalent to
 738              iterate over all possible fonts, and a regexp match
 739              on each one.  So we cache the results. */
 740           Lisp_Object matching_font = Qunbound;
 741           Lisp_Object hash_table = Fgethash (matchspec, d->charset_font_cache,
 742                                           Qunbound);
 743           if (UNBOUNDP (hash_table))
 744             {
 745               /* need to make a sub hash table. */
 746               hash_table = make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK,
 747                                                  HASH_TABLE_EQUAL);
 748               Fputhash (matchspec, hash_table, d->charset_font_cache);
 749             }
 750           else
 751             matching_font = Fgethash (instantiator, hash_table, Qunbound);
 752
 753           if (UNBOUNDP (matching_font))
 754             {
 755               /* make sure we cache the failures, too. */
 756               matching_font =
 757                 DEVMETH_OR_GIVEN (d, find_charset_font,
 758                                   (device, instantiator, matchspec),
 759                                   instantiator);
 760               Fputhash (instantiator, matching_font, hash_table);
 761             }
 762           if (NILP (matching_font))
 763             return Qunbound;
 764           instantiator = matching_font;
 765         }
 766 #endif /* MULE */
 767
 768       /* First, look to see if we can retrieve a cached value. */
 769       instance = Fgethash (instantiator, d->font_instance_cache, Qunbound);
 770       /* Otherwise, make a new one. */
 771       if (UNBOUNDP (instance))
 772         {
 773           /* make sure we cache the failures, too. */
 774           instance = Fmake_font_instance (instantiator, device, Qt);
 775           Fputhash (instantiator, instance, d->font_instance_cache);
 776         }
 777
 778       return NILP (instance) ? Qunbound : instance;
 779     }
 780   else if (VECTORP (instantiator))
 781     {
 782       assert (XVECTOR_LENGTH (instantiator) == 1);
 783       return (face_property_matching_instance
 784               (Fget_face (XVECTOR_DATA (instantiator)[0]), Qfont,
 785                matchspec, domain, ERROR_ME, 0, depth));
 786     }
 787   else if (NILP (instantiator))
 788     return Qunbound;
 789   else
 790     abort ();   /* Eh? */
 791
 792   return Qunbound;
 793 }
 794
 795 static void
 796 font_validate (Lisp_Object instantiator)
 797 {
 798   if (FONT_INSTANCEP (instantiator) || STRINGP (instantiator))
 799     return;
 800   if (VECTORP (instantiator))
 801     {
 802       if (XVECTOR_LENGTH (instantiator) != 1)
 803         {
 804           signal_simple_error
 805             ("Vector length must be one for font inheritance", instantiator);
 806         }
 807       Fget_face (XVECTOR_DATA (instantiator)[0]);
 808     }
 809   else
 810     signal_simple_error ("Must be string, vector, or font-instance",
 811                          instantiator);
 812 }
 813
 814 static void
 815 font_after_change (Lisp_Object specifier, Lisp_Object locale)
 816 {
 817   Lisp_Object face = FONT_SPECIFIER_FACE (XFONT_SPECIFIER (specifier));
 818   Lisp_Object property =
 819     FONT_SPECIFIER_FACE_PROPERTY (XFONT_SPECIFIER (specifier));
 820   if (!NILP (face))
 821     {
 822       face_property_was_changed (face, property, locale);
 823       if (BUFFERP (locale))
 824         XBUFFER (locale)->buffer_local_face_property = 1;
 825     }
 826 }
 827
 828 void
 829 set_font_attached_to (Lisp_Object obj, Lisp_Object face, Lisp_Object property)
 830 {
 831   Lisp_Specifier *font = XFONT_SPECIFIER (obj);
 832
 833   FONT_SPECIFIER_FACE (font) = face;
 834   FONT_SPECIFIER_FACE_PROPERTY (font) = property;
 835 }
 836
 837 DEFUN ("font-specifier-p", Ffont_specifier_p, 1, 1, 0, /*
 838 Return non-nil if OBJECT is a font specifier.
 839
 840 See `make-font-specifier' for a description of possible font instantiators.
 841 */
 842        (object))
 843 {
 844   return FONT_SPECIFIERP (object) ? Qt : Qnil;
 845 }
 846
 847 \f
 848 /*****************************************************************************
 849  Face Boolean Object
 850  ****************************************************************************/
 851 DEFINE_SPECIFIER_TYPE (face_boolean);
 852 Lisp_Object Qface_boolean;
 853
 854 static void
 855 face_boolean_create (Lisp_Object obj)
 856 {
 857   Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj);
 858
 859   FACE_BOOLEAN_SPECIFIER_FACE (face_boolean) = Qnil;
 860   FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean) = Qnil;
 861 }
 862
 863 static void
 864 face_boolean_mark (Lisp_Object obj)
 865 {
 866   Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj);
 867
 868   mark_object (FACE_BOOLEAN_SPECIFIER_FACE (face_boolean));
 869   mark_object (FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean));
 870 }
 871
 872 /* No equal or hash methods; ignore the face the face-boolean is based off
 873    of for `equal' */
 874
 875 static Lisp_Object
 876 face_boolean_instantiate (Lisp_Object specifier, Lisp_Object matchspec,
 877                           Lisp_Object domain, Lisp_Object instantiator,
 878                           Lisp_Object depth)
 879 {
 880   /* When called, we're inside of call_with_suspended_errors(),
 881      so we can freely error. */
 882   if (NILP (instantiator) || EQ (instantiator, Qt))
 883     return instantiator;
 884   else if (VECTORP (instantiator))
 885     {
 886       Lisp_Object retval;
 887       Lisp_Object prop;
 888       int instantiator_len = XVECTOR_LENGTH (instantiator);
 889
 890       assert (instantiator_len >= 1 && instantiator_len <= 3);
 891       if (instantiator_len > 1)
 892         prop = XVECTOR_DATA (instantiator)[1];
 893       else
 894         {
 895           if (NILP (FACE_BOOLEAN_SPECIFIER_FACE
 896                     (XFACE_BOOLEAN_SPECIFIER (specifier))))
 897             signal_simple_error
 898               ("Face-boolean specifier not attached to a face", instantiator);
 899           prop = FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY
 900             (XFACE_BOOLEAN_SPECIFIER (specifier));
 901         }
 902
 903       retval = (FACE_PROPERTY_INSTANCE_1
 904                 (Fget_face (XVECTOR_DATA (instantiator)[0]),
 905                  prop, domain, ERROR_ME, 0, depth));
 906
 907       if (instantiator_len == 3 && !NILP (XVECTOR_DATA (instantiator)[2]))
 908         retval = NILP (retval) ? Qt : Qnil;
 909
 910       return retval;
 911     }
 912   else
 913     abort ();   /* Eh? */
 914
 915   return Qunbound;
 916 }
 917
 918 static void
 919 face_boolean_validate (Lisp_Object instantiator)
 920 {
 921   if (NILP (instantiator) || EQ (instantiator, Qt))
 922     return;
 923   else if (VECTORP (instantiator) &&
 924            (XVECTOR_LENGTH (instantiator) >= 1 &&
 925             XVECTOR_LENGTH (instantiator) <= 3))
 926     {
 927       Lisp_Object face = XVECTOR_DATA (instantiator)[0];
 928
 929       Fget_face (face);
 930
 931       if (XVECTOR_LENGTH (instantiator) > 1)
 932         {
 933           Lisp_Object field = XVECTOR_DATA (instantiator)[1];
 934           if (!EQ (field, Qunderline)
 935               && !EQ (field, Qstrikethru)
 936               && !EQ (field, Qhighlight)
 937               && !EQ (field, Qdim)
 938               && !EQ (field, Qblinking)
 939               && !EQ (field, Qreverse))
 940             signal_simple_error ("Invalid face-boolean inheritance field",
 941                                  field);
 942         }
 943     }
 944   else if (VECTORP (instantiator))
 945     signal_simple_error ("Wrong length for face-boolean inheritance spec",
 946                          instantiator);
 947   else
 948     signal_simple_error ("Face-boolean instantiator must be nil, t, or vector",
 949                          instantiator);
 950 }
 951
 952 static void
 953 face_boolean_after_change (Lisp_Object specifier, Lisp_Object locale)
 954 {
 955   Lisp_Object face =
 956     FACE_BOOLEAN_SPECIFIER_FACE (XFACE_BOOLEAN_SPECIFIER (specifier));
 957   Lisp_Object property =
 958     FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (XFACE_BOOLEAN_SPECIFIER (specifier));
 959   if (!NILP (face))
 960     {
 961       face_property_was_changed (face, property, locale);
 962       if (BUFFERP (locale))
 963         XBUFFER (locale)->buffer_local_face_property = 1;
 964     }
 965 }
 966
 967 void
 968 set_face_boolean_attached_to (Lisp_Object obj, Lisp_Object face,
 969                               Lisp_Object property)
 970 {
 971   Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj);
 972
 973   FACE_BOOLEAN_SPECIFIER_FACE (face_boolean) = face;
 974   FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean) = property;
 975 }
 976
 977 DEFUN ("face-boolean-specifier-p", Fface_boolean_specifier_p, 1, 1, 0, /*
 978 Return non-nil if OBJECT is a face-boolean specifier.
 979
 980 See `make-face-boolean-specifier' for a description of possible
 981 face-boolean instantiators.
 982 */
 983        (object))
 984 {
 985   return FACE_BOOLEAN_SPECIFIERP (object) ? Qt : Qnil;
 986 }
 987
 988 \f
 989 /************************************************************************/
 990 /*                            initialization                            */
 991 /************************************************************************/
 992
 993 void
 994 syms_of_objects (void)
 995 {
 996   INIT_LRECORD_IMPLEMENTATION (color_instance);
 997   INIT_LRECORD_IMPLEMENTATION (font_instance);
 998
 999   DEFSUBR (Fcolor_specifier_p);
1000   DEFSUBR (Ffont_specifier_p);
1001   DEFSUBR (Fface_boolean_specifier_p);
1002
1003   defsymbol (&Qcolor_instancep, "color-instance-p");
1004   DEFSUBR (Fmake_color_instance);
1005   DEFSUBR (Fcolor_instance_p);
1006   DEFSUBR (Fcolor_instance_name);
1007   DEFSUBR (Fcolor_instance_rgb_components);
1008   DEFSUBR (Fvalid_color_name_p);
1009
1010   defsymbol (&Qfont_instancep, "font-instance-p");
1011   DEFSUBR (Fmake_font_instance);
1012   DEFSUBR (Ffont_instance_p);
1013   DEFSUBR (Ffont_instance_name);
1014   DEFSUBR (Ffont_instance_ascent);
1015   DEFSUBR (Ffont_instance_descent);
1016   DEFSUBR (Ffont_instance_width);
1017   DEFSUBR (Ffont_instance_proportional_p);
1018   DEFSUBR (Ffont_instance_truename);
1019   DEFSUBR (Ffont_instance_properties);
1020   DEFSUBR (Flist_fonts);
1021
1022   /* Qcolor, Qfont defined in general.c */
1023   defsymbol (&Qface_boolean, "face-boolean");
1024 }
1025
1026 static const struct lrecord_description color_specifier_description[] = {
1027   { XD_LISP_OBJECT, specifier_data_offset + offsetof (struct color_specifier, face) },
1028   { XD_LISP_OBJECT, specifier_data_offset + offsetof (struct color_specifier, face_property) },
1029   { XD_END }
1030 };
1031
1032 static const struct lrecord_description font_specifier_description[] = {
1033   { XD_LISP_OBJECT, specifier_data_offset + offsetof (struct font_specifier, face) },
1034   { XD_LISP_OBJECT, specifier_data_offset + offsetof (struct font_specifier, face_property) },
1035   { XD_END }
1036 };
1037
1038 static const struct lrecord_description face_boolean_specifier_description[] = {
1039   { XD_LISP_OBJECT, specifier_data_offset + offsetof (struct face_boolean_specifier, face) },
1040   { XD_LISP_OBJECT, specifier_data_offset + offsetof (struct face_boolean_specifier, face_property) },
1041   { XD_END }
1042 };
1043
1044 void
1045 specifier_type_create_objects (void)
1046 {
1047   INITIALIZE_SPECIFIER_TYPE_WITH_DATA (color, "color", "color-specifier-p");
1048   INITIALIZE_SPECIFIER_TYPE_WITH_DATA (font, "font", "font-specifier-p");
1049   INITIALIZE_SPECIFIER_TYPE_WITH_DATA (face_boolean, "face-boolean",
1050                                          "face-boolean-specifier-p");
1051
1052   SPECIFIER_HAS_METHOD (color, instantiate);
1053   SPECIFIER_HAS_METHOD (font, instantiate);
1054   SPECIFIER_HAS_METHOD (face_boolean, instantiate);
1055
1056   SPECIFIER_HAS_METHOD (color, validate);
1057   SPECIFIER_HAS_METHOD (font, validate);
1058   SPECIFIER_HAS_METHOD (face_boolean, validate);
1059
1060   SPECIFIER_HAS_METHOD (color, create);
1061   SPECIFIER_HAS_METHOD (font, create);
1062   SPECIFIER_HAS_METHOD (face_boolean, create);
1063
1064   SPECIFIER_HAS_METHOD (color, mark);
1065   SPECIFIER_HAS_METHOD (font, mark);
1066   SPECIFIER_HAS_METHOD (face_boolean, mark);
1067
1068   SPECIFIER_HAS_METHOD (color, after_change);
1069   SPECIFIER_HAS_METHOD (font, after_change);
1070   SPECIFIER_HAS_METHOD (face_boolean, after_change);
1071
1072 #ifdef MULE
1073   SPECIFIER_HAS_METHOD (font, validate_matchspec);
1074 #endif
1075 }
1076
1077 void
1078 reinit_specifier_type_create_objects (void)
1079 {
1080   REINITIALIZE_SPECIFIER_TYPE (color);
1081   REINITIALIZE_SPECIFIER_TYPE (font);
1082   REINITIALIZE_SPECIFIER_TYPE (face_boolean);
1083 }
1084
1085 void
1086 reinit_vars_of_objects (void)
1087 {
1088   staticpro_nodump (&Vthe_null_color_instance);
1089   {
1090     Lisp_Color_Instance *c =
1091       alloc_lcrecord_type (Lisp_Color_Instance, &lrecord_color_instance);
1092     c->name = Qnil;
1093     c->device = Qnil;
1094     c->data = 0;
1095
1096     XSETCOLOR_INSTANCE (Vthe_null_color_instance, c);
1097   }
1098
1099   staticpro_nodump (&Vthe_null_font_instance);
1100   {
1101     Lisp_Font_Instance *f =
1102       alloc_lcrecord_type (Lisp_Font_Instance, &lrecord_font_instance);
1103     f->name = Qnil;
1104     f->device = Qnil;
1105     f->data = 0;
1106
1107     f->ascent = f->height = 0;
1108     f->descent = 0;
1109     f->width = 0;
1110     f->proportional_p = 0;
1111
1112     XSETFONT_INSTANCE (Vthe_null_font_instance, f);
1113   }
1114 }
1115
1116 void
1117 vars_of_objects (void)
1118 {
1119   reinit_vars_of_objects ();
1120 }