xemacs-beta: src/specifier.c comparison

comparison src/specifier.c @ 5118:e0db3c197671 ben-lisp-object

merge up to latest default branch, doesn't compile yet

author	Ben Wing <ben@xemacs.org>
date	Sat, 26 Dec 2009 21:18:49 -0600
parents	3742ea8250b5 11357f7846bf
children	d1247f3cc363

comparison

equal deleted inserted replaced

-:3742ea8250b5
+:e0db3c197671
 Lisp_Object Qremove_locale, Qremove_locale_type;
 Lisp_Object Qconsole_type, Qdevice_class;
 static Lisp_Object Vuser_defined_tags;
+static Lisp_Object Vcharset_tag_lists;
 typedef struct specifier_type_entry specifier_type_entry;
 struct specifier_type_entry
 {
 Lisp_Object symbol;
 {
 if (! marked_p (rest))
 	{
 	  Lisp_Specifier* sp = XSPECIFIER (rest);
 	  /* A bit of assertion that we're removing both parts of the
-magic one altogether */
+	     magic one altogether */
 	  assert (!MAGIC_SPECIFIER_P(sp)
 		  || (BODILY_SPECIFIER_P(sp) && marked_p (sp->fallback))
 		  || (GHOST_SPECIFIER_P(sp) && marked_p (sp->magic_parent)));
 	  /* This specifier is garbage.  Remove it from the list. */
 	  if (NILP (prev))
 }
 unbind_to (count);
 write_fmt_string (printcharfun, " 0x%x>", sp->header.uid);
 }
+#ifndef NEW_GC
 static void
 finalize_specifier (void *header, int for_disksave)
 {
 Lisp_Specifier *sp = (Lisp_Specifier *) header;
 /* don't be snafued by the disksave finalization. */
 {
 xfree (sp->caching, struct specifier_caching *);
 sp->caching = 0;
 }
 }
+#endif /* not NEW_GC */
 static int
 specifier_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
 {
 Lisp_Specifier *s1 = XSPECIFIER (obj1);
 static const struct memory_description specifier_caching_description_1[] = {
 { XD_END }
 };
+#ifdef NEW_GC
+DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("specifier-caching", specifier_caching,
+				      0, specifier_caching_description_1,
+				      struct specifier_caching);
+#else /* not NEW_GC */
 static const struct sized_memory_description specifier_caching_description = {
 sizeof (struct specifier_caching),
 specifier_caching_description_1
 };
+#endif /* not NEW_GC */
 static const struct sized_memory_description specifier_extra_description_map[]
 = {
 { offsetof (Lisp_Specifier, methods) },
 { offsetof (struct specifier_methods, extra_description) },
 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, global_specs) },
 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, device_specs) },
 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, frame_specs) },
 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, window_specs) },
 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, buffer_specs) },
+#ifdef NEW_GC
+{ XD_LISP_OBJECT,  offsetof (Lisp_Specifier, caching) },
+#else /* not NEW_GC */
 { XD_BLOCK_PTR,  offsetof (Lisp_Specifier, caching), 1,
 { &specifier_caching_description } },
+#endif /* not NEW_GC */
 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, magic_parent) },
 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, fallback) },
 { XD_BLOCK_ARRAY, offsetof (Lisp_Specifier, data), 1,
 { specifier_extra_description_map } },
 { XD_END }
 };
 static const struct memory_description specifier_empty_extra_description_1[] =
 {
 { XD_END }
 };
 const struct sized_memory_description specifier_empty_extra_description = {
 0, specifier_empty_extra_description_1
 };
-DEFINE_SIZABLE_LISP_OBJECT ("specifier", specifier,
+#ifdef NEW_GC
-				       mark_specifier, print_specifier,
+DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("specifier", specifier,
-				       finalize_specifier,
+				     mark_specifier, print_specifier,
-				       specifier_equal, specifier_hash,
+				     0, specifier_equal, specifier_hash,
-				       specifier_description,
+				     specifier_description,
-				       sizeof_specifier,
+				     sizeof_specifier,
-				       Lisp_Specifier);
+				     Lisp_Specifier);
+#else /* not NEW_GC */
+DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("specifier", specifier,
+				     mark_specifier, print_specifier,
+				     finalize_specifier,
+				     specifier_equal, specifier_hash,
+				     specifier_description,
+				     sizeof_specifier,
+				     Lisp_Specifier);
+#endif /* not NEW_GC */
 /************************************************************************/
 /*                       Creating specifiers                            */
 /************************************************************************/
 if (EQ (type, Dynarr_at (the_specifier_type_entry_dynarr, i).symbol))
 	return Dynarr_at (the_specifier_type_entry_dynarr, i).meths;
 }
 maybe_invalid_argument ("Invalid specifier type",
-			   type, Qspecifier, errb);
+			  type, Qspecifier, errb);
 return 0;
 }
 static int
 value in that domain).  Valid domains are image instances, windows, frames,
 and devices. \(nil is not valid.) image instances are pseudo-domains since
 instantiation will actually occur in the window the image instance itself is
 instantiated in.
 */
 (domain))
 {
 /* This cannot GC. */
 return ((DEVICEP (domain) && DEVICE_LIVE_P (XDEVICE (domain))) ||
 	  (FRAMEP  (domain) && FRAME_LIVE_P  (XFRAME  (domain))) ||
 	  (WINDOWP (domain) && WINDOW_LIVE_P (XWINDOW (domain))) ||
 	  /* #### get image instances out of domains! */
 	  IMAGE_INSTANCEP (domain))
 ? Qt : Qnil;
 }
-DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, 1, 0,
+DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1,
-/*
+1, 0, /*
 Given a specifier LOCALE-TYPE, return non-nil if it is valid.
 Valid locale types are `global', `device', `frame', `window', and `buffer'.
 \(Note, however, that in functions that accept either a locale or a locale
 type, `global' is considered an individual locale.)
 */
 (locale_type))
 {
 /* This cannot GC. */
 return (EQ (locale_type, Qglobal) ||
 	  EQ (locale_type, Qdevice) ||
 	  EQ (locale_type, Qframe)  ||
 (locale))
 {
 /* This cannot GC. */
 if (NILP (Fvalid_specifier_locale_p (locale)))
 invalid_argument ("Invalid specifier locale",
-		       locale);
+		      locale);
 if (DEVICEP (locale)) return Qdevice;
 if (FRAMEP  (locale)) return Qframe;
 if (WINDOWP (locale)) return Qwindow;
 if (BUFFERP (locale)) return Qbuffer;
 assert (EQ (locale, Qglobal));
 return Qglobal;
 else if (!NILP (Fvalid_specifier_locale_p (locale)))
 return locale;
 else
 invalid_argument ("Invalid specifier locale",
-		       locale);
+		      locale);
 return Qnil;
 }
 static enum spec_locale_type
 if (EQ (locale_type, Qframe))  return LOCALE_FRAME;
 if (EQ (locale_type, Qwindow)) return LOCALE_WINDOW;
 if (EQ (locale_type, Qbuffer)) return LOCALE_BUFFER;
 invalid_argument ("Invalid specifier locale type",
-		     locale_type);
+		    locale_type);
 RETURN_NOT_REACHED (LOCALE_GLOBAL);
 }
 Lisp_Object
 decode_locale_list (Lisp_Object locale)
 static void
 check_valid_domain (Lisp_Object domain)
 {
 if (NILP (Fvalid_specifier_domain_p (domain)))
 invalid_argument ("Invalid specifier domain",
-		       domain);
+		      domain);
 }
 Lisp_Object
 decode_domain (Lisp_Object domain)
 {
 }
 DEFUN ("valid-specifier-tag-set-p", Fvalid_specifier_tag_set_p, 1, 1, 0, /*
 Return non-nil if TAG-SET is a valid specifier tag set.
-A specifier tag set is an entity that is attached to an instantiator
+A specifier tag set is an entity that is attached to an instantiator and can
-and can be used to restrict the scope of that instantiator to a
+be used to restrict the scope of that instantiator to a particular device
-particular device class or device type and/or to mark instantiators
+class, device type, or charset.  It can also be used to mark instantiators
-added by a particular package so that they can be later removed.
+added by a particular package so that they can be later removed as a group.
 A specifier tag set consists of a list of zero of more specifier tags,
 each of which is a symbol that is recognized by XEmacs as a tag.
 \(The valid device types and device classes are always tags, as are
 any tags defined by `define-specifier-tag'.) It is called a "tag set"
 \(as opposed to a list) because the order of the tags or the number of
 times a particular tag occurs does not matter.
-Each tag has a predicate associated with it, which specifies whether
+Each tag has two predicates associated with it, which specify, respectively,
-that tag applies to a particular device.  The tags which are device types
+whether that tag applies to a particular device and whether it applies to a
-and classes match devices of that type or class.  User-defined tags can
+particular character set.  The predefined tags which are device types and
-have any predicate, or none (meaning that all devices match).  When
+classes match devices of that type or class.  User-defined tags can have any
-attempting to instantiate a specifier, a particular instantiator is only
+device predicate, or none (meaning that all devices match).  When attempting
-considered if the device of the domain being instantiated over matches
+to instantiate a specifier, a particular instantiator is only considered if
-all tags in the tag set attached to that instantiator.
+the device of the domain being instantiated over matches all tags in the tag
+set attached to that instantiator.
+If a charset is to be considered--which is only the case for face
+instantiators--this consideration may be done twice.  The first iteration
+pays attention to the character set predicates; if no instantiator can be
+found in that case, the search is repeated ignoring the character set
+predicates.
 Most of the time, a tag set is not specified, and the instantiator
 gets a null tag set, which matches all devices.
 */
 (tag_set))
 {
 Lisp_Object rest;
 for (rest = tag_set; !NILP (rest); rest = XCDR (rest))
 {
 /* The return value of this function must be GCPRO'd. */
 if (!NILP (Fvalid_specifier_tag_p (tag_set)))
 return list1 (tag_set);
 if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
 invalid_argument ("Invalid specifier tag-set",
-		       tag_set);
+		      tag_set);
 return tag_set;
 }
 static Lisp_Object
 canonicalize_tag_set (Lisp_Object tag_set)
 }
 return 1;
 }
+static int
+charset_matches_specifier_tag_set_p (Lisp_Object charset,
+				     Lisp_Object tag_set,
+				     enum font_specifier_matchspec_stages
+				     stage)
+{
+Lisp_Object rest;
+int res = 0;
+assert(stage != impossible);
+LIST_LOOP (rest, tag_set)
+{
+Lisp_Object tag = XCAR (rest);
+Lisp_Object assoc;
+/* In the event that, during the creation of a charset, no specifier
+	 tags exist for which CHARSET-PREDICATE has been specified, then
+	 that charset's entry in Vcharset_tag_lists will be nil, and this
+	 charset shouldn't match. */
+if (NILP (XVECTOR_DATA(Vcharset_tag_lists)[XCHARSET_LEADING_BYTE(charset)
+						 - MIN_LEADING_BYTE]))
+	{
+	  return 0;
+	}
+/* Now, find out what the pre-calculated value is. */
+assoc = assq_no_quit(tag,
+			   XVECTOR_DATA(Vcharset_tag_lists)
+			   [XCHARSET_LEADING_BYTE(charset)
+			    - MIN_LEADING_BYTE]);
+if (!(NILP(assoc)) && !(NILP(XCDR(assoc))))
+	{
+	  assert(VECTORP(XCDR(assoc)));
+	  /* In the event that a tag specifies a charset, then the specifier
+	     must match for (this stage and this charset) for all
+	     charset-specifying tags.  */
+	  if (NILP(XVECTOR_DATA(XCDR(assoc))[stage]))
+	    {
+	      /* It doesn't match for this tag, even though the tag
+		 specifies a charset. Return 0. */
+	      return 0;
+	    }
+	  /* This tag specifies charset limitations, and this charset and
+	     stage match those charset limitations.
+	     In the event that a later tag specifies charset limitations
+	     that don't match, the return 0 above prevents us giving a
+	     positive match. */
+	  res = 1;
+	}
+}
+return res;
+}
 DEFUN ("device-matches-specifier-tag-set-p",
 Fdevice_matches_specifier_tag_set_p, 2, 2, 0, /*
 Return non-nil if DEVICE matches specifier tag set TAG-SET.
 This means that DEVICE matches each tag in the tag set. (Every
 tag recognized by XEmacs has a predicate associated with it that
 invalid_argument ("Invalid tag set", tag_set);
 return device_matches_specifier_tag_set_p (device, tag_set) ? Qt : Qnil;
 }
-DEFUN ("define-specifier-tag", Fdefine_specifier_tag, 1, 2, 0, /*
+Lisp_Object
+define_specifier_tag(Lisp_Object tag, Lisp_Object device_predicate,
+		     Lisp_Object charset_predicate)
+{
+Lisp_Object assoc = assq_no_quit (tag, Vuser_defined_tags),
+concons, devcons, charpres = Qnil;
+int recompute_devices = 0, recompute_charsets = 0, i, max_args = -1;
+if (NILP (assoc))
+{
+recompute_devices = recompute_charsets = 1;
+Vuser_defined_tags = Fcons (list3 (tag, device_predicate,
+					 charset_predicate),
+				  Vuser_defined_tags);
+DEVICE_LOOP_NO_BREAK (devcons, concons)
+	{
+	  struct device *d = XDEVICE (XCAR (devcons));
+	  /* Initially set the value to t in case of error
+	     in device_predicate */
+	  DEVICE_USER_DEFINED_TAGS (d) =
+	    Fcons (Fcons (tag, Qt), DEVICE_USER_DEFINED_TAGS (d));
+	}
+if (!NILP (charset_predicate))
+	{
+	  max_args = XINT(Ffunction_max_args(charset_predicate));
+	  if (max_args < 1)
+	    {
+	      invalid_argument
+		("Charset predicate must be able to take an argument", tag);
+	    }
+	}
+}
+else if (!NILP (device_predicate) && !NILP (XCADR (assoc)))
+{
+recompute_devices = 1;
+XCDR (assoc) = list2(device_predicate, charset_predicate);
+}
+else if (!NILP (charset_predicate) || !NILP(XCADDR (assoc)))
+{
+max_args = XINT(Ffunction_max_args(charset_predicate));
+if (max_args < 1)
+	{
+	  invalid_argument
+	    ("Charset predicate must be able to take an argument", tag);
+	}
+/* If there exists a charset_predicate for the tag currently (even if
+	 the new charset_predicate is nil), or if we're adding one, we need
+	 to recompute.  This contrasts with the device predicates, where we
+	 don't need to recompute if the old and new device predicates are
+	 both nil.  */
+recompute_charsets = 1;
+XCDR (assoc) = list2(device_predicate, charset_predicate);
+}
+/* Recompute the tag values for all devices and charsets, if necessary. In
+the special case where both the old and new device_predicates are nil,
+we know that we don't have to do it for the device. (It's probably
+common for people to call (define-specifier-tag) more than once on the
+same tag, and the most common case is where DEVICE_PREDICATE is not
+specified.) */
+if (recompute_devices)
+{
+DEVICE_LOOP_NO_BREAK (devcons, concons)
+	{
+	  Lisp_Object device = XCAR (devcons);
+	  assoc = assq_no_quit (tag,
+				DEVICE_USER_DEFINED_TAGS (XDEVICE (device)));
+	  assert (CONSP (assoc));
+	  if (NILP (device_predicate))
+	    XCDR (assoc) = Qt;
+	  else
+	    XCDR (assoc) = !NILP (call1 (device_predicate, device)) ? Qt
+	      : Qnil;
+	}
+}
+if (recompute_charsets)
+{
+if (NILP(charset_predicate))
+	{
+	  charpres = Qnil;
+	}
+for (i = 0; i < NUM_LEADING_BYTES; ++i)
+	{
+	  if (NILP(charset_by_leading_byte(MIN_LEADING_BYTE + i)))
+	    {
+	      continue;
+	    }
+	  assoc = assq_no_quit (tag,
+				XVECTOR_DATA(Vcharset_tag_lists)[i]);
+	  if (!NILP(charset_predicate))
+	    {
+	      struct gcpro gcpro1;
+	      charpres = make_vector(impossible, Qnil);
+	      GCPRO1 (charpres);
+	      /* If you want to extend the number of stages available, here
+		 in setup_charset_initial_specifier_tags, and in specifier.h
+		 is where you want to go. */
+#define DEFINE_SPECIFIER_TAG_FROB(stage)	do {			\
+		if (max_args > 1)					\
+		  {							\
+		    XVECTOR_DATA(charpres)[stage] =			\
+		      call2_trapping_problems				\
+		      ("Error during specifier tag charset predicate,"	\
+		       " stage " #stage, charset_predicate,		\
+		       charset_by_leading_byte(MIN_LEADING_BYTE + i),	\
+		       Q##stage, 0);					\
+		  }							\
+		else							\
+		  {							\
+		    XVECTOR_DATA(charpres)[stage] =			\
+		      call1_trapping_problems				\
+		      ("Error during specifier tag charset predicate,"	\
+		       " stage " #stage, charset_predicate,		\
+		       charset_by_leading_byte(MIN_LEADING_BYTE + i),	\
+		       0);						\
+		  }							\
+									\
+		if (UNBOUNDP(XVECTOR_DATA(charpres)[stage]))		\
+		  {							\
+		    XVECTOR_DATA(charpres)[stage] = Qnil;		\
+		  }							\
+		else if (!NILP(XVECTOR_DATA(charpres)[stage]))		\
+		  {							\
+		    /* Don't want refs to random other objects.  */	\
+		    XVECTOR_DATA(charpres)[stage] = Qt;			\
+		  }							\
+	      } while (0)
+	      DEFINE_SPECIFIER_TAG_FROB (initial);
+	      DEFINE_SPECIFIER_TAG_FROB (final);
+#undef DEFINE_SPECIFIER_TAG_FROB
+	      UNGCPRO;
+	    }
+	  if (!NILP(assoc))
+	    {
+	      assert(CONSP(assoc));
+	      XCDR (assoc) = charpres;
+	    }
+	  else
+	    {
+	      XVECTOR_DATA(Vcharset_tag_lists)[i]
+		= Fcons(Fcons(tag, charpres),
+			XVECTOR_DATA (Vcharset_tag_lists)[i]);
+	    }
+	}
+}
+return Qt;
+}
+DEFUN ("define-specifier-tag", Fdefine_specifier_tag, 1, 3, 0, /*
 Define a new specifier tag.
-If PREDICATE is specified, it should be a function of one argument
-\(a device) that specifies whether the tag matches that particular
+If DEVICE-PREDICATE is specified, it should be a function of one argument
-device.  If PREDICATE is omitted, the tag matches all devices.
+\(a device) that specifies whether the tag matches that particular device.
+If DEVICE-PREDICATE is omitted, the tag matches all devices.
-You can redefine an existing user-defined specifier tag.  However,
-you cannot redefine the built-in specifier tags (the device types
+If CHARSET-PREDICATE is supplied, it should be a function taking a single
-and classes) or the symbols nil, t, `all', or `global'.
+Lisp character set argument.  A tag's charset predicate is primarily used to
-*/
+determine what font to use for a given \(set of) charset\(s) when that tag
-(tag, predicate))
+is used in a set-face-font call; a non-nil return value indicates that the
-{
+tag matches the charset.
-Lisp_Object assoc, devcons, concons;
-int recompute = 0;
+The font matching process also has a concept of stages; the defined stages
+are currently `initial' and `final', and there exist specifier tags with
+those names that correspond to those stages.  On X11, 'initial is used when
+the font matching process is looking for fonts that match the desired
+registries of the charset--see the `charset-registries' function.  If that
+match process fails, then the 'final tag becomes relevant; this means that a
+more general lookup is desired, and that a font doesn't necessarily have to
+match the desired XLFD for the face, just the charset repertoire for this
+charset.  It also means that the charset registry and encoding used will be
+`iso10646-1', and the characters will be converted to display using that
+registry.
+If a tag set matches no character set; the two-stage match process will
+ignore the tag on its first pass, but if no match is found, it will respect
+it on the second pass, where character set information is ignored.
+You can redefine an existing user-defined specifier tag.  However, you
+cannot redefine most of the built-in specifier tags \(the device types and
+classes, `initial', and `final') or the symbols nil, t, `all', or `global'.
+Note that if a device type is not supported in this XEmacs, it will not be
+available as a built-in specifier tag; this is probably something we should
+change.
+*/
+(tag, device_predicate, charset_predicate))
+{
+int max_args;
 CHECK_SYMBOL (tag);
 if (valid_device_class_p (tag) ||
-valid_console_type_p (tag))
+valid_console_type_p (tag) ||
+EQ (tag, Qinitial) || EQ (tag, Qfinal))
 invalid_change ("Cannot redefine built-in specifier tags", tag);
 /* Try to prevent common instantiators and locales from being
 redefined, to reduce ambiguity */
 if (NILP (tag) || EQ (tag, Qt) || EQ (tag, Qall) || EQ (tag, Qglobal))
 invalid_change ("Cannot define nil, t, `all', or `global'", tag);
-assoc = assq_no_quit (tag, Vuser_defined_tags);
-if (NILP (assoc))
+if (!NILP (charset_predicate))
 {
-recompute = 1;
+max_args = XINT(Ffunction_max_args(charset_predicate));
-Vuser_defined_tags = Fcons (Fcons (tag, predicate), Vuser_defined_tags);
+if (max_args != 1)
-DEVICE_LOOP_NO_BREAK (devcons, concons)
+	{
-	{
+	  /* We only allow the stage argument to be specifed from C.  */
-	  struct device *d = XDEVICE (XCAR (devcons));
+	  invalid_change ("Charset predicate must take one argument",
-	  /* Initially set the value to t in case of error
+			  tag);
-	     in predicate */
+	}
-	  DEVICE_USER_DEFINED_TAGS (d) =
+}
-	    Fcons (Fcons (tag, Qt), DEVICE_USER_DEFINED_TAGS (d));
-	}
+return define_specifier_tag(tag, device_predicate, charset_predicate);
-}
-else if (!NILP (predicate) && !NILP (XCDR (assoc)))
-{
-recompute = 1;
-XCDR (assoc) = predicate;
-}
-/* recompute the tag values for all devices.  However, in the special
-case where both the old and new predicates are nil, we know that
-we don't have to do this. (It's probably common for people to
-call (define-specifier-tag) more than once on the same tag,
-and the most common case is where PREDICATE is not specified.) */
-if (recompute)
-{
-DEVICE_LOOP_NO_BREAK (devcons, concons)
-	{
-	  Lisp_Object device = XCAR (devcons);
-	  assoc = assq_no_quit (tag,
-				DEVICE_USER_DEFINED_TAGS (XDEVICE (device)));
-	  assert (CONSP (assoc));
-	  if (NILP (predicate))
-	    XCDR (assoc) = Qt;
-	  else
-	    XCDR (assoc) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
-	}
-}
-return Qnil;
 }
 /* Called at device-creation time to initialize the user-defined
 tag values for the newly-created device. */
 void
 setup_device_initial_specifier_tags (struct device *d)
 {
 Lisp_Object rest, rest2;
 Lisp_Object device = wrap_device (d);
+Lisp_Object device_predicate;
+int list_len;
 DEVICE_USER_DEFINED_TAGS (d) = Fcopy_alist (Vuser_defined_tags);
 /* Now set up the initial values */
 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d))
 XCDR (XCAR (rest)) = Qt;
 for (rest = Vuser_defined_tags, rest2 = DEVICE_USER_DEFINED_TAGS (d);
 !NILP (rest); rest = XCDR (rest), rest2 = XCDR (rest2))
 {
-Lisp_Object predicate = XCDR (XCAR (rest));
+GET_LIST_LENGTH(XCAR(rest), list_len);
-if (NILP (predicate))
-	XCDR (XCAR (rest2)) = Qt;
+assert(3 == list_len);
+device_predicate = XCADR(XCAR (rest));
+if (NILP (device_predicate))
+	{
+	  XCDR (XCAR (rest2)) = Qt;
+	}
 else
-	XCDR (XCAR (rest2)) =
+	{
-	  !NILP (call_critical_lisp_code (d, predicate, device)) ? Qt : Qnil;
+	  device_predicate = !NILP (call_critical_lisp_code
-}
+				    (d, device_predicate, device))
-}
+	    ? Qt : Qnil;
+	  XCDR (XCAR (rest2)) = device_predicate;
+	}
+}
+}
+void
+setup_charset_initial_specifier_tags (Lisp_Object charset)
+{
+Lisp_Object rest, charset_predicate, tag, new_value;
+Lisp_Object charset_tag_list = Qnil;
+LIST_LOOP (rest, Vuser_defined_tags)
+{
+tag = XCAR(XCAR(rest));
+charset_predicate = XCADDR(XCAR (rest));
+if (NILP(charset_predicate))
+	{
+	  continue;
+	}
+new_value = make_vector(impossible, Qnil);
+#define SETUP_CHARSET_TAGS_FROB(stage)		do {			\
+									\
+	XVECTOR_DATA(new_value)[stage] = call2_trapping_problems	\
+	  ("Error during specifier tag charset predicate,"		\
+	   " stage " #stage,						\
+	   charset_predicate, charset, Q##stage, 0);			\
+									\
+	if (UNBOUNDP(XVECTOR_DATA(new_value)[stage]))			\
+	  {								\
+	    XVECTOR_DATA(new_value)[stage] = Qnil;			\
+	  }								\
+	else if (!NILP(XVECTOR_DATA(new_value)[stage]))			\
+	  {								\
+	    /* Don't want random other objects hanging around. */	\
+	    XVECTOR_DATA(new_value)[stage] = Qt;			\
+	  }								\
+									\
+} while (0)
+SETUP_CHARSET_TAGS_FROB (initial);
+SETUP_CHARSET_TAGS_FROB (final);
+/* More later?  */
+#undef SETUP_CHARSET_TAGS_FROB
+charset_tag_list = Fcons(Fcons(tag, new_value), charset_tag_list);
+}
+XVECTOR_DATA
+(Vcharset_tag_lists)[XCHARSET_LEADING_BYTE(charset) - MIN_LEADING_BYTE]
+= charset_tag_list;
+}
+/* VM calls this, in vm-multiple-frames-possible-p, in the event that you're
+considering taking it out. */
 DEFUN ("device-matching-specifier-tag-list",
 Fdevice_matching_specifier_tag_list,
 0, 1, 0, /*
 Return a list of all specifier tags matching DEVICE.
 list = nconc2 (Fcopy_sequence (Vconsole_type_list), list);
 RETURN_UNGCPRO (list);
 }
-DEFUN ("specifier-tag-predicate", Fspecifier_tag_predicate, 1, 1, 0, /*
+DEFUN ("specifier-tag-device-predicate", Fspecifier_tag_device_predicate,
-Return the predicate for the given specifier tag.
+1, 1, 0, /*
+Return the device predicate for the given specifier tag.
 */
 (tag))
 {
 /* The return value of this function must be GCPRO'd. */
 CHECK_SYMBOL (tag);
 if (NILP (Fvalid_specifier_tag_p (tag)))
 invalid_argument ("Invalid specifier tag",
-		       tag);
+		      tag);
 /* Make up some predicates for the built-in types */
 if (valid_console_type_p (tag))
 return list3 (Qlambda, list1 (Qdevice),
 if (valid_device_class_p (tag))
 return list3 (Qlambda, list1 (Qdevice),
 		  list3 (Qeq, list2 (Qquote, tag),
 			 list2 (Qdevice_class, Qdevice)));
-return XCDR (assq_no_quit (tag, Vuser_defined_tags));
+return XCADR (assq_no_quit (tag, Vuser_defined_tags));
+}
+DEFUN ("specifier-tag-charset-predicate", Fspecifier_tag_charset_predicate,
+1, 1, 0, /*
+Return the charset predicate for the given specifier tag.
+*/
+(tag))
+{
+/* The return value of this function must be GCPRO'd. */
+CHECK_SYMBOL (tag);
+if (NILP (Fvalid_specifier_tag_p (tag)))
+invalid_argument ("Invalid specifier tag",
+		      tag);
+return XCADDR (assq_no_quit (tag, Vuser_defined_tags));
 }
 /* Return true if A "matches" B.  If EXACT_P is 0, A must be a subset of B.
 Otherwise, A must be `equal' to B.  The sets must be canonicalized. */
 static int
 tag_sets_match_p (Lisp_Object a, Lisp_Object b, int exact_p)
 {
 if (!exact_p)
 {
 Lisp_Object tag_set;
 if (!CONSP (inst_pair))
 	{
 	  maybe_sferror (
-				   "Invalid instantiator pair", inst_pair,
+			 "Invalid instantiator pair", inst_pair,
-				     Qspecifier, errb);
+			 Qspecifier, errb);
 	  return Qnil;
 	}
 if (NILP (Fvalid_specifier_tag_set_p (tag_set = XCAR (inst_pair))))
 	{
 	  maybe_invalid_argument (
-				   "Invalid specifier tag", tag_set,
+				  "Invalid specifier tag", tag_set,
-				     Qspecifier, errb);
+				  Qspecifier, errb);
 	  return Qnil;
 	}
 if (NILP (check_valid_instantiator (XCDR (inst_pair), meths, errb)))
 	return Qnil;
 {
 Lisp_Object locale;
 if (!CONSP (spec))
 	{
 	  maybe_sferror (
-				   "Invalid specification list", spec_list,
+			 "Invalid specification list", spec_list,
-				     Qspecifier, errb);
+			 Qspecifier, errb);
 	  return Qnil;
 	}
 if (NILP (Fvalid_specifier_locale_p (locale = XCAR (spec))))
 	{
 	  maybe_invalid_argument (
-				   "Invalid specifier locale", locale,
+				  "Invalid specifier locale", locale,
-				     Qspecifier, errb);
+				  Qspecifier, errb);
 	  return Qnil;
 	}
 if (NILP (check_valid_inst_list (XCDR (spec), meths, errb)))
 	return Qnil;
 /* This gets hit so much that the function call overhead had a
 measurable impact (according to Quantify).  #### We should figure
 out the frequency with which this is called with the various types
 and reorder the check accordingly. */
 #define SPECIFIER_GET_SPEC_LIST(specifier, type)			\
 (type == LOCALE_GLOBAL ? &(XSPECIFIER (specifier)->global_specs)   :	\
 type == LOCALE_DEVICE ? &(XSPECIFIER (specifier)->device_specs)   :	\
 type == LOCALE_FRAME  ? &(XSPECIFIER (specifier)->frame_specs)    :	\
 type == LOCALE_WINDOW ? &(XWEAK_LIST_LIST				\
-			   (XSPECIFIER (specifier)->window_specs)) :	\
+			     (XSPECIFIER (specifier)->window_specs)) :	\
 type == LOCALE_BUFFER ? &(XSPECIFIER (specifier)->buffer_specs)   :	\
 0)
 static Lisp_Object *
 specifier_get_inst_list (Lisp_Object specifier, Lisp_Object locale,
 			 enum spec_locale_type type)
 {
 specifier, and is an enum that corresponds to the values in
 `add-spec-to-specifier'.  The calling routine is responsible for
 validating LOCALE and INST-LIST, but the tag-sets in INST-LIST
 do not need to be canonicalized. */
 /* #### I really need to rethink the after-change
 functions to make them easier to use and more efficient. */
 static void
 specifier_add_spec (Lisp_Object specifier, Lisp_Object locale,
 		    Lisp_Object inst_list, enum spec_add_meth add_meth)
 {
 }
 /* map MAPFUN over the locales in SPECIFIER that are given in LOCALE.
 CLOSURE is passed unchanged to MAPFUN.  LOCALE can be one of
 -- nil (same as `all')
 -- a single locale, locale type, or `all'
 -- a list of locales, locale types, and/or `all'
 MAPFUN is called for each locale and locale type given; for `all',
 it is called for the locale `global' and for the four possible
 locale types.  In each invocation, either LOCALE will be a locale
 and LOCALE_TYPE will be the locale type of this locale,
 or LOCALE will be nil and LOCALE_TYPE will be a locale type.
 If MAPFUN ever returns non-zero, the mapping is halted and the
 value returned is returned from map_specifier().  Otherwise, the
 mapping proceeds to the end and map_specifier() returns 0.
 */
 static int
 map_specifier (Lisp_Object specifier, Lisp_Object locale,
 	       int (*mapfun) (Lisp_Object specifier,
 			      Lisp_Object locale,
 ((LOCALE (TAG-SET . INSTANTIATOR) ...) ...)
 where
 LOCALE := a window, a buffer, a frame, a device, or `global'
 TAG-SET := an unordered list of zero or more TAGS, each of which
-is a symbol
+	     is a symbol
 TAG := a device class (see `valid-device-class-p'), a device type
-(see `valid-console-type-p'), or a tag defined with
+	 (see `valid-console-type-p'), or a tag defined with
-`define-specifier-tag'
+	 `define-specifier-tag'
 INSTANTIATOR := format determined by the type of specifier
 The pair (TAG-SET . INSTANTIATOR) is called an `inst-pair'.
 A list of inst-pairs is called an `inst-list'.
 The pair (LOCALE . INST-LIST) is called a `specification' or `spec'.
 \(The default value of nil is a subset of all tag sets, so in this case
 no instantiators will be screened out.) If EXACT-P is non-nil, however,
 TAG-SET must be equal to an instantiator's tag set for the instantiator
 to be returned.
 */
 (specifier, locale, tag_set, exact_p))
 {
 struct specifier_spec_list_closure cl;
 struct gcpro gcpro1, gcpro2;
 CHECK_SPECIFIER (specifier);
 else
 {
 CHECK_SPECIFIER (dest);
 check_modifiable_specifier (dest);
 if (XSPECIFIER (dest)->methods != XSPECIFIER (specifier)->methods)
-invalid_argument ("Specifiers not of same type", Qunbound);
+	invalid_argument ("Specifiers not of same type", Qunbound);
 }
 cl.dest = dest;
 GCPRO1 (dest);
 map_specifier (specifier, locale, copy_specifier_mapfun,
 				   Lisp_Object matchspec,
 				   Lisp_Object domain,
 				   Lisp_Object inst_list,
 				   Error_Behavior errb, int no_quit,
 				   Lisp_Object depth,
-				   Lisp_Object *instantiator)
+				   Lisp_Object *instantiator,
+				   int no_fallback)
 {
 /* This function can GC */
 Lisp_Specifier *sp;
-Lisp_Object device;
+Lisp_Object device, charset = Qnil, rest;
-Lisp_Object rest;
+int count = specpdl_depth (), respected_charsets = 0;
-int count = specpdl_depth ();
 struct gcpro gcpro1, gcpro2;
+enum font_specifier_matchspec_stages stage = initial;
+#ifdef DEBUG_XEMACS
+int non_ascii;
+#endif
 GCPRO2 (specifier, inst_list);
 sp = XSPECIFIER (specifier);
 device = DOMAIN_DEVICE (domain);
 if (no_quit)
 /* The instantiate method is allowed to call eval.  Since it
 is quite common for this function to get called from somewhere in
 redisplay we need to make sure that quits are ignored.  Otherwise
 Fsignal will abort. */
 specbind (Qinhibit_quit, Qt);
-LIST_LOOP (rest, inst_list)
+#ifdef MULE
+if (CONSP(matchspec) && (CHARSETP(Ffind_charset(XCAR(matchspec)))))
+{
+charset = Ffind_charset(XCAR(matchspec));
+#ifdef DEBUG_XEMACS
+/* This is mostly to have somewhere to set debug breakpoints. */
+if (!EQ(charset, Vcharset_ascii))
+	{
+	  non_ascii = 1;
+	}
+#endif /* DEBUG_XEMACS */
+if (!NILP(XCDR(matchspec)))
+	{
+#define FROB(new_stage) if (EQ(Q##new_stage, XCDR(matchspec)))	\
+	    {							\
+	      stage = new_stage;				\
+	    }
+	  FROB(initial)
+	  else FROB(final)
+	  else assert(0);
+#undef FROB
+	}
+}
+#endif /* MULE */
+LIST_LOOP(rest, inst_list)
 {
 Lisp_Object tagged_inst = XCAR (rest);
 Lisp_Object tag_set = XCAR (tagged_inst);
+Lisp_Object val, the_instantiator;
-if (device_matches_specifier_tag_set_p (device, tag_set))
-	{
+if (!device_matches_specifier_tag_set_p (device, tag_set))
-	  Lisp_Object val = XCDR (tagged_inst);
+	{
-	  Lisp_Object the_instantiator = val;
+	  continue;
+	}
-	  if (HAS_SPECMETH_P (sp, instantiate))
+val = XCDR (tagged_inst);
-	    val = call_with_suspended_errors
+the_instantiator = val;
-	      ((lisp_fn_t) RAW_SPECMETH (sp, instantiate),
-	       Qunbound, Qspecifier, errb, 5, specifier,
+if (!NILP(charset) &&
-	       matchspec, domain, val, depth);
+	  !(charset_matches_specifier_tag_set_p (charset, tag_set, stage)))
+	{
-	  if (!UNBOUNDP (val))
+	  ++respected_charsets;
-	    {
+	  continue;
-	      unbind_to (count);
+	}
-	      UNGCPRO;
-	      if (instantiator)
+if (HAS_SPECMETH_P (sp, instantiate))
-		*instantiator = the_instantiator;
+	val = call_with_suspended_errors
-	      return val;
+	  ((lisp_fn_t) RAW_SPECMETH (sp, instantiate),
-	    }
+	   Qunbound, Qspecifier, errb, 5, specifier,
+	   matchspec, domain, val, depth, no_fallback);
+if (!UNBOUNDP (val))
+	{
+	  unbind_to (count);
+	  UNGCPRO;
+	  if (instantiator)
+	    *instantiator = the_instantiator;
+	  return val;
+	}
+}
+/* We've checked all the tag sets, and checking the charset part of the
+specifier never returned 0 (preventing the attempted instantiation), so
+there's no need to loop for the second time to avoid checking the
+charsets. */
+if (!respected_charsets)
+{
+unbind_to (count);
+UNGCPRO;
+return Qunbound;
+}
+/* Right, didn't instantiate a specifier last time, perhaps because we
+paid attention to the charset-specific aspects of the specifier.  Try
+again without checking the charset information.
+We can't emulate the approach for devices, defaulting to matching all
+character sets for a given specifier, because $random font instantiator
+cannot usefully show all character sets, and indeed having it try is a
+failure on our part.  */
+LIST_LOOP (rest, inst_list)
+{
+Lisp_Object tagged_inst = XCAR (rest);
+Lisp_Object tag_set = XCAR (tagged_inst);
+Lisp_Object val, the_instantiator;
+if (!device_matches_specifier_tag_set_p (device, tag_set))
+	{
+	  continue;
+	}
+val = XCDR (tagged_inst);
+the_instantiator = val;
+if (HAS_SPECMETH_P (sp, instantiate))
+	val = call_with_suspended_errors
+	  ((lisp_fn_t) RAW_SPECMETH (sp, instantiate),
+	   Qunbound, Qspecifier, errb, 5, specifier,
+	   matchspec, domain, val, depth, no_fallback);
+if (!UNBOUNDP (val))
+	{
+	  unbind_to (count);
+	  UNGCPRO;
+	  if (instantiator)
+	    *instantiator = the_instantiator;
+	  return val;
 	}
 }
 unbind_to (count);
 UNGCPRO;
 return Qunbound;
 }
 /* Given a SPECIFIER and a DOMAIN, return a specific instance for that
 specifier. Try to find one by checking the specifier types from most
-specific (buffer) to most general (global).  If we find an instance,
+specific (window) to most general (global).  If we find an instance,
 return it.  Otherwise return Qunbound. */
 #define CHECK_INSTANCE_ENTRY(key, matchspec, type) do {			\
-Lisp_Object *CIE_inst_list =						\
+Lisp_Object *CIE_inst_list =					\
 specifier_get_inst_list (specifier, key, type);			\
 if (CIE_inst_list)							\
 {									\
-Lisp_Object CIE_val =						\
+	Lisp_Object CIE_val =						\
-	specifier_instance_from_inst_list (specifier, matchspec,	\
+	  specifier_instance_from_inst_list (specifier, matchspec,	\
-					   domain, *CIE_inst_list,	\
+					     domain, *CIE_inst_list,	\
-					   errb, no_quit, depth,	\
+					     errb, no_quit, depth,	\
-instantiator);		\
+					     instantiator, no_fallback); \
-if (!UNBOUNDP (CIE_val))						\
+	if (!UNBOUNDP (CIE_val))					\
-	return CIE_val;							\
+	  return CIE_val;						\
 }									\
 } while (0)
 /* We accept any window, frame or device domain and do our checking
 starting from as specific a locale type as we can determine from the
 domain we are passed and going on up through as many other locale types
 as we can determine.  In practice, when called from redisplay the
 }
 assert (CONSP (sp->fallback));
 return specifier_instance_from_inst_list (specifier, matchspec, domain,
 					    sp->fallback, errb, no_quit,
-					    depth, instantiator);
+					    depth, instantiator,
+					    no_fallback);
 }
 #undef CHECK_INSTANCE_ENTRY
 Lisp_Object
 specifier_instance (Lisp_Object specifier, Lisp_Object matchspec,
 e.g., a buffer-local display table that only gives values for particular
 characters.  All other characters are handled as if the buffer-local
 display table is not there. (Chartable specifiers are not yet
 implemented.)
--- For font specifiers, MATCHSPEC should be a list (CHARSET . SECOND-STAGE-P),
+-- For font specifiers, MATCHSPEC should be a cons (CHARSET . STAGE).
-and the specification (a font string) must have a registry that matches
+The defined stages are currently `initial' and `final'.  On X11, 'initial
-the charset's registry.  (This only makes sense with Mule support.) This
+is used when the font matching process is looking for fonts that match
-makes it easy to choose a font that can display a particular
+the desired registries of the charset--see the `charset-registries'
-character. (This is what redisplay does, in fact.) SECOND-STAGE-P means
+function.  If that match process fails, then the 'final stage comes into
-to ignore the font's registry and instead look at the characters in the
+play; this means that a more general lookup is desired, and that a font
-font to see if the font can support the charset.  This currently only makes
+doesn't necessarily have to match the desired XLFD for the face, just the
-sense under MS Windows.
+charset repertoire for this charset.  It also means that the charset
+registry and encoding used will be `iso10646-1', and the characters will
+be converted to display using that registry.
+See `define-specifier-tag' for details on how to create a tag that
+specifies a given character set and stage combination.  You can supply
+such a tag to `set-face-font' in order to set a face's font for that
+character set and stage combination.
 */
 (specifier, matchspec, domain, default_, no_fallback))
 {
 return specifier_matching_foo (specifier, matchspec, domain, default_,
 				 no_fallback, 0);
 GCPRO1 (built_up_list);
 built_up_list = build_up_processed_list (specifier, domain, inst_list);
 if (!NILP (built_up_list))
 val = specifier_instance_from_inst_list (specifier, matchspec, domain,
 					     built_up_list, ERROR_ME,
-					     0, Qzero, &instantiator);
+					     0, Qzero, &instantiator, 0);
 UNGCPRO;
 return UNBOUNDP (val) ? default_ : want_instantiator ? instantiator : val;
 }
 return specifier_matching_foo_from_inst_list (specifier, Qunbound,
 						domain, inst_list, default_,
 						0);
 }
-DEFUN ("specifier-instantiator-from-inst-list", Fspecifier_instantiator_from_inst_list,
+DEFUN ("specifier-instantiator-from-inst-list",
-3, 4, 0, /*
+Fspecifier_instantiator_from_inst_list, 3, 4, 0, /*
 Attempt to convert an inst-list into an instance; return instantiator.
 This is identical to `specifier-instance-from-inst-list' but returns
 the instantiator used to generate the instance, rather than the instance
 itself.
 */
 You nearly always need to do something, e.g. set a dirty flag.)
 If you create a built-in specifier, you should do the following:
 - Make sure the file you create the specifier in has a
 specifier_vars_of_foo() function.  If not, create it, declare it in
 symsinit.h, and make sure it's called in the appropriate place in
 emacs.c.
 - In specifier_vars_of_foo(), do a DEFVAR_SPECIFIER(), followed by
 initializing the specifier using Fmake_specifier(), followed by
 set_specifier_fallback(), followed (optionally) by
 set_specifier_caching().
 - If you used set_specifier_caching(), make sure to create the
 appropriate value-changed functions.  Also make sure to add the
 appropriate slots where the values are cached to frameslots.h and
 winslots.h.
 Do a grep for menubar_visible_p for an example.
 */
 /* #### It would be nice if the specifier caching automatically knew
 {
 Lisp_Specifier *sp = XSPECIFIER (specifier);
 assert (!GHOST_SPECIFIER_P (sp));
 if (!sp->caching)
-sp->caching = xnew_and_zero (struct specifier_caching);
+#ifdef NEW_GC
+sp->caching = alloc_lrecord_type (struct specifier_caching,
+				      &lrecord_specifier_caching);
+#else /* not NEW_GC */
+sp->caching = xnew_and_zero (struct specifier_caching);
+#endif /* not NEW_GC */
 sp->caching->offset_into_struct_window = struct_window_offset;
 sp->caching->value_changed_in_window = value_changed_in_window;
 sp->caching->offset_into_struct_frame = struct_frame_offset;
 sp->caching->value_changed_in_frame = value_changed_in_frame;
 if (struct_window_offset)
 /*                        Display table specifier type                  */
 /************************************************************************/
 DEFINE_SPECIFIER_TYPE (display_table);
-#define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator)		   \
+#define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator)		\
-(VECTORP (instantiator)						   \
+(VECTORP (instantiator)						\
-|| (CHAR_TABLEP (instantiator)					   \
+|| (CHAR_TABLEP (instantiator)					\
-&& (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR	   \
+&& (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR	\
 	   || XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_GENERIC)) \
 || RANGE_TABLEP (instantiator))
 static void
 display_table_validate (Lisp_Object instantiator)
 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (instantiator))
 	{
 	lose:
 	  dead_wrong_type_argument
 	    (display_table_specifier_methods->predicate_symbol,
-				    instantiator);
+	     instantiator);
 	}
 }
 }
 DEFUN ("display-table-specifier-p", Fdisplay_table_specifier_p, 1, 1, 0, /*
 void
 syms_of_specifier (void)
 {
 INIT_LISP_OBJECT (specifier);
+#ifdef NEW_GC
+INIT_LISP_OBJECT (specifier_caching);
+#endif /* NEW_GC */
 DEFSYMBOL (Qspecifierp);
 DEFSYMBOL (Qconsole_type);
 DEFSYMBOL (Qdevice_class);
 DEFSUBR (Fvalid_specifier_tag_set_p);
 DEFSUBR (Fcanonicalize_tag_set);
 DEFSUBR (Fdevice_matches_specifier_tag_set_p);
 DEFSUBR (Fdefine_specifier_tag);
 DEFSUBR (Fdevice_matching_specifier_tag_list);
 DEFSUBR (Fspecifier_tag_list);
-DEFSUBR (Fspecifier_tag_predicate);
+DEFSUBR (Fspecifier_tag_device_predicate);
+DEFSUBR (Fspecifier_tag_charset_predicate);
 DEFSUBR (Fcheck_valid_instantiator);
 DEFSUBR (Fvalid_instantiator_p);
 DEFSUBR (Fcheck_valid_inst_list);
 DEFSUBR (Fvalid_inst_list_p);
 Vuser_defined_tags = Qnil;
 staticpro (&Vuser_defined_tags);
 Vunlock_ghost_specifiers = Qnil;
 staticpro (&Vunlock_ghost_specifiers);
-}
+Vcharset_tag_lists = make_vector(NUM_LEADING_BYTES, Qnil);
+staticpro (&Vcharset_tag_lists);
+}

Mercurial > hg > xemacs-beta

comparison src/specifier.c @ 5118:e0db3c197671 ben-lisp-object