diff src/glyphs.c @ 5178:97eb4942aec8

merge
author Ben Wing <ben@xemacs.org>
date Mon, 29 Mar 2010 21:28:13 -0500
parents 8b2f75cecb89 1fae11d56ad2
children 71ee43b8a74d
line wrap: on
line diff
--- a/src/glyphs.c	Tue Feb 23 07:28:35 2010 -0600
+++ b/src/glyphs.c	Mon Mar 29 21:28:13 2010 -0500
@@ -4,7 +4,7 @@
    Copyright (C) 1995, 1996, 2000, 2001, 2002, 2004, 2005 Ben Wing
    Copyright (C) 1995 Sun Microsystems
    Copyright (C) 1998, 1999, 2000 Andy Piper
-   Copyright (C) 2007 Didier Verna
+   Copyright (C) 2007, 2010 Didier Verna
 
 This file is part of XEmacs.
 
@@ -992,7 +992,7 @@
   Lisp_Image_Instance *ii = XIMAGE_INSTANCE (obj);
 
   if (print_readably)
-    printing_unreadable_lcrecord (obj, 0);
+    printing_unreadable_lisp_object (obj, 0);
   write_fmt_string_lisp (printcharfun, "#<image-instance (%s) ", 1,
 			 Fimage_instance_type (obj));
   if (!NILP (ii->name))
@@ -1108,20 +1108,19 @@
 
   MAYBE_DEVMETH (DOMAIN_XDEVICE (ii->domain), print_image_instance,
 		 (ii, printcharfun, escapeflag));
-  write_fmt_string (printcharfun, " 0x%x>", ii->header.uid);
+  write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj));
 }
 
 static void
-finalize_image_instance (void *header, int for_disksave)
-{
-  Lisp_Image_Instance *i = (Lisp_Image_Instance *) header;
+finalize_image_instance (Lisp_Object obj)
+{
+  Lisp_Image_Instance *i = XIMAGE_INSTANCE (obj);
 
   /* objects like this exist at dump time, so don't bomb out. */
   if (IMAGE_INSTANCE_TYPE (i) == IMAGE_NOTHING
       ||
       NILP (IMAGE_INSTANCE_DEVICE (i)))
     return;
-  if (for_disksave) finalose (i);
 
   /* We can't use the domain here, because it might have
      disappeared. */
@@ -1314,21 +1313,19 @@
 		 0));
 }
 
-DEFINE_LRECORD_IMPLEMENTATION ("image-instance", image_instance,
-			       0, /*dumpable-flag*/
-			       mark_image_instance, print_image_instance,
-			       finalize_image_instance, image_instance_equal,
-			       image_instance_hash,
-			       image_instance_description,
-			       Lisp_Image_Instance);
+DEFINE_NODUMP_LISP_OBJECT ("image-instance", image_instance,
+			   mark_image_instance, print_image_instance,
+			   finalize_image_instance, image_instance_equal,
+			   image_instance_hash,
+			   image_instance_description,
+			   Lisp_Image_Instance);
 
 static Lisp_Object
 allocate_image_instance (Lisp_Object governing_domain, Lisp_Object parent,
 			 Lisp_Object instantiator)
 {
-  Lisp_Image_Instance *lp =
-    ALLOC_LCRECORD_TYPE (Lisp_Image_Instance, &lrecord_image_instance);
-  Lisp_Object val;
+  Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (image_instance);
+  Lisp_Image_Instance *lp = XIMAGE_INSTANCE (obj);
 
   /* It's not possible to simply keep a record of the domain in which
      the instance was instantiated. This is because caching may mean
@@ -1351,10 +1348,9 @@
   /* So that layouts get done. */
   lp->layout_changed = 1;
 
-  val = wrap_image_instance (lp);
   MARK_GLYPHS_CHANGED;
 
-  return val;
+  return obj;
 }
 
 static enum image_instance_type
@@ -1994,7 +1990,7 @@
      device-specific method to copy the window-system subobject. */
   new_ = allocate_image_instance (XIMAGE_INSTANCE_DOMAIN (image_instance),
 				 Qnil, Qnil);
-  COPY_LCRECORD (XIMAGE_INSTANCE (new_), XIMAGE_INSTANCE (image_instance));
+  copy_lisp_object (new_, image_instance);
   /* note that if this method returns non-zero, this method MUST
      copy any window-system resources, so that when one image instance is
      freed, the other one is not hosed. */
@@ -2521,15 +2517,16 @@
 /*                        pixmap file functions                         */
 /************************************************************************/
 
-/* If INSTANTIATOR refers to inline data, return Qt.
-   If INSTANTIATOR refers to data in a file, return the full filename
-   if it exists, Qnil if there's no console method for locating the file, or
-   (filename) if there was an error locating the file.
+/* - If INSTANTIATOR refers to inline data, or there is no file keyword, we
+     have nothing to do, so return Qt.
+   - If INSTANTIATOR refers to data in a file, return the full filename
+     if it exists; otherwise, return '(filename), meaning "file not found".
+   - If there is no locate_pixmap_file method for this console, return Qnil.
 
    FILE_KEYWORD and DATA_KEYWORD are symbols specifying the
    keywords used to look up the file and inline data,
-   respectively, in the instantiator.  Normally these would
-   be Q_file and Q_data, but might be different for mask data. */
+   respectively, in the instantiator.  These would be Q_file and Q_data,
+   Q_mask_file or Q_mask_data. */
 
 Lisp_Object
 potential_pixmap_file_instantiator (Lisp_Object instantiator,
@@ -2736,18 +2733,20 @@
   return Qnil; /* not reached */
 }
 
+/* This function attempts to find implicit mask files by appending "Mask" or
+   "msk" to the original bitmap file name. This is more or less standard: a
+   number of bitmaps in /usr/include/X11/bitmaps use it. */
 Lisp_Object
 xbm_mask_file_munging (Lisp_Object alist, Lisp_Object file,
 		       Lisp_Object mask_file, Lisp_Object console_type)
 {
-  /* This is unclean but it's fairly standard -- a number of the
-     bitmaps in /usr/include/X11/bitmaps use it -- so we support
-     it. */
-  if (EQ (mask_file, Qt)
-      /* don't override explicitly specified mask data. */
-      && NILP (assq_no_quit (Q_mask_data, alist))
-      && !EQ (file, Qt))
+  /* Let's try to find an implicit mask file if we have neither an explicit
+     mask file name, nor inline mask data. Note that no errors are reported in
+     case of failure because the mask file we're looking for might not
+     exist. */ 
+  if (EQ (mask_file, Qt) && NILP (assq_no_quit (Q_mask_data, alist)))
     {
+      assert (!EQ (file, Qt) && !EQ (file, Qnil));
       mask_file = MAYBE_LISP_CONTYPE_METH
 	(decode_console_type(console_type, ERROR_ME),
 	 locate_pixmap_file, (concat2 (file, build_ascstring ("Mask"))));
@@ -2757,10 +2756,14 @@
 	   locate_pixmap_file, (concat2 (file, build_ascstring ("msk"))));
     }
 
+  /* We got a mask file, either explicitely or from the search above. */
   if (!NILP (mask_file))
     {
-      Lisp_Object mask_data =
-	bitmap_to_lisp_data (mask_file, 0, 0, 0);
+      Lisp_Object mask_data;
+
+      assert (!EQ (mask_file, Qt));
+
+      mask_data = bitmap_to_lisp_data (mask_file, 0, 0, 0);
       alist = remassq_no_quit (Q_mask_file, alist);
       /* there can't be a :mask-data at this point. */
       alist = Fcons (Fcons (Q_mask_file, mask_file),
@@ -2776,9 +2779,8 @@
 xbm_normalize (Lisp_Object inst, Lisp_Object console_type,
 	       Lisp_Object UNUSED (dest_mask))
 {
-  Lisp_Object file = Qnil, mask_file = Qnil;
+  Lisp_Object file = Qnil, mask_file = Qnil, alist = Qnil;
   struct gcpro gcpro1, gcpro2, gcpro3;
-  Lisp_Object alist = Qnil;
 
   GCPRO3 (file, mask_file, alist);
 
@@ -2796,7 +2798,9 @@
   mask_file = potential_pixmap_file_instantiator (inst, Q_mask_file,
 						  Q_mask_data, console_type);
 
-  if (NILP (file)) /* normalization impossible for the console type */
+  /* No locate_pixmap_file method for this console type, so we can't get a
+     file (neither a mask file BTW). */
+  if (NILP (file))
     RETURN_UNGCPRO (Qnil);
 
   if (CONSP (file)) /* failure locating filename */
@@ -2804,6 +2808,11 @@
 			       "no such file or directory",
 			       Fcar (file));
 
+  if (CONSP (mask_file)) /* failure locating filename */
+    signal_double_image_error ("Opening bitmap mask file",
+			       "no such file or directory",
+			       Fcar (mask_file));
+
   if (EQ (file, Qt) && EQ (mask_file, Qt)) /* no conversion necessary */
     RETURN_UNGCPRO (inst);
 
@@ -2863,10 +2872,8 @@
 xface_normalize (Lisp_Object inst, Lisp_Object console_type,
 		 Lisp_Object UNUSED (dest_mask))
 {
-  /* This function can call lisp */
-  Lisp_Object file = Qnil, mask_file = Qnil;
+  Lisp_Object file = Qnil, mask_file = Qnil, alist = Qnil;
   struct gcpro gcpro1, gcpro2, gcpro3;
-  Lisp_Object alist = Qnil;
 
   GCPRO3 (file, mask_file, alist);
 
@@ -2884,28 +2891,34 @@
   mask_file = potential_pixmap_file_instantiator (inst, Q_mask_file,
 						  Q_mask_data, console_type);
 
-  if (NILP (file)) /* normalization impossible for the console type */
+  /* No locate_pixmap_file method for this console type, so we can't get a
+     file (neither a mask file BTW). */
+  if (NILP (file))
     RETURN_UNGCPRO (Qnil);
 
   if (CONSP (file)) /* failure locating filename */
-    signal_double_image_error ("Opening bitmap file",
+    signal_double_image_error ("Opening face file",
 			       "no such file or directory",
 			       Fcar (file));
 
+  if (CONSP (mask_file)) /* failure locating filename */
+    signal_double_image_error ("Opening face mask file",
+			       "no such file or directory",
+			       Fcar (mask_file));
+
   if (EQ (file, Qt) && EQ (mask_file, Qt)) /* no conversion necessary */
     RETURN_UNGCPRO (inst);
 
   alist = tagged_vector_to_alist (inst);
 
-  {
-    /* #### FIXME: what if EQ (file, Qt) && !EQ (mask, Qt) ? Is that possible?
-       If so, we have a problem... -- dvl */
-    Lisp_Object data = make_string_from_file (file);
-    alist = remassq_no_quit (Q_file, alist);
-    /* there can't be a :data at this point. */
-    alist = Fcons (Fcons (Q_file, file),
-		   Fcons (Fcons (Q_data, data), alist));
-  }
+  if (!EQ (file, Qt))
+    {
+      Lisp_Object data = make_string_from_file (file);
+      alist = remassq_no_quit (Q_file, alist);
+      /* there can't be a :data at this point. */
+      alist = Fcons (Fcons (Q_file, file),
+		     Fcons (Fcons (Q_data, data), alist));
+    }
 
   alist = xbm_mask_file_munging (alist, file, mask_file, console_type);
 
@@ -3694,11 +3707,11 @@
   Lisp_Glyph *glyph = XGLYPH (obj);
 
   if (print_readably)
-    printing_unreadable_lcrecord (obj, 0);
+    printing_unreadable_lisp_object (obj, 0);
 
   write_fmt_string_lisp (printcharfun, "#<glyph (%s", 1, Fglyph_type (obj));
   write_fmt_string_lisp (printcharfun, ") %S", 1, glyph->image);
-  write_fmt_string (printcharfun, "0x%x>", glyph->header.uid);
+  write_fmt_string (printcharfun, "0x%x>", LISP_OBJECT_UID (obj));
 }
 
 /* Glyphs are equal if all of their display attributes are equal.  We
@@ -3805,14 +3818,11 @@
   { XD_END }
 };
 
-DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("glyph", glyph,
-					  1, /*dumpable-flag*/
-					  mark_glyph, print_glyph, 0,
-					  glyph_equal, glyph_hash,
-					  glyph_description,
-					  glyph_getprop, glyph_putprop,
-					  glyph_remprop, glyph_plist,
-					  Lisp_Glyph);
+DEFINE_DUMPABLE_LISP_OBJECT ("glyph", glyph,
+			     mark_glyph, print_glyph, 0,
+			     glyph_equal, glyph_hash,
+			     glyph_description,
+			     Lisp_Glyph);
 
 Lisp_Object
 allocate_glyph (enum glyph_type type,
@@ -3820,8 +3830,8 @@
 				      Lisp_Object locale))
 {
   /* This function can GC */
-  Lisp_Object obj = Qnil;
-  Lisp_Glyph *g = ALLOC_LCRECORD_TYPE (Lisp_Glyph, &lrecord_glyph);
+  Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (glyph);
+  Lisp_Glyph *g = XGLYPH (obj);
 
   g->type = type;
   g->image = Fmake_specifier (Qimage); /* This function can GC */
@@ -3867,7 +3877,6 @@
     g->face = Qnil;
     g->plist = Qnil;
     g->after_change = after_change;
-    obj = wrap_glyph (g);
 
     set_image_attached_to (g->image, obj, Qimage);
     UNGCPRO;
@@ -4465,12 +4474,12 @@
 
 int
 compute_glyph_cachel_usage (glyph_cachel_dynarr *glyph_cachels,
-			    struct overhead_stats *ovstats)
+			    struct usage_stats *ustats)
 {
   int total = 0;
 
   if (glyph_cachels)
-    total += Dynarr_memory_usage (glyph_cachels, ovstats);
+    total += Dynarr_memory_usage (glyph_cachels, ustats);
 
   return total;
 }
@@ -4537,7 +4546,7 @@
 	  XWEAK_LIST_LIST (FRAME_SUBWINDOW_CACHE (f))
 	    = delq_no_quit (value,
 			    XWEAK_LIST_LIST (FRAME_SUBWINDOW_CACHE (f)));
-	  finalize_image_instance (XIMAGE_INSTANCE (value), 0);
+	  finalize_image_instance (value);
 	}
     }
   return 0;
@@ -4640,7 +4649,7 @@
       struct expose_ignore *ei;
 
 #ifdef NEW_GC
-      ei = alloc_lrecord_type (struct expose_ignore, &lrecord_expose_ignore);
+      ei = XEXPOSE_IGNORE (ALLOC_NORMAL_LISP_OBJECT (expose_ignore));
 #else /* not NEW_GC */
       ei = Blocktype_alloc (the_expose_ignore_blocktype);
 #endif /* not NEW_GC */
@@ -5175,10 +5184,19 @@
  *****************************************************************************/
 
 void
+glyph_objects_create (void)
+{
+  OBJECT_HAS_METHOD (glyph, getprop);
+  OBJECT_HAS_METHOD (glyph, putprop);
+  OBJECT_HAS_METHOD (glyph, remprop);
+  OBJECT_HAS_METHOD (glyph, plist);
+}
+
+void
 syms_of_glyphs (void)
 {
-  INIT_LRECORD_IMPLEMENTATION (glyph);
-  INIT_LRECORD_IMPLEMENTATION (image_instance);
+  INIT_LISP_OBJECT (glyph);
+  INIT_LISP_OBJECT (image_instance);
 
   /* image instantiators */