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, void (*markobj) (Lisp_Object))
  61 {
  62   struct Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj);
  63   markobj (c->name);
  64   if (!NILP (c->device)) /* Vthe_null_color_instance */
  65     MAYBE_DEVMETH (XDEVICE (c->device), mark_color_instance, (c, markobj));
  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   struct 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   struct Lisp_Color_Instance *c = (struct 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   struct Lisp_Color_Instance *c1 = XCOLOR_INSTANCE (obj1);
 106   struct 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   struct 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,
 131                                struct 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   struct 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 (struct 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   struct 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, void (*markobj) (Lisp_Object))
 241 {
 242   struct Lisp_Font_Instance *f = XFONT_INSTANCE (obj);
 243
 244   markobj (f->name);
 245   if (!NILP (f->device)) /* Vthe_null_font_instance */
 246     MAYBE_DEVMETH (XDEVICE (f->device), mark_font_instance, (f, markobj));
 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   struct 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   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
 269 finalize_font_instance (void *header, int for_disksave)
 270 {
 271   struct Lisp_Font_Instance *f = (struct Lisp_Font_Instance *) header;
 272
 273   if (!NILP (f->device))
 274     {
 275       if (for_disksave) finalose (f);
 276       MAYBE_DEVMETH (XDEVICE (f->device), finalize_font_instance, (f));
 277     }
 278 }
 279
 280 /* Fonts are equal if they resolve to the same name.
 281    Since we call `font-truename' to do this, and since font-truename is lazy,
 282    this means the `equal' could cause XListFonts to be run the first time.
 283  */
 284 static int
 285 font_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
 286 {
 287   /* #### should this be moved into a device method? */
 288   return internal_equal (font_instance_truename_internal (obj1, ERROR_ME_NOT),
 289                          font_instance_truename_internal (obj2, ERROR_ME_NOT),
 290                          depth + 1);
 291 }
 292
 293 static unsigned long
 294 font_instance_hash (Lisp_Object obj, int depth)
 295 {
 296   return internal_hash (font_instance_truename_internal (obj, ERROR_ME_NOT),
 297                         depth + 1);
 298 }
 299
 300 DEFINE_LRECORD_IMPLEMENTATION ("font-instance", font_instance,
 301                                mark_font_instance, print_font_instance,
 302                                finalize_font_instance, font_instance_equal,
 303                                font_instance_hash, struct Lisp_Font_Instance);
 304 \f
 305 DEFUN ("make-font-instance", Fmake_font_instance, 1, 3, 0, /*
 306 Return a new `font-instance' object named NAME.
 307 DEVICE specifies the device this object applies to and defaults to the
 308 selected device.  An error is signalled if the font is unknown or cannot
 309 be allocated; however, if NOERROR is non-nil, nil is simply returned in
 310 this case.
 311
 312 The returned object is a normal, first-class lisp object.  The way you
 313 `deallocate' the font is the way you deallocate any other lisp object:
 314 you drop all pointers to it and allow it to be garbage collected.  When
 315 these objects are GCed, the underlying X data is deallocated as well.
 316 */
 317        (name, device, no_error))
 318 {
 319   struct Lisp_Font_Instance *f;
 320   Lisp_Object val;
 321   int retval = 0;
 322   Error_behavior errb = decode_error_behavior_flag (no_error);
 323
 324   if (ERRB_EQ (errb, ERROR_ME))
 325     CHECK_STRING (name);
 326   else if (!STRINGP (name))
 327     return Qnil;
 328
 329   XSETDEVICE (device, decode_device (device));
 330
 331   f = alloc_lcrecord_type (struct Lisp_Font_Instance, lrecord_font_instance);
 332   f->name = name;
 333   f->device = device;
 334
 335   f->data = 0;
 336
 337   /* Stick some default values here ... */
 338   f->ascent = f->height = 1;
 339   f->descent = 0;
 340   f->width = 1;
 341   f->proportional_p = 0;
 342
 343   retval = MAYBE_INT_DEVMETH (XDEVICE (device), initialize_font_instance,
 344                               (f, name, device, errb));
 345
 346   if (!retval)
 347     return Qnil;
 348
 349   XSETFONT_INSTANCE (val, f);
 350   return val;
 351 }
 352
 353 DEFUN ("font-instance-p", Ffont_instance_p, 1, 1, 0, /*
 354 Return non-nil if OBJECT is a font instance.
 355 */
 356        (object))
 357 {
 358   return FONT_INSTANCEP (object) ? Qt : Qnil;
 359 }
 360
 361 DEFUN ("font-instance-name", Ffont_instance_name, 1, 1, 0, /*
 362 Return the name used to allocate FONT-INSTANCE.
 363 */
 364        (font_instance))
 365 {
 366   CHECK_FONT_INSTANCE (font_instance);
 367   return XFONT_INSTANCE (font_instance)->name;
 368 }
 369
 370 DEFUN ("font-instance-ascent", Ffont_instance_ascent, 1, 1, 0, /*
 371 Return the ascent in pixels of FONT-INSTANCE.
 372 The returned value is the maximum ascent for all characters in the font,
 373 where a character's ascent is the number of pixels above (and including)
 374 the baseline.
 375 */
 376        (font_instance))
 377 {
 378   CHECK_FONT_INSTANCE (font_instance);
 379   return make_int (XFONT_INSTANCE (font_instance)->ascent);
 380 }
 381
 382 DEFUN ("font-instance-descent", Ffont_instance_descent, 1, 1, 0, /*
 383 Return the descent in pixels of FONT-INSTANCE.
 384 The returned value is the maximum descent for all characters in the font,
 385 where a character's descent is the number of pixels below the baseline.
 386 \(Many characters to do not have any descent.  Typical characters with a
 387 descent are lowercase p and lowercase g.)
 388 */
 389        (font_instance))
 390 {
 391   CHECK_FONT_INSTANCE (font_instance);
 392   return make_int (XFONT_INSTANCE (font_instance)->descent);
 393 }
 394
 395 DEFUN ("font-instance-width", Ffont_instance_width, 1, 1, 0, /*
 396 Return the width in pixels of FONT-INSTANCE.
 397 The returned value is the average width for all characters in the font.
 398 */
 399        (font_instance))
 400 {
 401   CHECK_FONT_INSTANCE (font_instance);
 402   return make_int (XFONT_INSTANCE (font_instance)->width);
 403 }
 404
 405 DEFUN ("font-instance-proportional-p", Ffont_instance_proportional_p, 1, 1, 0, /*
 406 Return whether FONT-INSTANCE is proportional.
 407 This means that different characters in the font have different widths.
 408 */
 409        (font_instance))
 410 {
 411   CHECK_FONT_INSTANCE (font_instance);
 412   return XFONT_INSTANCE (font_instance)->proportional_p ? Qt : Qnil;
 413 }
 414
 415 static Lisp_Object
 416 font_instance_truename_internal (Lisp_Object font_instance,
 417                                  Error_behavior errb)
 418 {
 419   struct Lisp_Font_Instance *f = XFONT_INSTANCE (font_instance);
 420   struct device *d = XDEVICE (f->device);
 421   return DEVMETH_OR_GIVEN (d, font_instance_truename, (f, errb), f->name);
 422 }
 423
 424 DEFUN ("font-instance-truename", Ffont_instance_truename, 1, 1, 0, /*
 425 Return the canonical name of FONT-INSTANCE.
 426 Font names are patterns which may match any number of fonts, of which
 427 the first found is used.  This returns an unambiguous name for that font
 428 \(but not necessarily its only unambiguous name).
 429 */
 430        (font_instance))
 431 {
 432   CHECK_FONT_INSTANCE (font_instance);
 433   return font_instance_truename_internal (font_instance, ERROR_ME);
 434 }
 435
 436 DEFUN ("font-instance-properties", Ffont_instance_properties, 1, 1, 0, /*
 437 Return the properties (an alist or nil) of FONT-INSTANCE.
 438 */
 439        (font_instance))
 440 {
 441   struct Lisp_Font_Instance *f;
 442
 443   CHECK_FONT_INSTANCE (font_instance);
 444   f = XFONT_INSTANCE (font_instance);
 445
 446   return MAYBE_LISP_DEVMETH (XDEVICE (f->device),
 447                              font_instance_properties, (f));
 448 }
 449
 450 DEFUN ("list-fonts", Flist_fonts, 1, 2, 0, /*
 451 Return a list of font names matching the given pattern.
 452 DEVICE specifies which device to search for names, and defaults to the
 453 currently selected device.
 454 */
 455        (pattern, device))
 456 {
 457   CHECK_STRING (pattern);
 458   XSETDEVICE (device, decode_device (device));
 459
 460   return MAYBE_LISP_DEVMETH (XDEVICE (device), list_fonts, (pattern, device));
 461 }
 462
 463 \f
 464 /****************************************************************************
 465  Color Object
 466  ***************************************************************************/
 467 DEFINE_SPECIFIER_TYPE (color);
 468 /* Qcolor defined in general.c */
 469
 470 static void
 471 color_create (Lisp_Object obj)
 472 {
 473   struct Lisp_Specifier *color = XCOLOR_SPECIFIER (obj);
 474
 475   COLOR_SPECIFIER_FACE (color) = Qnil;
 476   COLOR_SPECIFIER_FACE_PROPERTY (color) = Qnil;
 477 }
 478
 479 static void
 480 color_mark (Lisp_Object obj, void (*markobj) (Lisp_Object))
 481 {
 482   struct Lisp_Specifier *color = XCOLOR_SPECIFIER (obj);
 483
 484   markobj (COLOR_SPECIFIER_FACE (color));
 485   markobj (COLOR_SPECIFIER_FACE_PROPERTY (color));
 486 }
 487
 488 /* No equal or hash methods; ignore the face the color is based off
 489    of for `equal' */
 490
 491 static Lisp_Object
 492 color_instantiate (Lisp_Object specifier, Lisp_Object matchspec,
 493                    Lisp_Object domain, Lisp_Object instantiator,
 494                    Lisp_Object depth)
 495 {
 496   /* When called, we're inside of call_with_suspended_errors(),
 497      so we can freely error. */
 498   Lisp_Object device = DFW_DEVICE (domain);
 499   struct device *d = XDEVICE (device);
 500
 501   if (COLOR_INSTANCEP (instantiator))
 502     {
 503       /* If we are on the same device then we're done.  Otherwise change
 504          the instantiator to the name used to generate the pixel and let the
 505          STRINGP case deal with it. */
 506       if (NILP (device) /* Vthe_null_color_instance */
 507           || EQ (device, XCOLOR_INSTANCE (instantiator)->device))
 508         return instantiator;
 509       else
 510         instantiator = Fcolor_instance_name (instantiator);
 511     }
 512
 513   if (STRINGP (instantiator))
 514     {
 515       /* First, look to see if we can retrieve a cached value. */
 516       Lisp_Object instance =
 517         Fgethash (instantiator, d->color_instance_cache, Qunbound);
 518       /* Otherwise, make a new one. */
 519       if (UNBOUNDP (instance))
 520         {
 521           /* make sure we cache the failures, too. */
 522           instance = Fmake_color_instance (instantiator, device, Qt);
 523           Fputhash (instantiator, instance, d->color_instance_cache);
 524         }
 525
 526       return NILP (instance) ? Qunbound : instance;
 527     }
 528   else if (VECTORP (instantiator))
 529     {
 530       switch (XVECTOR_LENGTH (instantiator))
 531         {
 532         case 0:
 533           if (DEVICE_TTY_P (d))
 534             return Vthe_null_color_instance;
 535           else
 536             signal_simple_error ("Color instantiator [] only valid on TTY's",
 537                                  device);
 538
 539         case 1:
 540           if (NILP (COLOR_SPECIFIER_FACE (XCOLOR_SPECIFIER (specifier))))
 541             signal_simple_error ("Color specifier not attached to a face",
 542                                  instantiator);
 543           return (FACE_PROPERTY_INSTANCE_1
 544                   (Fget_face (XVECTOR_DATA (instantiator)[0]),
 545                    COLOR_SPECIFIER_FACE_PROPERTY (XCOLOR_SPECIFIER (specifier)),
 546                    domain, ERROR_ME, 0, depth));
 547
 548         case 2:
 549           return (FACE_PROPERTY_INSTANCE_1
 550                   (Fget_face (XVECTOR_DATA (instantiator)[0]),
 551                    XVECTOR_DATA (instantiator)[1], domain, ERROR_ME, 0, depth));
 552
 553         default:
 554           abort ();
 555         }
 556     }
 557   else if (NILP (instantiator))
 558     {
 559       if (DEVICE_TTY_P (d))
 560         return Vthe_null_color_instance;
 561       else
 562         signal_simple_error ("Color instantiator [] only valid on TTY's",
 563                              device);
 564     }
 565   else
 566     abort ();   /* The spec validation routines are screwed up. */
 567
 568   return Qunbound;
 569 }
 570
 571 static void
 572 color_validate (Lisp_Object instantiator)
 573 {
 574   if (COLOR_INSTANCEP (instantiator) || STRINGP (instantiator))
 575     return;
 576   if (VECTORP (instantiator))
 577     {
 578       if (XVECTOR_LENGTH (instantiator) > 2)
 579         signal_simple_error ("Inheritance vector must be of size 0 - 2",
 580                              instantiator);
 581       else if (XVECTOR_LENGTH (instantiator) > 0)
 582         {
 583           Lisp_Object face = XVECTOR_DATA (instantiator)[0];
 584
 585           Fget_face (face);
 586           if (XVECTOR_LENGTH (instantiator) == 2)
 587             {
 588               Lisp_Object field = XVECTOR_DATA (instantiator)[1];
 589               if (!EQ (field, Qforeground) && !EQ (field, Qbackground))
 590                 signal_simple_error
 591                   ("Inheritance field must be `foreground' or `background'",
 592                    field);
 593             }
 594         }
 595     }
 596   else
 597     signal_simple_error ("Invalid color instantiator", instantiator);
 598 }
 599
 600 static void
 601 color_after_change (Lisp_Object specifier, Lisp_Object locale)
 602 {
 603   Lisp_Object face = COLOR_SPECIFIER_FACE (XCOLOR_SPECIFIER (specifier));
 604   Lisp_Object property =
 605     COLOR_SPECIFIER_FACE_PROPERTY (XCOLOR_SPECIFIER (specifier));
 606   if (!NILP (face))
 607     face_property_was_changed (face, property, locale);
 608 }
 609
 610 void
 611 set_color_attached_to (Lisp_Object obj, Lisp_Object face, Lisp_Object property)
 612 {
 613   struct Lisp_Specifier *color = XCOLOR_SPECIFIER (obj);
 614
 615   COLOR_SPECIFIER_FACE (color) = face;
 616   COLOR_SPECIFIER_FACE_PROPERTY (color) = property;
 617 }
 618
 619 DEFUN ("color-specifier-p", Fcolor_specifier_p, 1, 1, 0, /*
 620 Return t if OBJECT is a color specifier.
 621
 622 Valid instantiators for color specifiers are:
 623
 624 -- a string naming a color (e.g. under X this might be "lightseagreen2"
 625    or "#F534B2")
 626 -- a color instance (use that instance directly if the device matches,
 627    or use the string that generated it)
 628 -- a vector of no elements (only on TTY's; this means to set no color
 629    at all, thus using the "natural" color of the terminal's text)
 630 -- a vector of one or two elements: a face to inherit from, and
 631    optionally a symbol naming which property of that face to inherit,
 632    either `foreground' or `background' (if omitted, defaults to the same
 633    property that this color specifier is used for; if this specifier is
 634    not part of a face, the instantiator would not be valid)
 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   struct 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, void (*markobj) (Lisp_Object))
 659 {
 660   struct Lisp_Specifier *font = XFONT_SPECIFIER (obj);
 661
 662   markobj (FONT_SPECIFIER_FACE (font));
 663   markobj (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 = DFW_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   struct 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 Valid instantiators for font specifiers are:
 833
 834 -- a string naming a font (e.g. under X this might be
 835    "-*-courier-medium-r-*-*-*-140-*-*-*-*-iso8859-*" for a 14-point
 836    upright medium-weight Courier font)
 837 -- a font instance (use that instance directly if the device matches,
 838    or use the string that generated it)
 839 -- a vector of no elements (only on TTY's; this means to set no font
 840    at all, thus using the "natural" font of the terminal's text)
 841 -- a vector of one element (a face to inherit from)
 842 */
 843        (object))
 844 {
 845   return FONT_SPECIFIERP (object) ? Qt : Qnil;
 846 }
 847
 848 \f
 849 /*****************************************************************************
 850  Face Boolean Object
 851  ****************************************************************************/
 852 DEFINE_SPECIFIER_TYPE (face_boolean);
 853 Lisp_Object Qface_boolean;
 854
 855 static void
 856 face_boolean_create (Lisp_Object obj)
 857 {
 858   struct Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj);
 859
 860   FACE_BOOLEAN_SPECIFIER_FACE (face_boolean) = Qnil;
 861   FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean) = Qnil;
 862 }
 863
 864 static void
 865 face_boolean_mark (Lisp_Object obj, void (*markobj) (Lisp_Object))
 866 {
 867   struct Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj);
 868
 869   markobj (FACE_BOOLEAN_SPECIFIER_FACE (face_boolean));
 870   markobj (FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean));
 871 }
 872
 873 /* No equal or hash methods; ignore the face the face-boolean is based off
 874    of for `equal' */
 875
 876 static Lisp_Object
 877 face_boolean_instantiate (Lisp_Object specifier, Lisp_Object matchspec,
 878                           Lisp_Object domain, Lisp_Object instantiator,
 879                           Lisp_Object depth)
 880 {
 881   /* When called, we're inside of call_with_suspended_errors(),
 882      so we can freely error. */
 883   if (NILP (instantiator) || EQ (instantiator, Qt))
 884     return instantiator;
 885   else if (VECTORP (instantiator))
 886     {
 887       Lisp_Object retval;
 888       Lisp_Object prop;
 889       int instantiator_len = XVECTOR_LENGTH (instantiator);
 890
 891       assert (instantiator_len >= 1 && instantiator_len <= 3);
 892       if (instantiator_len > 1)
 893         prop = XVECTOR_DATA (instantiator)[1];
 894       else
 895         {
 896           if (NILP (FACE_BOOLEAN_SPECIFIER_FACE
 897                     (XFACE_BOOLEAN_SPECIFIER (specifier))))
 898             signal_simple_error
 899               ("Face-boolean specifier not attached to a face", instantiator);
 900           prop = FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY
 901             (XFACE_BOOLEAN_SPECIFIER (specifier));
 902         }
 903
 904       retval = (FACE_PROPERTY_INSTANCE_1
 905                 (Fget_face (XVECTOR_DATA (instantiator)[0]),
 906                  prop, domain, ERROR_ME, 0, depth));
 907
 908       if (instantiator_len == 3 && !NILP (XVECTOR_DATA (instantiator)[2]))
 909         retval = NILP (retval) ? Qt : Qnil;
 910
 911       return retval;
 912     }
 913   else
 914     abort ();   /* Eh? */
 915
 916   return Qunbound;
 917 }
 918
 919 static void
 920 face_boolean_validate (Lisp_Object instantiator)
 921 {
 922   if (NILP (instantiator) || EQ (instantiator, Qt))
 923     return;
 924   else if (VECTORP (instantiator) &&
 925            (XVECTOR_LENGTH (instantiator) >= 1 &&
 926             XVECTOR_LENGTH (instantiator) <= 3))
 927     {
 928       Lisp_Object face = XVECTOR_DATA (instantiator)[0];
 929
 930       Fget_face (face);
 931
 932       if (XVECTOR_LENGTH (instantiator) > 1)
 933         {
 934           Lisp_Object field = XVECTOR_DATA (instantiator)[1];
 935           if (!EQ (field, Qunderline)
 936               && !EQ (field, Qstrikethru)
 937               && !EQ (field, Qhighlight)
 938               && !EQ (field, Qdim)
 939               && !EQ (field, Qblinking)
 940               && !EQ (field, Qreverse))
 941             signal_simple_error ("Invalid face-boolean inheritance field",
 942                                  field);
 943         }
 944     }
 945   else if (VECTORP (instantiator))
 946     signal_simple_error ("Wrong length for face-boolean inheritance spec",
 947                          instantiator);
 948   else
 949     signal_simple_error ("Face-boolean instantiator must be nil, t, or vector",
 950                          instantiator);
 951 }
 952
 953 static void
 954 face_boolean_after_change (Lisp_Object specifier, Lisp_Object locale)
 955 {
 956   Lisp_Object face =
 957     FACE_BOOLEAN_SPECIFIER_FACE (XFACE_BOOLEAN_SPECIFIER (specifier));
 958   Lisp_Object property =
 959     FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (XFACE_BOOLEAN_SPECIFIER (specifier));
 960   if (!NILP (face))
 961     face_property_was_changed (face, property, locale);
 962 }
 963
 964 void
 965 set_face_boolean_attached_to (Lisp_Object obj, Lisp_Object face,
 966                               Lisp_Object property)
 967 {
 968   struct Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj);
 969
 970   FACE_BOOLEAN_SPECIFIER_FACE (face_boolean) = face;
 971   FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean) = property;
 972 }
 973
 974 DEFUN ("face-boolean-specifier-p", Fface_boolean_specifier_p, 1, 1, 0, /*
 975 Return non-nil if OBJECT is a face-boolean specifier.
 976
 977 Valid instantiators for face-boolean specifiers are
 978
 979 -- t or nil
 980 -- a vector of two or three elements: a face to inherit from,
 981    optionally a symbol naming the property of that face to inherit from
 982    (if omitted, defaults to the same property that this face-boolean
 983    specifier is used for; if this specifier is not part of a face,
 984    the instantiator would not be valid), and optionally a value which,
 985    if non-nil, means to invert the sense of the inherited property.
 986 */
 987        (object))
 988 {
 989   return FACE_BOOLEAN_SPECIFIERP (object) ? Qt : Qnil;
 990 }
 991
 992 \f
 993 /************************************************************************/
 994 /*                            initialization                            */
 995 /************************************************************************/
 996
 997 void
 998 syms_of_objects (void)
 999 {
1000   DEFSUBR (Fcolor_specifier_p);
1001   DEFSUBR (Ffont_specifier_p);
1002   DEFSUBR (Fface_boolean_specifier_p);
1003
1004   defsymbol (&Qcolor_instancep, "color-instance-p");
1005   DEFSUBR (Fmake_color_instance);
1006   DEFSUBR (Fcolor_instance_p);
1007   DEFSUBR (Fcolor_instance_name);
1008   DEFSUBR (Fcolor_instance_rgb_components);
1009   DEFSUBR (Fvalid_color_name_p);
1010
1011   defsymbol (&Qfont_instancep, "font-instance-p");
1012   DEFSUBR (Fmake_font_instance);
1013   DEFSUBR (Ffont_instance_p);
1014   DEFSUBR (Ffont_instance_name);
1015   DEFSUBR (Ffont_instance_ascent);
1016   DEFSUBR (Ffont_instance_descent);
1017   DEFSUBR (Ffont_instance_width);
1018   DEFSUBR (Ffont_instance_proportional_p);
1019   DEFSUBR (Ffont_instance_truename);
1020   DEFSUBR (Ffont_instance_properties);
1021   DEFSUBR (Flist_fonts);
1022
1023   /* Qcolor, Qfont defined in general.c */
1024   defsymbol (&Qface_boolean, "face-boolean");
1025 }
1026
1027 void
1028 specifier_type_create_objects (void)
1029 {
1030   INITIALIZE_SPECIFIER_TYPE_WITH_DATA (color, "color", "color-specifier-p");
1031   INITIALIZE_SPECIFIER_TYPE_WITH_DATA (font, "font", "font-specifier-p");
1032   INITIALIZE_SPECIFIER_TYPE_WITH_DATA (face_boolean, "face-boolean",
1033                                          "face-boolean-specifier-p");
1034
1035   SPECIFIER_HAS_METHOD (color, instantiate);
1036   SPECIFIER_HAS_METHOD (font, instantiate);
1037   SPECIFIER_HAS_METHOD (face_boolean, instantiate);
1038
1039   SPECIFIER_HAS_METHOD (color, validate);
1040   SPECIFIER_HAS_METHOD (font, validate);
1041   SPECIFIER_HAS_METHOD (face_boolean, validate);
1042
1043   SPECIFIER_HAS_METHOD (color, create);
1044   SPECIFIER_HAS_METHOD (font, create);
1045   SPECIFIER_HAS_METHOD (face_boolean, create);
1046
1047   SPECIFIER_HAS_METHOD (color, mark);
1048   SPECIFIER_HAS_METHOD (font, mark);
1049   SPECIFIER_HAS_METHOD (face_boolean, mark);
1050
1051   SPECIFIER_HAS_METHOD (color, after_change);
1052   SPECIFIER_HAS_METHOD (font, after_change);
1053   SPECIFIER_HAS_METHOD (face_boolean, after_change);
1054
1055 #ifdef MULE
1056   SPECIFIER_HAS_METHOD (font, validate_matchspec);
1057 #endif
1058 }
1059
1060 void
1061 vars_of_objects (void)
1062 {
1063   staticpro (&Vthe_null_color_instance);
1064   {
1065     struct Lisp_Color_Instance *c =
1066       alloc_lcrecord_type (struct Lisp_Color_Instance, lrecord_color_instance);
1067     c->name = Qnil;
1068     c->device = Qnil;
1069     c->data = 0;
1070
1071     XSETCOLOR_INSTANCE (Vthe_null_color_instance, c);
1072   }
1073
1074   staticpro (&Vthe_null_font_instance);
1075   {
1076     struct Lisp_Font_Instance *f =
1077       alloc_lcrecord_type (struct Lisp_Font_Instance, lrecord_font_instance);
1078     f->name = Qnil;
1079     f->device = Qnil;
1080     f->data = 0;
1081
1082     f->ascent = f->height = 0;
1083     f->descent = 0;
1084     f->width = 0;
1085     f->proportional_p = 0;
1086
1087     XSETFONT_INSTANCE (Vthe_null_font_instance, f);
1088   }
1089 }