Mercurial > hg > xemacs-beta
annotate tests/glyph-test.el @ 5169:6c6d78781d59
cleanup of code related to xfree(), better KKCC backtrace capabilities, document XD_INLINE_LISP_OBJECT_BLOCK_PTR, fix some memory leaks, other code cleanup
-------------------- ChangeLog entries follow: --------------------
src/ChangeLog addition:
2010-03-24 Ben Wing <ben@xemacs.org>
* array.h:
* array.h (XD_LISP_DYNARR_DESC):
* dumper.c (pdump_register_sub):
* dumper.c (pdump_store_new_pointer_offsets):
* dumper.c (pdump_reloc_one_mc):
* elhash.c:
* gc.c (lispdesc_one_description_line_size):
* gc.c (kkcc_marking):
* lrecord.h:
* lrecord.h (IF_NEW_GC):
* lrecord.h (enum memory_description_type):
* lrecord.h (enum data_description_entry_flags):
* lrecord.h (struct opaque_convert_functions):
Rename XD_LISP_OBJECT_BLOCK_PTR to XD_INLINE_LISP_OBJECT_BLOCK_PTR
and document it in lrecord.h.
* data.c:
* data.c (finish_marking_weak_lists):
* data.c (continue_marking_ephemerons):
* data.c (finish_marking_ephemerons):
* elhash.c (MARK_OBJ):
* gc.c:
* gc.c (lispdesc_indirect_count_1):
* gc.c (struct):
* gc.c (kkcc_bt_push):
* gc.c (kkcc_gc_stack_push):
* gc.c (kkcc_gc_stack_push_lisp_object):
* gc.c (kkcc_gc_stack_repush_dirty_object):
* gc.c (KKCC_DO_CHECK_FREE):
* gc.c (mark_object_maybe_checking_free):
* gc.c (mark_struct_contents):
* gc.c (mark_lisp_object_block_contents):
* gc.c (register_for_finalization):
* gc.c (mark_object):
* gc.h:
* lisp.h:
* profile.c:
* profile.c (mark_profiling_info_maphash):
Clean up KKCC code related to DEBUG_XEMACS. Rename
kkcc_backtrace() to kkcc_backtrace_1() and add two params: a
`size' arg to control how many stack elements to print and a
`detailed' arg to control whether Lisp objects are printed using
`debug_print()'. Create front-ends to kkcc_backtrace_1() --
kkcc_detailed_backtrace(), kkcc_short_backtrace(),
kkcc_detailed_backtrace_full(), kkcc_short_backtrace_full(), as
well as shortened versions kbt(), kbts(), kbtf(), kbtsf() -- to
call it with various parameter values. Add an `is_lisp' field to
the stack and backtrace structures and use it to keep track of
whether an object pushed onto the stack is a Lisp object or a
non-Lisp structure; in kkcc_backtrace_1(), don't try to print a
non-Lisp structure as a Lisp object.
* elhash.c:
* extents.c:
* file-coding.c:
* lrecord.h:
* lrecord.h (IF_NEW_GC):
* marker.c:
* marker.c (Fmarker_buffer):
* mule-coding.c:
* number.c:
* rangetab.c:
* specifier.c:
New macros IF_OLD_GC(), IF_NEW_GC() to simplify declaration of
Lisp objects when a finalizer may exist in one but not the other.
Use them appropriately.
* extents.c (finalize_extent_info):
Don't zero out data->soe and data->extents before trying to free,
else we get memory leaks.
* lrecord.h (enum lrecord_type):
Make the first lrecord type have value 1 not 0 so that 0 remains
without implementation and attempts to interpret zeroed memory
as a Lisp object will be more obvious.
* array.c (Dynarr_free):
* device-msw.c (msprinter_delete_device):
* device-tty.c (free_tty_device_struct):
* device-tty.c (tty_delete_device):
* dialog-msw.c (handle_directory_dialog_box):
* dialog-x.c:
* emacs.c (free_argc_argv):
* emodules.c (attempt_module_delete):
* file-coding.c (chain_finalize_coding_stream_1):
* file-coding.c (chain_finalize_coding_stream):
* glyphs-eimage.c:
* glyphs-eimage.c (jpeg_instantiate_unwind):
* glyphs-eimage.c (gif_instantiate_unwind):
* glyphs-eimage.c (png_instantiate_unwind):
* glyphs-eimage.c (tiff_instantiate_unwind):
* imgproc.c:
* imgproc.c (build_EImage_quantable):
* insdel.c (uninit_buffer_text):
* mule-coding.c (iso2022_finalize_detection_state):
* objects-tty.c (tty_finalize_color_instance):
* objects-tty.c (tty_finalize_font_instance):
* objects-tty.c (tty_font_list):
* process.c:
* process.c (finalize_process):
* redisplay.c (add_propagation_runes):
* scrollbar-gtk.c:
* scrollbar-gtk.c (gtk_free_scrollbar_instance):
* scrollbar-gtk.c (gtk_release_scrollbar_instance):
* scrollbar-msw.c:
* scrollbar-msw.c (mswindows_free_scrollbar_instance):
* scrollbar-msw.c (unshow_that_mofo):
* scrollbar-x.c (x_free_scrollbar_instance):
* scrollbar-x.c (x_release_scrollbar_instance):
* select-x.c:
* select-x.c (x_handle_selection_request):
* syntax.c:
* syntax.c (uninit_buffer_syntax_cache):
* text.h (eifree):
If possible, whenever we call xfree() on a field in a structure,
set the field to 0 afterwards. A lot of code is written so that
it checks the value being freed to see if it is non-zero before
freeing it -- doing this and setting the value to 0 afterwards
ensures (a) we won't try to free twice if the cleanup code is
called twice; (b) if the object itself stays around, KKCC won't
crash when attempting to mark the freed field.
* rangetab.c:
Add a finalization method when not NEW_GC to avoid memory leaks.
(#### We still get memory leaks when NEW_GC; need to convert gap
array to Lisp object).
author | Ben Wing <ben@xemacs.org> |
---|---|
date | Wed, 24 Mar 2010 01:22:51 -0500 |
parents | 8a653fbe5c27 |
children | 308d34e9f07d |
rev | line source |
---|---|
4781
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
1 ;;; Copyright (C) 1998 Andy Piper |
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
2 |
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
3 ;;; This file is part of XEmacs. |
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
4 |
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
5 ;;; XEmacs is free software; you can redistribute it and/or modify it |
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
6 ;;; under the terms of the GNU General Public License as published by |
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
7 ;;; the Free Software Foundation; either version 2, or (at your |
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
8 ;;; option) any later version. |
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
9 |
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
10 ;;; XEmacs is distributed in the hope that it will be useful, but |
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
11 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
13 ;;; General Public License for more details. |
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
14 |
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
15 ;;; You should have received a copy of the GNU General Public License |
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
16 ;;; along with XEmacs; see the file COPYING. If not, write to the Free |
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
17 ;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
18 ;;; Boston, MA 02110-1301, USA. |
8a653fbe5c27
Add copyright and GPL v2 or later notices to Andy Piper's contributions, with
Jerry James <james@xemacs.org>
parents:
462
diff
changeset
|
19 |
428 | 20 (set-extent-begin-glyph |
21 (make-extent (point) (point)) | |
442 | 22 (setq im (make-glyph [xbm :file "xemacsicon.xbm"]))) |
428 | 23 |
438 | 24 (set-extent-begin-glyph |
25 (make-extent (point) (point)) | |
26 (make-glyph [string :data "xemacs"])) | |
27 | |
428 | 28 (defun foo () |
29 (interactive) | |
30 (setq ok-select (not ok-select))) | |
31 | |
32 (defun fee () (interactive) (message "hello")) | |
33 | |
34 ;; button in a group | |
35 (setq ok-select nil) | |
36 (set-extent-begin-glyph | |
37 (make-extent (point) (point)) | |
442 | 38 (make-glyph |
39 (setq radio-button1 | |
40 [button :face widget | |
41 :descriptor ["ok1" (setq ok-select t) | |
428 | 42 :style radio :selected ok-select]]))) |
43 ;; button in a group | |
44 (set-extent-begin-glyph | |
45 (make-extent (point) (point)) | |
442 | 46 (make-glyph |
47 (setq radio-button2 | |
48 [button :descriptor ["ok2" (setq ok-select nil) :style radio | |
428 | 49 :selected (not ok-select)]]))) |
50 ;; toggle button | |
51 (set-extent-begin-glyph | |
52 (make-extent (point) (point)) | |
53 (setq tbutton | |
442 | 54 (make-glyph [button :descriptor ["ok3" (setq ok-select nil) |
428 | 55 :style toggle |
56 :selected (not ok-select)]]))) | |
57 (set-extent-begin-glyph | |
58 (make-extent (point) (point)) | |
442 | 59 (make-glyph |
60 (setq toggle-button | |
61 [button :descriptor ["ok4" :style toggle | |
62 :callback | |
63 (setq ok-select (not ok-select)) | |
64 :selected ok-select]]))) | |
428 | 65 |
66 ;; normal pushbutton | |
67 (set-extent-begin-glyph | |
68 (make-extent (point) (point)) | |
69 (setq push-button | |
70 (make-glyph [button :width 10 :height 2 | |
71 :face modeline-mousable | |
442 | 72 :descriptor "ok" :callback foo |
428 | 73 :selected t]))) |
74 ;; tree view | |
75 (set-extent-begin-glyph | |
76 (make-extent (point) (point)) | |
77 (setq tree (make-glyph | |
78 [tree-view :width 10 | |
79 :descriptor "My Tree" | |
442 | 80 :items (["One" foo] |
81 (["Two" foo] | |
82 ["Four" foo] | |
83 "Six") | |
84 "Three")]))) | |
428 | 85 |
86 ;; tab control | |
87 (set-extent-begin-glyph | |
88 (make-extent (point) (point)) | |
89 (setq tab (make-glyph | |
90 [tab-control :descriptor "My Tab" | |
91 :face highlight | |
438 | 92 :orientation right |
442 | 93 :items (["One" foo :selected t] |
94 ["Two" fee :selected nil] | |
95 ["Three" foo :selected nil])]))) | |
428 | 96 |
97 ;; progress gauge | |
98 (set-extent-begin-glyph | |
99 (make-extent (point) (point)) | |
100 (setq pgauge (make-glyph | |
442 | 101 [progress-gauge :width 10 :height 2 :value 0 |
428 | 102 :descriptor "ok"]))) |
103 ;; progress the progress ... | |
104 (let ((x 0)) | |
105 (while (<= x 100) | |
442 | 106 (set-glyph-image pgauge `[progress-gauge :width 10 :height 2 |
107 :descriptor "ok" :value ,x]) | |
428 | 108 (setq x (+ x 5)) |
109 (sit-for 0.1))) | |
110 | |
111 ;; progress gauge in the modeline | |
112 (setq global-mode-string | |
113 (cons (make-extent nil nil) | |
114 (setq pg (make-glyph | |
115 [progress-gauge :width 5 :pixel-height 16 | |
116 :descriptor "ok"])))) | |
117 ;; progress the progress ... | |
118 (let ((x 0)) | |
119 (while (<= x 100) | |
442 | 120 (set-glyph-image pg |
121 `[progress-gauge :width 5 :pixel-height 16 | |
122 :descriptor "ok" :value ,x]) | |
428 | 123 (setq x (+ x 5)) |
462 | 124 (redisplay-frame) |
428 | 125 (sit-for 0.1))) |
126 | |
127 (set-extent-begin-glyph | |
128 (make-extent (point) (point)) | |
129 (make-glyph | |
130 [button :face modeline-mousable | |
131 :descriptor "ok" :callback foo | |
132 :image [xpm :file "../etc/xemacs-icon.xpm"]])) | |
133 | |
134 ;; normal pushbutton | |
135 (set-extent-begin-glyph | |
136 (make-extent (point) (point)) | |
438 | 137 (setq pbutton |
138 (make-glyph [button :descriptor ["A Big Button" foo ]]))) | |
428 | 139 |
140 ;; edit box | |
141 (set-extent-begin-glyph | |
142 (make-extent (point) (point)) | |
442 | 143 (make-glyph (setq edit-field [edit-field :pixel-width 50 :pixel-height 30 |
428 | 144 :face bold-italic |
145 :descriptor ["Hello"]]))) | |
146 ;; combo box | |
147 (set-extent-begin-glyph | |
148 (make-extent (point) (point)) | |
442 | 149 (make-glyph (setq combo-box |
150 [combo-box :width 10 :descriptor ["Hello"] | |
151 :items ("One" "Two" "Three")]))) | |
428 | 152 |
153 ;; label | |
154 (set-extent-begin-glyph | |
155 (make-extent (point) (point)) | |
442 | 156 (make-glyph (setq label [label :pixel-width 150 :descriptor "Hello"]))) |
428 | 157 |
158 ;; string | |
159 (set-extent-begin-glyph | |
160 (make-extent (point) (point)) | |
442 | 161 (make-glyph |
162 (setq str | |
163 [string :data "Hello There"]))) | |
428 | 164 |
165 ;; scrollbar | |
166 ;(set-extent-begin-glyph | |
167 ; (make-extent (point) (point)) | |
168 ; (make-glyph [scrollbar :width 50 :height 20 :descriptor ["Hello"]])) | |
169 | |
170 ;; generic subwindow | |
171 (setq sw (make-glyph [subwindow :pixel-width 50 :pixel-height 70])) | |
172 (set-extent-begin-glyph (make-extent (point) (point)) sw) | |
173 | |
174 ;; layout | |
175 (setq layout | |
176 (make-glyph | |
442 | 177 `[layout :descriptor "The Layout" |
178 :orientation vertical | |
179 :justify left | |
180 :border [string :data "Hello There Mrs"] | |
181 :items ([layout :orientation horizontal | |
182 :items (,radio-button1 ,radio-button2)] | |
183 ,edit-field ,toggle-button ,label ,str)])) | |
184 ;(set-glyph-face layout 'gui-element) | |
428 | 185 (set-extent-begin-glyph |
186 (make-extent (point) (point)) layout) | |
434 | 187 |
442 | 188 ;; another test layout |
189 (set-extent-begin-glyph | |
190 (make-extent (point) (point)) | |
191 (setq layout-2 | |
192 (make-glyph `[layout :descriptor "The Layout" | |
193 :orientation vertical | |
194 :items ([progress-gauge :value 0 :width 10 :height 2 | |
195 :descriptor "ok"])]))) | |
196 | |
197 (set-glyph-image layout-2 `[layout :descriptor "The Layout" | |
198 :orientation vertical | |
199 :items ([progress-gauge :value 4 :width 10 :height 2 | |
200 :descriptor "ok"])]) | |
434 | 201 (setq test-toggle-widget nil) |
202 | |
203 (defun test-toggle (widget) | |
204 (set-extent-begin-glyph | |
205 (make-extent (point) (point)) | |
206 (make-glyph (vector 'button | |
207 :descriptor "ok" | |
208 :style 'toggle | |
209 :selected `(funcall test-toggle-value | |
210 ,widget) | |
211 :callback `(funcall test-toggle-action | |
212 ,widget))))) | |
213 | |
214 (defun test-toggle-action (widget &optional event) | |
215 (if widget | |
216 (message "Widget is t") | |
217 (message "Widget is nil"))) | |
218 | |
219 (defun test-toggle-value (widget) | |
220 (setq widget (not widget)) | |
221 (not widget)) |