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