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