xemacs-beta: src/glyphs.c comparison

comparison 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

comparison

equal deleted inserted replaced

-:b785049378e3
+:97eb4942aec8
 Copyright (C) 1994, 1995 Board of Trustees, University of Illinois
 Copyright (C) 1995 Tinker Systems
 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.
 XEmacs is free software; you can redistribute it and/or modify it
 under the terms of the GNU General Public License as published by the
 		      int escapeflag)
 {
 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))
 write_fmt_string_lisp (printcharfun, "%S ", 1, ii->name);
 write_fmt_string_lisp (printcharfun, "on %s ", 1, ii->domain);
 ABORT ();
 }
 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)
+finalize_image_instance (Lisp_Object obj)
 {
-Lisp_Image_Instance *i = (Lisp_Image_Instance *) header;
+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. */
 MAYBE_DEVMETH (XDEVICE (IMAGE_INSTANCE_DEVICE (i)),
 		 finalize_image_instance, (i));
 		(XDEVICE (image_instance_device (obj)),
 		 image_instance_hash, (i, depth),
 		 0));
 }
-DEFINE_LRECORD_IMPLEMENTATION ("image-instance", image_instance,
+DEFINE_NODUMP_LISP_OBJECT ("image-instance", image_instance,
-			       0, /*dumpable-flag*/
+			   mark_image_instance, print_image_instance,
-			       mark_image_instance, print_image_instance,
+			   finalize_image_instance, image_instance_equal,
-			       finalize_image_instance, image_instance_equal,
+			   image_instance_hash,
-			       image_instance_hash,
+			   image_instance_description,
-			       image_instance_description,
+			   Lisp_Image_Instance);
-			       Lisp_Image_Instance);
 static Lisp_Object
 allocate_image_instance (Lisp_Object governing_domain, Lisp_Object parent,
 			 Lisp_Object instantiator)
 {
-Lisp_Image_Instance *lp =
+Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (image_instance);
-ALLOC_LCRECORD_TYPE (Lisp_Image_Instance, &lrecord_image_instance);
+Lisp_Image_Instance *lp = XIMAGE_INSTANCE (obj);
-Lisp_Object val;
 /* It's not possible to simply keep a record of the domain in which
 the instance was instantiated. This is because caching may mean
 that the domain becomes invalid but the instance remains
 valid. However, the only truly relevant domain is the domain in
 lp->parent = parent;
 lp->instantiator = instantiator;
 /* 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
 decode_image_instance_type (Lisp_Object type, Error_Behavior errb)
 {
 /* #### There should be a copy_image_instance(), which calls a
 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. */
 if (!DEVMETH (XDEVICE (device), colorize_image_instance, (new_, foreground,
 							    background)))
 /************************************************************************/
 /*                        pixmap file functions                         */
 /************************************************************************/
-/* If INSTANTIATOR refers to inline data, return Qt.
+/* - If INSTANTIATOR refers to inline data, or there is no file keyword, we
-If INSTANTIATOR refers to data in a file, return the full filename
+have nothing to do, so return Qt.
-if it exists, Qnil if there's no console method for locating the file, or
+- If INSTANTIATOR refers to data in a file, return the full filename
-(filename) if there was an error locating the file.
+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
+respectively, in the instantiator.  These would be Q_file and Q_data,
-be Q_file and Q_data, but might be different for mask data. */
+Q_mask_file or Q_mask_data. */
 Lisp_Object
 potential_pixmap_file_instantiator (Lisp_Object instantiator,
 				    Lisp_Object file_keyword,
 				    Lisp_Object data_keyword,
 }
 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
+/* Let's try to find an implicit mask file if we have neither an explicit
-bitmaps in /usr/include/X11/bitmaps use it -- so we support
+mask file name, nor inline mask data. Note that no errors are reported in
-it. */
+case of failure because the mask file we're looking for might not
-if (EQ (mask_file, Qt)
+exist. */
-/* don't override explicitly specified mask data. */
+if (EQ (mask_file, Qt) && NILP (assq_no_quit (Q_mask_data, alist)))
-&& NILP (assq_no_quit (Q_mask_data, alist))
+{
-&& !EQ (file, Qt))
+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"))));
 if (NILP (mask_file))
 	mask_file = MAYBE_LISP_CONTYPE_METH
 	  (decode_console_type(console_type, ERROR_ME),
 	   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 =
+Lisp_Object mask_data;
-	bitmap_to_lisp_data (mask_file, 0, 0, 0);
+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),
 		     Fcons (Fcons (Q_mask_data, mask_data), alist));
 }
 static Lisp_Object
 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);
 /* Now, convert any file data into inline data for both the regular
 data and the mask data.  At the end of this, `data' will contain
 file = potential_pixmap_file_instantiator (inst, Q_file, Q_data,
 					     console_type);
 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",
 			       "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);
 alist = tagged_vector_to_alist (inst);
 static Lisp_Object
 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, alist = Qnil;
-Lisp_Object file = Qnil, mask_file = Qnil;
 struct gcpro gcpro1, gcpro2, gcpro3;
-Lisp_Object alist = Qnil;
 GCPRO3 (file, mask_file, alist);
 /* Now, convert any file data into inline data for both the regular
 data and the mask data.  At the end of this, `data' will contain
 file = potential_pixmap_file_instantiator (inst, Q_file, Q_data,
 					     console_type);
 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);
-{
+if (!EQ (file, Qt))
-/* #### 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);
-Lisp_Object data = make_string_from_file (file);
+alist = remassq_no_quit (Q_file, alist);
-alist = remassq_no_quit (Q_file, alist);
+/* there can't be a :data at this point. */
-/* there can't be a :data at this point. */
+alist = Fcons (Fcons (Q_file, file),
-alist = Fcons (Fcons (Q_file, file),
+		     Fcons (Fcons (Q_data, data), alist));
-		   Fcons (Fcons (Q_data, data), alist));
+}
-}
 alist = xbm_mask_file_munging (alist, file, mask_file, console_type);
 {
 Lisp_Object result = alist_to_tagged_vector (Qxface, alist);
 	     int UNUSED (escapeflag))
 {
 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
 don't compare names or doc-strings, because that would make equal
 be eq.
 { XD_LISP_OBJECT, offsetof (Lisp_Glyph, face) },
 { XD_LISP_OBJECT, offsetof (Lisp_Glyph, plist) },
 { XD_END }
 };
-DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("glyph", glyph,
+DEFINE_DUMPABLE_LISP_OBJECT ("glyph", glyph,
-					  1, /*dumpable-flag*/
+			     mark_glyph, print_glyph, 0,
-					  mark_glyph, print_glyph, 0,
+			     glyph_equal, glyph_hash,
-					  glyph_equal, glyph_hash,
+			     glyph_description,
-					  glyph_description,
+			     Lisp_Glyph);
-					  glyph_getprop, glyph_putprop,
-					  glyph_remprop, glyph_plist,
-					  Lisp_Glyph);
 Lisp_Object
 allocate_glyph (enum glyph_type type,
 		void (*after_change) (Lisp_Object glyph, Lisp_Object property,
 				      Lisp_Object locale))
 {
 /* This function can GC */
-Lisp_Object obj = Qnil;
+Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (glyph);
-Lisp_Glyph *g = ALLOC_LCRECORD_TYPE (Lisp_Glyph, &lrecord_glyph);
+Lisp_Glyph *g = XGLYPH (obj);
 g->type = type;
 g->image = Fmake_specifier (Qimage); /* This function can GC */
 g->dirty = 0;
 switch (g->type)
 g->baseline = Fmake_specifier (Qgeneric);
 set_specifier_fallback (g->baseline, tem3);
 g->face = Qnil;
 g->plist = Qnil;
 g->after_change = after_change;
-obj = wrap_glyph (g);
 set_image_attached_to (g->image, obj, Qimage);
 UNGCPRO;
 }
 #ifdef MEMORY_USAGE_STATS
 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;
 }
 #endif /* MEMORY_USAGE_STATS */
 	     cache also. Otherwise code that checks the sanity of the instance
 	     will fail. */
 	  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;
 }
 if (!hold_ignored_expose_registration)
 {
 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 */
 ei->next = NULL;
 /*****************************************************************************
 *                              initialization                               *
 *****************************************************************************/
 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_LISP_OBJECT (glyph);
-INIT_LRECORD_IMPLEMENTATION (image_instance);
+INIT_LISP_OBJECT (image_instance);
 /* image instantiators */
 DEFSUBR (Fimage_instantiator_format_list);
 DEFSUBR (Fvalid_image_instantiator_format_p);

Mercurial > hg > xemacs-beta

comparison src/glyphs.c @ 5178:97eb4942aec8