diff src/objects.c @ 5128:7be849cb8828 ben-lisp-object

merge
author Ben Wing <ben@xemacs.org>
date Sun, 07 Mar 2010 02:09:59 -0600
parents a9c41067dd88 5502045ec510
children f965e31a35f0
line wrap: on
line diff
--- a/src/objects.c	Fri Mar 05 04:08:17 2010 -0600
+++ b/src/objects.c	Sun Mar 07 02:09:59 2010 -0600
@@ -2,6 +2,7 @@
    Copyright (C) 1995 Free Software Foundation, Inc.
    Copyright (C) 1995 Board of Trustees, University of Illinois.
    Copyright (C) 1995, 1996, 2002, 2004, 2005, 2010 Ben Wing.
+   Copyright (C) 2010 Didier Verna
 
 This file is part of XEmacs.
 
@@ -1210,6 +1211,130 @@
 }
 
 
+/*****************************************************************************
+ Face Background Placement Object
+ ****************************************************************************/
+Lisp_Object Qabsolute, Qrelative;
+
+static const struct memory_description
+face_background_placement_specifier_description[] = {
+  { XD_LISP_OBJECT, offsetof (struct face_background_placement_specifier,
+			      face) },
+  { XD_END }
+};
+
+DEFINE_SPECIFIER_TYPE_WITH_DATA (face_background_placement);
+Lisp_Object Qface_background_placement;
+
+static void
+face_background_placement_create (Lisp_Object obj)
+{
+  Lisp_Specifier *face_background_placement
+    = XFACE_BACKGROUND_PLACEMENT_SPECIFIER (obj);
+
+  FACE_BACKGROUND_PLACEMENT_SPECIFIER_FACE (face_background_placement) = Qnil;
+}
+
+static void
+face_background_placement_mark (Lisp_Object obj)
+{
+  Lisp_Specifier *face_background_placement
+    = XFACE_BACKGROUND_PLACEMENT_SPECIFIER (obj);
+
+  mark_object
+    (FACE_BACKGROUND_PLACEMENT_SPECIFIER_FACE (face_background_placement));
+}
+
+/* No equal or hash methods; ignore the face the background-placement is based
+   off of for `equal' */
+
+extern Lisp_Object Qbackground_placement;
+
+static Lisp_Object
+face_background_placement_instantiate (Lisp_Object UNUSED (specifier),
+				       Lisp_Object UNUSED (matchspec),
+				       Lisp_Object domain,
+				       Lisp_Object instantiator,
+				       Lisp_Object depth,
+				       int no_fallback)
+{
+  /* When called, we're inside of call_with_suspended_errors(),
+     so we can freely error. */
+  if (EQ (instantiator, Qabsolute) || EQ (instantiator, Qrelative))
+    return instantiator;
+  else if (VECTORP (instantiator))
+    {
+      assert (XVECTOR_LENGTH (instantiator) == 1);
+
+      return FACE_PROPERTY_INSTANCE_1
+	(Fget_face (XVECTOR_DATA (instantiator)[0]),
+	 Qbackground_placement, domain, ERROR_ME, no_fallback, depth);
+    }
+  else
+    ABORT ();	/* Eh? */
+
+  return Qunbound;
+}
+
+static void
+face_background_placement_validate (Lisp_Object instantiator)
+{
+  if (EQ (instantiator, Qabsolute) || EQ (instantiator, Qrelative))
+    return;
+  else if (VECTORP (instantiator) &&
+	   (XVECTOR_LENGTH (instantiator) == 1))
+    {
+      Lisp_Object face = XVECTOR_DATA (instantiator)[0];
+
+      Fget_face (face); /* just to check that the face exists -- dvl */
+    }
+  else if (VECTORP (instantiator))
+    sferror ("Wrong length for background-placement inheritance spec",
+	     instantiator);
+  else
+    invalid_argument
+      ("\
+Background-placement instantiator must be absolute, relative or vector",
+       instantiator);
+}
+
+static void
+face_background_placement_after_change (Lisp_Object specifier,
+					Lisp_Object locale)
+{
+  Lisp_Object face
+    = FACE_BACKGROUND_PLACEMENT_SPECIFIER_FACE
+    (XFACE_BACKGROUND_PLACEMENT_SPECIFIER (specifier));
+
+  if (!NILP (face))
+    {
+      face_property_was_changed (face, Qbackground_placement, locale);
+      if (BUFFERP (locale))
+	XBUFFER (locale)->buffer_local_face_property = 1;
+    }
+}
+
+void
+set_face_background_placement_attached_to (Lisp_Object obj, Lisp_Object face)
+{
+  Lisp_Specifier *face_background_placement
+    = XFACE_BACKGROUND_PLACEMENT_SPECIFIER (obj);
+
+  FACE_BACKGROUND_PLACEMENT_SPECIFIER_FACE (face_background_placement) = face;
+}
+
+DEFUN ("face-background-placement-specifier-p", Fface_background_placement_specifier_p, 1, 1, 0, /*
+Return non-nil if OBJECT is a face-background-placement specifier.
+
+See `make-face-background-placement-specifier' for a description of possible
+face-background-placement instantiators.
+*/
+       (object))
+{
+  return FACE_BACKGROUND_PLACEMENT_SPECIFIERP (object) ? Qt : Qnil;
+}
+
+
 /************************************************************************/
 /*                            initialization                            */
 /************************************************************************/
@@ -1223,6 +1348,7 @@
   DEFSUBR (Fcolor_specifier_p);
   DEFSUBR (Ffont_specifier_p);
   DEFSUBR (Fface_boolean_specifier_p);
+  DEFSUBR (Fface_background_placement_specifier_p);
 
   DEFSYMBOL_MULTIWORD_PREDICATE (Qcolor_instancep);
   DEFSUBR (Fmake_color_instance);
@@ -1247,6 +1373,10 @@
 
   /* Qcolor, Qfont defined in general.c */
   DEFSYMBOL (Qface_boolean);
+
+  DEFSYMBOL (Qface_background_placement);
+  DEFSYMBOL (Qabsolute);
+  DEFSYMBOL (Qrelative);
 }
 
 void
@@ -1256,26 +1386,35 @@
   INITIALIZE_SPECIFIER_TYPE_WITH_DATA (font, "font", "font-specifier-p");
   INITIALIZE_SPECIFIER_TYPE_WITH_DATA (face_boolean, "face-boolean",
 					 "face-boolean-specifier-p");
+  INITIALIZE_SPECIFIER_TYPE_WITH_DATA (face_background_placement,
+				       "face-background-placement",
+				       "\
+face-background-placement-specifier-p");
 
   SPECIFIER_HAS_METHOD (color, instantiate);
   SPECIFIER_HAS_METHOD (font, instantiate);
   SPECIFIER_HAS_METHOD (face_boolean, instantiate);
+  SPECIFIER_HAS_METHOD (face_background_placement, instantiate);
 
   SPECIFIER_HAS_METHOD (color, validate);
   SPECIFIER_HAS_METHOD (font, validate);
   SPECIFIER_HAS_METHOD (face_boolean, validate);
+  SPECIFIER_HAS_METHOD (face_background_placement, validate);
 
   SPECIFIER_HAS_METHOD (color, create);
   SPECIFIER_HAS_METHOD (font, create);
   SPECIFIER_HAS_METHOD (face_boolean, create);
+  SPECIFIER_HAS_METHOD (face_background_placement, create);
 
   SPECIFIER_HAS_METHOD (color, mark);
   SPECIFIER_HAS_METHOD (font, mark);
   SPECIFIER_HAS_METHOD (face_boolean, mark);
+  SPECIFIER_HAS_METHOD (face_background_placement, mark);
 
   SPECIFIER_HAS_METHOD (color, after_change);
   SPECIFIER_HAS_METHOD (font, after_change);
   SPECIFIER_HAS_METHOD (face_boolean, after_change);
+  SPECIFIER_HAS_METHOD (face_background_placement, after_change);
 
 #ifdef MULE
   SPECIFIER_HAS_METHOD (font, validate_matchspec);
@@ -1288,6 +1427,7 @@
   REINITIALIZE_SPECIFIER_TYPE (color);
   REINITIALIZE_SPECIFIER_TYPE (font);
   REINITIALIZE_SPECIFIER_TYPE (face_boolean);
+  REINITIALIZE_SPECIFIER_TYPE (face_background_placement);
 }
 
 void