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, Lisp_Type_Record, 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 NO-ERROR is non-nil, nil is simply
 141 returned in this case. (And if NO-ERROR 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, no_error))
 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 (no_error)));
 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, no_error))
 319 {
 320   Lisp_Font_Instance *f;
 321   Lisp_Object val;
 322   int retval = 0;
 323   Error_behavior errb = decode_error_behavior_flag (no_error);
 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     face_property_was_changed (face, property, locale);
 620 }
 621
 622 void
 623 set_color_attached_to (Lisp_Object obj, Lisp_Object face, Lisp_Object property)
 624 {
 625   Lisp_Specifier *color = XCOLOR_SPECIFIER (obj);
 626
 627   COLOR_SPECIFIER_FACE (color) = face;
 628   COLOR_SPECIFIER_FACE_PROPERTY (color) = property;
 629 }
 630
 631 DEFUN ("color-specifier-p", Fcolor_specifier_p, 1, 1, 0, /*
 632 Return t if OBJECT is a color specifier.
 633
 634 See `make-color-specifier' for a description of possible color instantiators.
 635 */
 636        (object))
 637 {
 638   return COLOR_SPECIFIERP (object) ? Qt : Qnil;
 639 }
 640
 641 \f
 642 /****************************************************************************
 643  Font Object
 644  ***************************************************************************/
 645 DEFINE_SPECIFIER_TYPE (font);
 646 /* Qfont defined in general.c */
 647
 648 static void
 649 font_create (Lisp_Object obj)
 650 {
 651   Lisp_Specifier *font = XFONT_SPECIFIER (obj);
 652
 653   FONT_SPECIFIER_FACE (font) = Qnil;
 654   FONT_SPECIFIER_FACE_PROPERTY (font) = Qnil;
 655 }
 656
 657 static void
 658 font_mark (Lisp_Object obj)
 659 {
 660   Lisp_Specifier *font = XFONT_SPECIFIER (obj);
 661
 662   mark_object (FONT_SPECIFIER_FACE (font));
 663   mark_object (FONT_SPECIFIER_FACE_PROPERTY (font));
 664 }
 665
 666 /* No equal or hash methods; ignore the face the font is based off
 667    of for `equal' */
 668
 669 #ifdef MULE
 670
 671 int
 672 font_spec_matches_charset (struct device *d, Lisp_Object charset,
 673                            const Bufbyte *nonreloc, Lisp_Object reloc,
 674                            Bytecount offset, Bytecount length)
 675 {
 676   return DEVMETH_OR_GIVEN (d, font_spec_matches_charset,
 677                            (d, charset, nonreloc, reloc, offset, length),
 678                            1);
 679 }
 680
 681 static void
 682 font_validate_matchspec (Lisp_Object matchspec)
 683 {
 684   Fget_charset (matchspec);
 685 }
 686
 687 #endif /* MULE */
 688
 689
 690 static Lisp_Object
 691 font_instantiate (Lisp_Object specifier, Lisp_Object matchspec,
 692                   Lisp_Object domain, Lisp_Object instantiator,
 693                   Lisp_Object depth)
 694 {
 695   /* When called, we're inside of call_with_suspended_errors(),
 696      so we can freely error. */
 697   Lisp_Object device = DOMAIN_DEVICE (domain);
 698   struct device *d = XDEVICE (device);
 699   Lisp_Object instance;
 700
 701 #ifdef MULE
 702   if (!UNBOUNDP (matchspec))
 703     matchspec = Fget_charset (matchspec);
 704 #endif
 705
 706   if (FONT_INSTANCEP (instantiator))
 707     {
 708       if (NILP (device)
 709           || EQ (device, XFONT_INSTANCE (instantiator)->device))
 710         {
 711 #ifdef MULE
 712           if (font_spec_matches_charset (d, matchspec, 0,
 713                                          Ffont_instance_truename
 714                                          (instantiator),
 715                                          0, -1))
 716             return instantiator;
 717 #else
 718           return instantiator;
 719 #endif
 720         }
 721       instantiator = Ffont_instance_name (instantiator);
 722     }
 723
 724   if (STRINGP (instantiator))
 725     {
 726 #ifdef MULE
 727       if (!UNBOUNDP (matchspec))
 728         {
 729           /* The instantiator is a font spec that could match many
 730              different fonts.  We need to find one of those fonts
 731              whose registry matches the registry of the charset in
 732              MATCHSPEC.  This is potentially a very slow operation,
 733              as it involves doing an XListFonts() or equivalent to
 734              iterate over all possible fonts, and a regexp match
 735              on each one.  So we cache the results. */
 736           Lisp_Object matching_font = Qunbound;
 737           Lisp_Object hash_table = Fgethash (matchspec, d->charset_font_cache,
 738                                           Qunbound);
 739           if (UNBOUNDP (hash_table))
 740             {
 741               /* need to make a sub hash table. */
 742               hash_table = make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK,
 743                                                  HASH_TABLE_EQUAL);
 744               Fputhash (matchspec, hash_table, d->charset_font_cache);
 745             }
 746           else
 747             matching_font = Fgethash (instantiator, hash_table, Qunbound);
 748
 749           if (UNBOUNDP (matching_font))
 750             {
 751               /* make sure we cache the failures, too. */
 752               matching_font =
 753                 DEVMETH_OR_GIVEN (d, find_charset_font,
 754                                   (device, instantiator, matchspec),
 755                                   instantiator);
 756               Fputhash (instantiator, matching_font, hash_table);
 757             }
 758           if (NILP (matching_font))
 759             return Qunbound;
 760           instantiator = matching_font;
 761         }
 762 #endif /* MULE */
 763
 764       /* First, look to see if we can retrieve a cached value. */
 765       instance = Fgethash (instantiator, d->font_instance_cache, Qunbound);
 766       /* Otherwise, make a new one. */
 767       if (UNBOUNDP (instance))
 768         {
 769           /* make sure we cache the failures, too. */
 770           instance = Fmake_font_instance (instantiator, device, Qt);
 771           Fputhash (instantiator, instance, d->font_instance_cache);
 772         }
 773
 774       return NILP (instance) ? Qunbound : instance;
 775     }
 776   else if (VECTORP (instantiator))
 777     {
 778       assert (XVECTOR_LENGTH (instantiator) == 1);
 779       return (face_property_matching_instance
 780               (Fget_face (XVECTOR_DATA (instantiator)[0]), Qfont,
 781                matchspec, domain, ERROR_ME, 0, depth));
 782     }
 783   else if (NILP (instantiator))
 784     return Qunbound;
 785   else
 786     abort ();   /* Eh? */
 787
 788   return Qunbound;
 789 }
 790
 791 static void
 792 font_validate (Lisp_Object instantiator)
 793 {
 794   if (FONT_INSTANCEP (instantiator) || STRINGP (instantiator))
 795     return;
 796   if (VECTORP (instantiator))
 797     {
 798       if (XVECTOR_LENGTH (instantiator) != 1)
 799         {
 800           signal_simple_error
 801             ("Vector length must be one for font inheritance", instantiator);
 802         }
 803       Fget_face (XVECTOR_DATA (instantiator)[0]);
 804     }
 805   else
 806     signal_simple_error ("Must be string, vector, or font-instance",
 807                          instantiator);
 808 }
 809
 810 static void
 811 font_after_change (Lisp_Object specifier, Lisp_Object locale)
 812 {
 813   Lisp_Object face = FONT_SPECIFIER_FACE (XFONT_SPECIFIER (specifier));
 814   Lisp_Object property =
 815     FONT_SPECIFIER_FACE_PROPERTY (XFONT_SPECIFIER (specifier));
 816   if (!NILP (face))
 817     face_property_was_changed (face, property, locale);
 818 }
 819
 820 void
 821 set_font_attached_to (Lisp_Object obj, Lisp_Object face, Lisp_Object property)
 822 {
 823   Lisp_Specifier *font = XFONT_SPECIFIER (obj);
 824
 825   FONT_SPECIFIER_FACE (font) = face;
 826   FONT_SPECIFIER_FACE_PROPERTY (font) = property;
 827 }
 828
 829 DEFUN ("font-specifier-p", Ffont_specifier_p, 1, 1, 0, /*
 830 Return non-nil if OBJECT is a font specifier.
 831
 832 See `make-font-specifier' for a description of possible font instantiators.
 833 */
 834        (object))
 835 {
 836   return FONT_SPECIFIERP (object) ? Qt : Qnil;
 837 }
 838
 839 \f
 840 /*****************************************************************************
 841  Face Boolean Object
 842  ****************************************************************************/
 843 DEFINE_SPECIFIER_TYPE (face_boolean);
 844 Lisp_Object Qface_boolean;
 845
 846 static void
 847 face_boolean_create (Lisp_Object obj)
 848 {
 849   Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj);
 850
 851   FACE_BOOLEAN_SPECIFIER_FACE (face_boolean) = Qnil;
 852   FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean) = Qnil;
 853 }
 854
 855 static void
 856 face_boolean_mark (Lisp_Object obj)
 857 {
 858   Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj);
 859
 860   mark_object (FACE_BOOLEAN_SPECIFIER_FACE (face_boolean));
 861   mark_object (FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean));
 862 }
 863
 864 /* No equal or hash methods; ignore the face the face-boolean is based off
 865    of for `equal' */
 866
 867 static Lisp_Object
 868 face_boolean_instantiate (Lisp_Object specifier, Lisp_Object matchspec,
 869                           Lisp_Object domain, Lisp_Object instantiator,
 870                           Lisp_Object depth)
 871 {
 872   /* When called, we're inside of call_with_suspended_errors(),
 873      so we can freely error. */
 874   if (NILP (instantiator) || EQ (instantiator, Qt))
 875     return instantiator;
 876   else if (VECTORP (instantiator))
 877     {
 878       Lisp_Object retval;
 879       Lisp_Object prop;
 880       int instantiator_len = XVECTOR_LENGTH (instantiator);
 881
 882       assert (instantiator_len >= 1 && instantiator_len <= 3);
 883       if (instantiator_len > 1)
 884         prop = XVECTOR_DATA (instantiator)[1];
 885       else
 886         {
 887           if (NILP (FACE_BOOLEAN_SPECIFIER_FACE
 888                     (XFACE_BOOLEAN_SPECIFIER (specifier))))
 889             signal_simple_error
 890               ("Face-boolean specifier not attached to a face", instantiator);
 891           prop = FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY
 892             (XFACE_BOOLEAN_SPECIFIER (specifier));
 893         }
 894
 895       retval = (FACE_PROPERTY_INSTANCE_1
 896                 (Fget_face (XVECTOR_DATA (instantiator)[0]),
 897                  prop, domain, ERROR_ME, 0, depth));
 898
 899       if (instantiator_len == 3 && !NILP (XVECTOR_DATA (instantiator)[2]))
 900         retval = NILP (retval) ? Qt : Qnil;
 901
 902       return retval;
 903     }
 904   else
 905     abort ();   /* Eh? */
 906
 907   return Qunbound;
 908 }
 909
 910 static void
 911 face_boolean_validate (Lisp_Object instantiator)
 912 {
 913   if (NILP (instantiator) || EQ (instantiator, Qt))
 914     return;
 915   else if (VECTORP (instantiator) &&
 916            (XVECTOR_LENGTH (instantiator) >= 1 &&
 917             XVECTOR_LENGTH (instantiator) <= 3))
 918     {
 919       Lisp_Object face = XVECTOR_DATA (instantiator)[0];
 920
 921       Fget_face (face);
 922
 923       if (XVECTOR_LENGTH (instantiator) > 1)
 924         {
 925           Lisp_Object field = XVECTOR_DATA (instantiator)[1];
 926           if (!EQ (field, Qunderline)
 927               && !EQ (field, Qstrikethru)
 928               && !EQ (field, Qhighlight)
 929               && !EQ (field, Qdim)
 930               && !EQ (field, Qblinking)
 931               && !EQ (field, Qreverse))
 932             signal_simple_error ("Invalid face-boolean inheritance field",
 933                                  field);
 934         }
 935     }
 936   else if (VECTORP (instantiator))
 937     signal_simple_error ("Wrong length for face-boolean inheritance spec",
 938                          instantiator);
 939   else
 940     signal_simple_error ("Face-boolean instantiator must be nil, t, or vector",
 941                          instantiator);
 942 }
 943
 944 static void
 945 face_boolean_after_change (Lisp_Object specifier, Lisp_Object locale)
 946 {
 947   Lisp_Object face =
 948     FACE_BOOLEAN_SPECIFIER_FACE (XFACE_BOOLEAN_SPECIFIER (specifier));
 949   Lisp_Object property =
 950     FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (XFACE_BOOLEAN_SPECIFIER (specifier));
 951   if (!NILP (face))
 952     face_property_was_changed (face, property, locale);
 953 }
 954
 955 void
 956 set_face_boolean_attached_to (Lisp_Object obj, Lisp_Object face,
 957                               Lisp_Object property)
 958 {
 959   Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj);
 960
 961   FACE_BOOLEAN_SPECIFIER_FACE (face_boolean) = face;
 962   FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean) = property;
 963 }
 964
 965 DEFUN ("face-boolean-specifier-p", Fface_boolean_specifier_p, 1, 1, 0, /*
 966 Return non-nil if OBJECT is a face-boolean specifier.
 967
 968 See `make-face-boolean-specifier' for a description of possible
 969 face-boolean instantiators.
 970 */
 971        (object))
 972 {
 973   return FACE_BOOLEAN_SPECIFIERP (object) ? Qt : Qnil;
 974 }
 975
 976 \f
 977 /************************************************************************/
 978 /*                            initialization                            */
 979 /************************************************************************/
 980
 981 void
 982 syms_of_objects (void)
 983 {
 984   INIT_LRECORD_IMPLEMENTATION (color_instance);
 985   INIT_LRECORD_IMPLEMENTATION (font_instance);
 986
 987   DEFSUBR (Fcolor_specifier_p);
 988   DEFSUBR (Ffont_specifier_p);
 989   DEFSUBR (Fface_boolean_specifier_p);
 990
 991   defsymbol (&Qcolor_instancep, "color-instance-p");
 992   DEFSUBR (Fmake_color_instance);
 993   DEFSUBR (Fcolor_instance_p);
 994   DEFSUBR (Fcolor_instance_name);
 995   DEFSUBR (Fcolor_instance_rgb_components);
 996   DEFSUBR (Fvalid_color_name_p);
 997
 998   defsymbol (&Qfont_instancep, "font-instance-p");
 999   DEFSUBR (Fmake_font_instance);
1000   DEFSUBR (Ffont_instance_p);
1001   DEFSUBR (Ffont_instance_name);
1002   DEFSUBR (Ffont_instance_ascent);
1003   DEFSUBR (Ffont_instance_descent);
1004   DEFSUBR (Ffont_instance_width);
1005   DEFSUBR (Ffont_instance_proportional_p);
1006   DEFSUBR (Ffont_instance_truename);
1007   DEFSUBR (Ffont_instance_properties);
1008   DEFSUBR (Flist_fonts);
1009
1010   /* Qcolor, Qfont defined in general.c */
1011   defsymbol (&Qface_boolean, "face-boolean");
1012 }
1013
1014 static const struct lrecord_description color_specifier_description[] = {
1015   { XD_LISP_OBJECT, specifier_data_offset + offsetof (struct color_specifier, face) },
1016   { XD_LISP_OBJECT, specifier_data_offset + offsetof (struct color_specifier, face_property) },
1017   { XD_END }
1018 };
1019
1020 static const struct lrecord_description font_specifier_description[] = {
1021   { XD_LISP_OBJECT, specifier_data_offset + offsetof (struct font_specifier, face) },
1022   { XD_LISP_OBJECT, specifier_data_offset + offsetof (struct font_specifier, face_property) },
1023   { XD_END }
1024 };
1025
1026 static const struct lrecord_description face_boolean_specifier_description[] = {
1027   { XD_LISP_OBJECT, specifier_data_offset + offsetof (struct face_boolean_specifier, face) },
1028   { XD_LISP_OBJECT, specifier_data_offset + offsetof (struct face_boolean_specifier, face_property) },
1029   { XD_END }
1030 };
1031
1032 void
1033 specifier_type_create_objects (void)
1034 {
1035   INITIALIZE_SPECIFIER_TYPE_WITH_DATA (color, "color", "color-specifier-p");
1036   INITIALIZE_SPECIFIER_TYPE_WITH_DATA (font, "font", "font-specifier-p");
1037   INITIALIZE_SPECIFIER_TYPE_WITH_DATA (face_boolean, "face-boolean",
1038                                          "face-boolean-specifier-p");
1039
1040   SPECIFIER_HAS_METHOD (color, instantiate);
1041   SPECIFIER_HAS_METHOD (font, instantiate);
1042   SPECIFIER_HAS_METHOD (face_boolean, instantiate);
1043
1044   SPECIFIER_HAS_METHOD (color, validate);
1045   SPECIFIER_HAS_METHOD (font, validate);
1046   SPECIFIER_HAS_METHOD (face_boolean, validate);
1047
1048   SPECIFIER_HAS_METHOD (color, create);
1049   SPECIFIER_HAS_METHOD (font, create);
1050   SPECIFIER_HAS_METHOD (face_boolean, create);
1051
1052   SPECIFIER_HAS_METHOD (color, mark);
1053   SPECIFIER_HAS_METHOD (font, mark);
1054   SPECIFIER_HAS_METHOD (face_boolean, mark);
1055
1056   SPECIFIER_HAS_METHOD (color, after_change);
1057   SPECIFIER_HAS_METHOD (font, after_change);
1058   SPECIFIER_HAS_METHOD (face_boolean, after_change);
1059
1060 #ifdef MULE
1061   SPECIFIER_HAS_METHOD (font, validate_matchspec);
1062 #endif
1063 }
1064
1065 void
1066 reinit_specifier_type_create_objects (void)
1067 {
1068   REINITIALIZE_SPECIFIER_TYPE (color);
1069   REINITIALIZE_SPECIFIER_TYPE (font);
1070   REINITIALIZE_SPECIFIER_TYPE (face_boolean);
1071 }
1072
1073 void
1074 reinit_vars_of_objects (void)
1075 {
1076   staticpro_nodump (&Vthe_null_color_instance);
1077   {
1078     Lisp_Color_Instance *c =
1079       alloc_lcrecord_type (Lisp_Color_Instance, &lrecord_color_instance);
1080     c->name = Qnil;
1081     c->device = Qnil;
1082     c->data = 0;
1083
1084     XSETCOLOR_INSTANCE (Vthe_null_color_instance, c);
1085   }
1086
1087   staticpro_nodump (&Vthe_null_font_instance);
1088   {
1089     Lisp_Font_Instance *f =
1090       alloc_lcrecord_type (Lisp_Font_Instance, &lrecord_font_instance);
1091     f->name = Qnil;
1092     f->device = Qnil;
1093     f->data = 0;
1094
1095     f->ascent = f->height = 0;
1096     f->descent = 0;
1097     f->width = 0;
1098     f->proportional_p = 0;
1099
1100     XSETFONT_INSTANCE (Vthe_null_font_instance, f);
1101   }
1102 }
1103
1104 void
1105 vars_of_objects (void)
1106 {
1107   reinit_vars_of_objects ();
1108 }