xemacs-beta: src/specifier.c comparison

comparison src/specifier.c @ 280:7df0dd720c89 r21-0b38

Import from CVS: tag r21-0b38

author	cvs
date	Mon, 13 Aug 2007 10:32:22 +0200
parents	6330739388db
children	558f606b08ae

comparison

equal deleted inserted replaced

-:c20b2fb5bb0a
+:7df0dd720c89
 /* Synched up with: Not in FSF. */
 /* Design by Ben Wing;
 Original version by Chuck Thompson;
-rewritten by Ben Wing */
+rewritten by Ben Wing;
+Magic specifiers by Kirill Katsnelson;
+*/
 #include <config.h>
 #include "lisp.h"
 #include "buffer.h"
 static Lisp_Object Vcached_specifiers;
 /* Do NOT mark through this, or specifiers will never be GC'd. */
 static Lisp_Object Vall_specifiers;
-static Lisp_Object Vreveal_ghoste_specifiers;
+static Lisp_Object Vunlock_ghost_specifiers;
 /* #### The purpose of this is to check for inheritance loops
 in specifiers that can inherit from other specifiers, but it's
 not yet implemented.
 #### Look into this for 19.14. */
-static Lisp_Object_dynarr current_specifiers;
+/* static Lisp_Object_dynarr current_specifiers; */
 static void recompute_cached_specifier_everywhere (Lisp_Object specifier);
 EXFUN (Fspecifier_specs, 4);
 EXFUN (Fremove_specifier, 4);
 (s1->methods == s2->methods &&
 internal_equal (s1->global_specs, s2->global_specs, depth) &&
 internal_equal (s1->device_specs, s2->device_specs, depth) &&
 internal_equal (s1->frame_specs,  s2->frame_specs,  depth) &&
 internal_equal (s1->window_specs, s2->window_specs, depth) &&
-internal_equal (s1->buffer_specs, s2->buffer_specs, depth));
+internal_equal (s1->buffer_specs, s2->buffer_specs, depth) &&
-/* #### Why do not compare fallbacks here? */
+internal_equal (s1->fallback,     s2->fallback,     depth));
 if (retval && HAS_SPECMETH_P (s1, equal))
 retval = SPECMETH (s1, equal, (o1, o2, depth - 1));
 Vinhibit_quit = old_inhibit_quit;
 !NILP (Fvalid_specifier_locale_type_p (locale)))
 return;
 signal_simple_error ("Invalid specifier locale or locale type", locale);
 }
-DEFUN ("specifier-locale-type-from-locale",
+DEFUN ("specifier-locale-type-from-locale", Fspecifier_locale_type_from_locale,
-Fspecifier_locale_type_from_locale, 1, 1, 0, /*
+1, 1, 0, /*
 Given a specifier LOCALE, return its type.
 */
 (locale))
 {
 /* This cannot GC. */
 else
 	XCDR (XCAR (rest2)) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
 }
 }
-DEFUN ("device-matching-specifier-tag-list",
+DEFUN ("device-matching-specifier-tag-list", Fdevice_matching_specifier_tag_list,
-Fdevice_matching_specifier_tag_list, 0, 1, 0, /*
+0, 1, 0, /*
 Return a list of all specifier tags matching DEVICE.
 DEVICE defaults to the selected device if omitted.
 */
 (device))
 {
 signal_simple_error ("Invalid `how-to-add' flag", how_to_add);
 return SPEC_PREPEND;		/* not reached */
 }
-/* Given a specifier object SPEC, return its bodily specifier for a
+/* Given a specifier object SPEC, return bodily specifier if SPEC is a
 ghost specifier, otherwise return the object itself
 */
 static Lisp_Object
 bodily_specifier (Lisp_Object spec)
 {
 return (GHOST_SPECIFIER_P (XSPECIFIER (spec))
 	  ? XSPECIFIER(spec)->magic_parent : spec);
 }
-/* Given a specifier object SPEC, return a specifier to be operated on
+/* Signal error if (specifier SPEC is read-only.
-by external lisp function. This is a ghost specifier for a magic
+Read only are ghost specifiers unless Vunlock_ghost_specifiers is
-specifier when and only when Vreveal_ghoste_specifiers is non-nil,
+non-nil.  All other specifiers are read-write.
-otherwise SPEC itself.
+*/
-*/
+static void
+check_modifiable_specifier (Lisp_Object spec)
+{
+if (NILP (Vunlock_ghost_specifiers)
+&& GHOST_SPECIFIER_P (XSPECIFIER (spec)))
+signal_simple_error ("Attempt to modify read-only specifier",
+			 list1 (spec));
+}
+/* Helper function which unwind protects the value of
+Vunlock_ghost_specifiers, then sets it to non-nil value */
 static Lisp_Object
-maybe_ghost_specifier (Lisp_Object spec)
+restore_unlock_value (Lisp_Object val)
 {
-return (!NILP (Vreveal_ghoste_specifiers)
+Vunlock_ghost_specifiers = val;
-	  && BODILY_SPECIFIER_P (XSPECIFIER (spec))
-	  ? XSPECIFIER(spec)->fallback : spec);
-}
-/* Helper function which unwind protects the value of
-Vreveal_ghoste_specifiers, then sets it to non-nil value */
-static Lisp_Object
-restore_reveal_value (Lisp_Object val)
-{
-Vreveal_ghoste_specifiers = val;
 return val;
 }
 int
-reveal_ghost_specifiers_protected (void)
+unlock_ghost_specifiers_protected (void)
 {
 int depth = specpdl_depth ();
-record_unwind_protect (restore_reveal_value,
+record_unwind_protect (restore_unlock_value,
-			 Vreveal_ghoste_specifiers);
+			 Vunlock_ghost_specifiers);
-Vreveal_ghoste_specifiers = Qt;
+Vunlock_ghost_specifiers = Qt;
 return depth;
 }
 /* This gets hit so much that the function call overhead had a
 measurable impact (according to Quantify).  #### We should figure
 enum spec_add_meth add_meth;
 Lisp_Object inst_list;
 struct gcpro gcpro1;
 CHECK_SPECIFIER (specifier);
+check_modifiable_specifier (specifier);
 locale = decode_locale (locale);
 check_valid_instantiator (instantiator,
 			    decode_specifier_type
 			    (Fspecifier_type (specifier), ERROR_ME),
 			    ERROR_ME);
 tag_set = decode_specifier_tag_set (tag_set);
 add_meth = decode_how_to_add_specification (how_to_add);
 inst_list = list1 (Fcons (tag_set, instantiator));
 GCPRO1 (inst_list);
-specifier_add_spec (maybe_ghost_specifier (specifier),
+specifier_add_spec (specifier, locale, inst_list, add_meth);
-		      locale, inst_list, add_meth);
 recompute_cached_specifier_everywhere (specifier);
 RETURN_UNGCPRO (Qnil);
 }
 DEFUN ("add-spec-list-to-specifier", Fadd_spec_list_to_specifier, 2, 3, 0, /*
 {
 enum spec_add_meth add_meth;
 Lisp_Object rest;
 CHECK_SPECIFIER (specifier);
+check_modifiable_specifier (specifier);
 check_valid_spec_list (spec_list,
 			 decode_specifier_type
 			 (Fspecifier_type (specifier), ERROR_ME),
 			 ERROR_ME);
 add_meth = decode_how_to_add_specification (how_to_add);
 /* Placating the GCC god. */
 Lisp_Object specification = XCAR (rest);
 Lisp_Object locale    = XCAR (specification);
 Lisp_Object inst_list = XCDR (specification);
-specifier_add_spec (maybe_ghost_specifier (specifier),
+specifier_add_spec (specifier, locale, inst_list, add_meth);
-			  locale, inst_list, add_meth);
 }
 recompute_cached_specifier_everywhere (specifier);
 return Qnil;
 }
 void
 add_spec_to_ghost_specifier (Lisp_Object specifier, Lisp_Object instantiator,
 			     Lisp_Object locale, Lisp_Object tag_set,
 			     Lisp_Object how_to_add)
 {
-int depth = reveal_ghost_specifiers_protected ();
+int depth = unlock_ghost_specifiers_protected ();
-Fadd_spec_to_specifier (specifier, instantiator, locale,
+Fadd_spec_to_specifier (XSPECIFIER(specifier)->fallback,
-			  tag_set, how_to_add);
+			  instantiator, locale, tag_set, how_to_add);
 unbind_to (depth, Qnil);
 }
 struct specifier_spec_list_closure
 {
 struct gcpro gcpro1, gcpro2;
 CHECK_SPECIFIER (specifier);
 cl.head = cl.tail = Qnil;
 GCPRO2 (cl.head, cl.tail);
-map_specifier (maybe_ghost_specifier (specifier),
+map_specifier (specifier, locale, specifier_spec_list_mapfun,
-		 locale, specifier_spec_list_mapfun,
 		 tag_set, exact_p, &cl);
 UNGCPRO;
 return cl.head;
 }
 	locale = XCAR (locale);
 GCPRO1 (tag_set);
 tag_set = decode_specifier_tag_set (tag_set);
 tag_set = canonicalize_tag_set (tag_set);
 RETURN_UNGCPRO
-	(specifier_get_external_inst_list (maybe_ghost_specifier (specifier),
+	(specifier_get_external_inst_list (specifier, locale,
-					   locale,
 					   locale_type_from_locale (locale),
-					   tag_set, !NILP (exact_p),
+					   tag_set, !NILP (exact_p), 1, 1));
-					   1, 1));
 }
 else
 return Fspecifier_spec_list (specifier, locale, tag_set, exact_p);
 }
 to be removed.
 */
 (specifier, locale, tag_set, exact_p))
 {
 CHECK_SPECIFIER (specifier);
-map_specifier (maybe_ghost_specifier (specifier), locale,
+check_modifiable_specifier (specifier);
-		 remove_specifier_mapfun, tag_set, exact_p, 0);
+map_specifier (specifier, locale, remove_specifier_mapfun,
+		 tag_set, exact_p, 0);
 recompute_cached_specifier_everywhere (specifier);
 return Qnil;
 }
 void
 remove_ghost_specifier (Lisp_Object specifier, Lisp_Object locale,
 			Lisp_Object tag_set, Lisp_Object exact_p)
 {
-int depth = reveal_ghost_specifiers_protected ();
+int depth = unlock_ghost_specifiers_protected ();
-Fremove_specifier (specifier, locale, tag_set, exact_p);
+Fremove_specifier (XSPECIFIER(specifier)->fallback,
+		     locale, tag_set, exact_p);
 unbind_to (depth, Qnil);
 }
 struct copy_specifier_closure
 {
 dest = make_specifier (XSPECIFIER (specifier)->methods);
 }
 else
 {
 CHECK_SPECIFIER (dest);
+check_modifiable_specifier (dest);
 if (XSPECIFIER (dest)->methods != XSPECIFIER (specifier)->methods)
 	error ("Specifiers not of same type");
 }
 cl.dest = dest;
 GCPRO1 (dest);
-map_specifier (maybe_ghost_specifier (specifier), locale,
+map_specifier (specifier, locale, copy_specifier_mapfun,
-		 copy_specifier_mapfun, tag_set, exact_p, &cl);
+		 tag_set, exact_p, &cl);
 UNGCPRO;
 recompute_cached_specifier_everywhere (dest);
 return dest;
 }
 frame = domain;
 else if (DEVICEP (domain))
 device = domain;
 else
 /* #### dmoore - dammit, this should just signal an error or something
-shouldn't it? */
+shouldn't it?
+#### No. Errors are handled in Lisp primitives implementation.
+Invalid domain is a design error here - kkm. */
 abort ();
 if (NILP (buffer) && !NILP (window))
 buffer = XWINDOW (window)->buffer;
 if (NILP (frame) && !NILP (window))
 Lisp_Object instance;
 CHECK_SPECIFIER (specifier);
 domain = decode_domain (domain);
-instance = specifier_instance (maybe_ghost_specifier (specifier),
+instance = specifier_instance (specifier, Qunbound, domain, ERROR_ME, 0,
-				 Qunbound, domain, ERROR_ME, 0,
 				 !NILP (no_fallback), Qzero);
 return UNBOUNDP (instance) ? default_ : instance;
 }
 DEFUN ("specifier-matching-instance", Fspecifier_matching_instance, 2, 5, 0, /*
 CHECK_SPECIFIER (specifier);
 check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
 				   ERROR_ME);
 domain = decode_domain (domain);
-instance = specifier_instance (maybe_ghost_specifier (specifier),
+instance = specifier_instance (specifier, matchspec, domain, ERROR_ME,
-				 matchspec, domain, ERROR_ME,
 				 0, !NILP (no_fallback), Qzero);
 return UNBOUNDP (instance) ? default_ : instance;
 }
-DEFUN ("specifier-instance-from-inst-list",
+DEFUN ("specifier-instance-from-inst-list", Fspecifier_instance_from_inst_list,
-Fspecifier_instance_from_inst_list, 3, 4, 0, /*
+3, 4, 0, /*
 Attempt to convert a particular inst-list into an instance.
 This attempts to instantiate INST-LIST in the given DOMAIN,
 as if INST-LIST existed in a specification in SPECIFIER.  If
 the instantiation fails, DEFAULT is returned.  In most circumstances,
 you should not use this function; use `specifier-instance' instead.
 CHECK_SPECIFIER (specifier);
 check_valid_domain (domain);
 check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
 GCPRO1 (built_up_list);
-built_up_list = build_up_processed_list (maybe_ghost_specifier (specifier),
+built_up_list = build_up_processed_list (specifier, domain, inst_list);
-					   domain, inst_list);
 if (!NILP (built_up_list))
-val = specifier_instance_from_inst_list (maybe_ghost_specifier (specifier),
+val = specifier_instance_from_inst_list (specifier, Qunbound, domain,
-					     Qunbound, domain, built_up_list,
+					     built_up_list, ERROR_ME,
-					     ERROR_ME, 0, Qzero);
+					     0, Qzero);
 UNGCPRO;
 return UNBOUNDP (val) ? default_ : val;
 }
-DEFUN ("specifier-matching-instance-from-inst-list",
+DEFUN ("specifier-matching-instance-from-inst-list", Fspecifier_matching_instance_from_inst_list,
-Fspecifier_matching_instance_from_inst_list, 4, 5, 0, /*
+4, 5, 0, /*
 Attempt to convert a particular inst-list into an instance.
 This attempts to instantiate INST-LIST in the given DOMAIN
 \(as if INST-LIST existed in a specification in SPECIFIER),
 matching the specifications against MATCHSPEC.
 check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
 				   ERROR_ME);
 check_valid_domain (domain);
 check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
 GCPRO1 (built_up_list);
-built_up_list = build_up_processed_list (maybe_ghost_specifier (specifier),
+built_up_list = build_up_processed_list (specifier, domain, inst_list);
-					   domain, inst_list);
 if (!NILP (built_up_list))
-val = specifier_instance_from_inst_list (maybe_ghost_specifier (specifier),
+val = specifier_instance_from_inst_list (specifier, matchspec, domain,
-					     matchspec, domain, built_up_list,
+					     built_up_list, ERROR_ME,
-					     ERROR_ME, 0, Qzero);
+					     0, Qzero);
 UNGCPRO;
 return UNBOUNDP (val) ? default_ : val;
 }
 Vall_specifiers = Qnil;
 Vuser_defined_tags = Qnil;
 staticpro (&Vuser_defined_tags);
-Vreveal_ghoste_specifiers = Qnil;
+Vunlock_ghost_specifiers = Qnil;
-staticpro (&Vreveal_ghoste_specifiers);
+staticpro (&Vunlock_ghost_specifiers);
 }

Mercurial > hg > xemacs-beta

comparison src/specifier.c @ 280:7df0dd720c89 r21-0b38