Mercurial > hg > xemacs-beta
annotate src/opaque.c @ 5124:623d57b7fbe8 ben-lisp-object
separate regular and disksave finalization, print method fixes.
Create separate disksave method and make the finalize method only be for
actual object finalization, not disksave finalization.
Fix places where 0 was given in place of a printer -- print methods are
mandatory, and internal objects formerly without a print method now must
explicitly specify internal_object_printer().
Change the defn of CONSOLE_LIVE_P to avoid problems in some weird situations.
-------------------- ChangeLog entries follow: --------------------
src/ChangeLog addition:
2010-01-20 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (very_old_free_lcrecord):
* alloc.c (disksave_object_finalization_1):
* alloc.c (make_lcrecord_list):
* alloc.c (alloc_managed_lcrecord):
* alloc.c (free_managed_lcrecord):
* alloc.c (sweep_lcrecords_1):
* buffer.c:
* bytecode.c:
* bytecode.c (Fcompiled_function_p):
* chartab.c:
* console-impl.h:
* console-impl.h (CONSOLE_TYPE_P):
* console.c:
* console.c (set_quit_events):
* data.c:
* data.c (Fmake_ephemeron):
* database.c:
* database.c (finalize_database):
* database.c (Fclose_database):
* device-msw.c:
* device-msw.c (finalize_devmode):
* device-msw.c (allocate_devmode):
* device.c:
* elhash.c:
* elhash.c (finalize_hash_table):
* eval.c:
* eval.c (bind_multiple_value_limits):
* event-stream.c:
* event-stream.c (finalize_command_builder):
* events.c:
* events.c (mark_event):
* extents.c:
* extents.c (finalize_extent_info):
* extents.c (uninit_buffer_extents):
* faces.c:
* file-coding.c:
* file-coding.c (finalize_coding_system):
* file-coding.h:
* file-coding.h (struct coding_system_methods):
* file-coding.h (struct detector):
* floatfns.c:
* floatfns.c (extract_float):
* fns.c:
* fns.c (Fidentity):
* font-mgr.c (finalize_fc_pattern):
* font-mgr.c (finalize_fc_config):
* frame.c:
* glyphs.c:
* glyphs.c (finalize_image_instance):
* glyphs.c (unmap_subwindow_instance_cache_mapper):
* gui.c:
* gui.c (gui_error):
* keymap.c:
* lisp.h (struct Lisp_Symbol):
* lrecord.h:
* lrecord.h (struct lrecord_implementation):
* lrecord.h (MC_ALLOC_CALL_FINALIZER):
* lrecord.h (MC_ALLOC_CALL_FINALIZER_FOR_DISKSAVE):
* lrecord.h (DEFINE_DUMPABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_SIZABLE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_SIZABLE_INTERNAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_SIZABLE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_FROB_BLOCK_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_FROB_BLOCK_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_INTERNAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_SIZABLE_INTERNAL_LISP_OBJECT):
* lrecord.h (MAKE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_SIZABLE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_GENERAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_SIZABLE_GENERAL_LISP_OBJECT):
* lrecord.h (MAKE_MODULE_LISP_OBJECT):
* lstream.c:
* lstream.c (finalize_lstream):
* lstream.c (disksave_lstream):
* marker.c:
* marker.c (finalize_marker):
* mule-charset.c (make_charset):
* number.c:
* objects.c:
* objects.c (finalize_color_instance):
* objects.c (finalize_font_instance):
* opaque.c:
* opaque.c (make_opaque_ptr):
* process-nt.c:
* process-nt.c (nt_finalize_process_data):
* process-nt.c (nt_deactivate_process):
* process.c:
* process.c (finalize_process):
* procimpl.h (struct process_methods):
* scrollbar.c:
* scrollbar.c (free_scrollbar_instance):
* specifier.c (finalize_specifier):
* symbols.c:
* toolbar.c:
* toolbar.c (Ftoolbar_button_p):
* tooltalk.c:
* ui-gtk.c:
* ui-gtk.c (emacs_gtk_object_finalizer):
* ui-gtk.c (allocate_emacs_gtk_boxed_data):
* window.c:
* window.c (finalize_window):
* window.c (mark_window_as_deleted):
Separate out regular and disksave finalization. Instead of a
FOR_DISKSAVE argument to the finalizer, create a separate object
method `disksaver'. Make `finalizer' have only one argument.
Go through and separate out all finalize methods into finalize
and disksave. Delete lots of thereby redundant disksave checking.
Delete places that signal an error if we attempt to disksave --
all of these objects are non-dumpable and we will get an error
from pdump anyway if we attempt to dump them. After this is done,
only one object remains that has a disksave method -- lstream.
Change DEFINE_*_LISP_OBJECT_WITH_PROPS to DEFINE_*_GENERAL_LISP_OBJECT,
which is used for specifying either property methods or disksave
methods (or in the future, any other less-used methods).
Remove the for_disksave argument to finalize_process_data. Don't
provide a disksaver for processes because no one currently needs
it.
Clean up various places where objects didn't provide a print method.
It was made mandatory in previous changes, and all methods now
either provide their own print method or use internal_object_printer
or external_object_printer.
Change the definition of CONSOLE_LIVE_P to use the contype enum
rather than looking into the conmeths structure -- in some weird
situations with dead objects, the conmeths structure is NULL,
and printing such objects from debug_print() will crash if we try
to look into the conmeths structure.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Wed, 20 Jan 2010 07:05:57 -0600 |
| parents | e0db3c197671 |
| children | b5df3737028a |
| rev | line source |
|---|---|
| 428 | 1 /* Opaque Lisp objects. |
| 2 Copyright (C) 1993, 1994, 1995 Sun Microsystems, Inc. | |
| 800 | 3 Copyright (C) 1995, 1996, 2002 Ben Wing. |
| 428 | 4 |
| 5 This file is part of XEmacs. | |
| 6 | |
| 7 XEmacs is free software; you can redistribute it and/or modify it | |
| 8 under the terms of the GNU General Public License as published by the | |
| 9 Free Software Foundation; either version 2, or (at your option) any | |
| 10 later version. | |
| 11 | |
| 12 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 15 for more details. | |
| 16 | |
| 17 You should have received a copy of the GNU General Public License | |
| 18 along with XEmacs; see the file COPYING. If not, write to | |
| 19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 20 Boston, MA 02111-1307, USA. */ | |
| 21 | |
| 22 /* Synched up with: Not in FSF. */ | |
| 23 | |
| 24 /* Written by Ben Wing, October 1993. */ | |
| 25 | |
| 26 /* "Opaque" is used internally to hold keep track of allocated memory | |
| 27 so it gets GC'd properly, and to store arbitrary data in places | |
| 28 where a Lisp_Object is required and which may get GC'd. (e.g. as | |
| 29 the argument to record_unwind_protect()). Once created in C, | |
| 30 opaque objects cannot be resized. | |
| 31 | |
| 32 OPAQUE OBJECTS SHOULD NEVER ESCAPE TO THE LISP LEVEL. Some code | |
| 33 depends on this. As such, opaque objects are a generalization | |
| 34 of the Qunbound marker. | |
| 35 */ | |
| 36 | |
| 37 #include <config.h> | |
| 38 #include "lisp.h" | |
| 39 #include "opaque.h" | |
| 40 | |
| 3263 | 41 #ifndef NEW_GC |
| 428 | 42 Lisp_Object Vopaque_ptr_free_list; |
| 3263 | 43 #endif /* not NEW_GC */ |
| 428 | 44 |
| 45 /* Should never, ever be called. (except by an external debugger) */ | |
| 46 static void | |
| 2286 | 47 print_opaque (Lisp_Object obj, Lisp_Object printcharfun, |
| 48 int UNUSED (escapeflag)) | |
| 428 | 49 { |
| 442 | 50 const Lisp_Opaque *p = XOPAQUE (obj); |
| 428 | 51 |
| 800 | 52 write_fmt_string |
| 53 (printcharfun, | |
| 54 "#<INTERNAL OBJECT (XEmacs bug?) (opaque, size=%lu) 0x%lx>", | |
| 55 (long)(p->size), (unsigned long) p); | |
| 428 | 56 } |
| 57 | |
| 665 | 58 inline static Bytecount |
| 59 aligned_sizeof_opaque (Bytecount opaque_size) | |
| 456 | 60 { |
| 826 | 61 return MAX_ALIGN_SIZE (offsetof (Lisp_Opaque, data) + opaque_size); |
| 456 | 62 } |
| 63 | |
| 665 | 64 static Bytecount |
| 442 | 65 sizeof_opaque (const void *header) |
| 428 | 66 { |
| 456 | 67 return aligned_sizeof_opaque (((const Lisp_Opaque *) header)->size); |
| 428 | 68 } |
| 69 | |
| 70 /* Return an opaque object of size SIZE. | |
| 71 If DATA is OPAQUE_CLEAR, the object's data is memset to '\0' bytes. | |
| 72 If DATA is OPAQUE_UNINIT, the object's data is uninitialized. | |
| 73 Else the object's data is initialized by copying from DATA. */ | |
| 74 Lisp_Object | |
| 665 | 75 make_opaque (const void *data, Bytecount size) |
| 428 | 76 { |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
77 Lisp_Object obj = |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
78 ALLOC_SIZED_LISP_OBJECT (aligned_sizeof_opaque (size), opaque); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
79 Lisp_Opaque *p = XOPAQUE (obj); |
| 428 | 80 p->size = size; |
| 81 | |
| 82 if (data == OPAQUE_CLEAR) | |
| 83 memset (p->data, '\0', size); | |
| 84 else if (data == OPAQUE_UNINIT) | |
| 85 DO_NOTHING; | |
| 86 else | |
| 87 memcpy (p->data, data, size); | |
| 88 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
89 return obj; |
| 428 | 90 } |
| 91 | |
| 92 /* This will not work correctly for opaques with subobjects! */ | |
| 93 | |
| 94 static int | |
| 2286 | 95 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) |
| 428 | 96 { |
| 665 | 97 Bytecount size; |
| 428 | 98 return ((size = XOPAQUE_SIZE (obj1)) == XOPAQUE_SIZE (obj2) && |
| 99 !memcmp (XOPAQUE_DATA (obj1), XOPAQUE_DATA (obj2), size)); | |
| 100 } | |
| 101 | |
| 102 /* This will not work correctly for opaques with subobjects! */ | |
| 103 | |
| 2515 | 104 static Hashcode |
| 2286 | 105 hash_opaque (Lisp_Object obj, int UNUSED (depth)) |
| 428 | 106 { |
| 107 if (XOPAQUE_SIZE (obj) == sizeof (unsigned long)) | |
| 2515 | 108 return *((Hashcode *) XOPAQUE_DATA (obj)); |
| 428 | 109 else |
| 110 return memory_hash (XOPAQUE_DATA (obj), XOPAQUE_SIZE (obj)); | |
| 111 } | |
| 112 | |
| 1204 | 113 static const struct memory_description opaque_description[] = { |
| 428 | 114 { XD_END } |
| 115 }; | |
| 116 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
117 DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("opaque", opaque, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
118 0, print_opaque, 0, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
119 equal_opaque, hash_opaque, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
120 opaque_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
121 sizeof_opaque, Lisp_Opaque); |
| 428 | 122 |
| 123 /* stuff to handle opaque pointers */ | |
| 124 | |
| 125 /* Should never, ever be called. (except by an external debugger) */ | |
| 126 static void | |
| 2286 | 127 print_opaque_ptr (Lisp_Object obj, Lisp_Object printcharfun, |
| 128 int UNUSED (escapeflag)) | |
| 428 | 129 { |
| 442 | 130 const Lisp_Opaque_Ptr *p = XOPAQUE_PTR (obj); |
| 428 | 131 |
| 800 | 132 write_fmt_string |
| 133 (printcharfun, | |
| 134 "#<INTERNAL OBJECT (XEmacs bug?) (opaque-ptr, adr=0x%lx) 0x%lx>", | |
| 135 (long)(p->ptr), (unsigned long) p); | |
| 428 | 136 } |
| 137 | |
| 138 static int | |
| 2286 | 139 equal_opaque_ptr (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) |
| 428 | 140 { |
| 141 return (XOPAQUE_PTR (obj1)->ptr == XOPAQUE_PTR (obj2)->ptr); | |
| 142 } | |
| 143 | |
| 2515 | 144 static Hashcode |
| 2286 | 145 hash_opaque_ptr (Lisp_Object obj, int UNUSED (depth)) |
| 428 | 146 { |
| 2515 | 147 return (Hashcode) XOPAQUE_PTR (obj)->ptr; |
| 428 | 148 } |
| 149 | |
| 1575 | 150 static const struct memory_description opaque_ptr_description[] = { |
| 151 { XD_END } | |
| 152 }; | |
| 153 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
154 DEFINE_NODUMP_LISP_OBJECT ("opaque-ptr", opaque_ptr, |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
155 0, print_opaque_ptr, 0, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
156 equal_opaque_ptr, hash_opaque_ptr, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
157 opaque_ptr_description, Lisp_Opaque_Ptr); |
| 428 | 158 |
| 159 Lisp_Object | |
| 160 make_opaque_ptr (void *val) | |
| 161 { | |
| 3263 | 162 #ifdef NEW_GC |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
163 Lisp_Object res = ALLOC_LISP_OBJECT (opaque_ptr); |
| 3263 | 164 #else /* not NEW_GC */ |
| 1204 | 165 Lisp_Object res = alloc_managed_lcrecord (Vopaque_ptr_free_list); |
| 3263 | 166 #endif /* not NEW_GC */ |
| 428 | 167 set_opaque_ptr (res, val); |
| 168 return res; | |
| 169 } | |
| 170 | |
| 171 /* Be very very careful with this. Same admonitions as with | |
| 172 free_cons() apply. */ | |
| 173 | |
| 174 void | |
| 175 free_opaque_ptr (Lisp_Object ptr) | |
| 176 { | |
| 3263 | 177 #ifdef NEW_GC |
| 2720 | 178 free_lrecord (ptr); |
| 3263 | 179 #else /* not NEW_GC */ |
| 428 | 180 free_managed_lcrecord (Vopaque_ptr_free_list, ptr); |
| 3263 | 181 #endif /* not NEW_GC */ |
| 428 | 182 } |
| 183 | |
| 3263 | 184 #ifndef NEW_GC |
| 428 | 185 void |
| 1204 | 186 reinit_opaque_early (void) |
| 428 | 187 { |
| 647 | 188 Vopaque_ptr_free_list = make_lcrecord_list (sizeof (Lisp_Opaque_Ptr), |
| 189 &lrecord_opaque_ptr); | |
| 428 | 190 staticpro_nodump (&Vopaque_ptr_free_list); |
| 191 } | |
| 3263 | 192 #endif /* not NEW_GC */ |
| 428 | 193 |
| 194 void | |
| 195 init_opaque_once_early (void) | |
| 196 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
197 INIT_LISP_OBJECT (opaque); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
198 INIT_LISP_OBJECT (opaque_ptr); |
| 442 | 199 |
| 3263 | 200 #ifndef NEW_GC |
| 1204 | 201 reinit_opaque_early (); |
| 3263 | 202 #endif /* not NEW_GC */ |
| 428 | 203 } |