annotate src/alloc.c @ 3063:d30cd499e445

[xemacs-hg @ 2005-11-13 10:48:01 by ben] further error-checking, etc. alloc.c, lrecord.h: Move around the handling of setting of lheader->uid so it's in set_lheader_implementation() -- that way, even non-MC-ALLOC builds get useful uid's in their bare lrecords. Redo related code for strings so the non-ascii count that is stored in the uid isn't hosed. events.c: Save and restore the uid around event zeroing/deadbeefing. lisp.h: Set the correct value of MAX_STRING_ASCII_BEGIN under MC_ALLOC. lisp.h: rearrange the basic code handling ints and chars. basic int stuff goes first, followed by basic char stuff, followed in turn by stuff that mixes ints and chars. this is required since some basic defn's have become inline functions. XCHAR and CHARP have additional error-checking in that they check to make sure that the value in question is not just a character but a valid character (i.e. its numeric value is valid). print.c: debug_p4 now has a useful UID in all cases and uses it; but it also prints the raw header address (previously, you just got one of them). text.h: some basic char defn's that belonged in lisp.h have been moved there. valid_ichar_p() is moved too since the inline functions need it.
author ben
date Sun, 13 Nov 2005 10:48:04 +0000
parents b7f26b2f78bd
children 141c2920ea48 3742ea8250b5
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1 /* Storage allocation and gc for XEmacs Lisp interpreter.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2 Copyright (C) 1985-1998 Free Software Foundation, Inc.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3 Copyright (C) 1995 Sun Microsystems, Inc.
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
4 Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005 Ben Wing.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6 This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8 XEmacs is free software; you can redistribute it and/or modify it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9 under the terms of the GNU General Public License as published by the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10 Free Software Foundation; either version 2, or (at your option) any
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11 later version.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
12
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
16 for more details.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
17
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
18 You should have received a copy of the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
19 along with XEmacs; see the file COPYING. If not, write to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21 Boston, MA 02111-1307, USA. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
23 /* Synched up with: FSF 19.28, Mule 2.0. Substantially different from
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
24 FSF. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
25
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
26 /* Authorship:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
27
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
28 FSF: Original version; a long time ago.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
29 Mly: Significantly rewritten to use new 3-bit tags and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
30 nicely abstracted object definitions, for 19.8.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31 JWZ: Improved code to keep track of purespace usage and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
32 issue nice purespace and GC stats.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
33 Ben Wing: Cleaned up frob-block lrecord code, added error-checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
34 and various changes for Mule, for 19.12.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
35 Added bit vectors for 19.13.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
36 Added lcrecord lists for 19.14.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
37 slb: Lots of work on the purification and dump time code.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
38 Synched Doug Lea malloc support from Emacs 20.2.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
39 og: Killed the purespace. Portable dumper (moved to dumper.c)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
40 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
41
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
42 #include <config.h>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
43 #include "lisp.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
44
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
45 #include "backtrace.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
46 #include "buffer.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
47 #include "bytecode.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
48 #include "chartab.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
49 #include "device.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
50 #include "elhash.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
51 #include "events.h"
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
52 #include "extents-impl.h"
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
53 #include "file-coding.h"
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
54 #include "frame-impl.h"
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
55 #include "glyphs.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
56 #include "opaque.h"
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
57 #include "lstream.h"
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
58 #include "process.h"
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
59 #include "profile.h"
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60 #include "redisplay.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61 #include "specifier.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62 #include "sysfile.h"
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
63 #include "sysdep.h"
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
64 #include "window.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65 #include "console-stream.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
66
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
67 #ifdef DOUG_LEA_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
68 #include <malloc.h>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
69 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71 EXFUN (Fgarbage_collect, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
72
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
73 static void recompute_need_to_garbage_collect (void);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
74
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
75 #if 0 /* this is _way_ too slow to be part of the standard debug options */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
76 #if defined(DEBUG_XEMACS) && defined(MULE)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
77 #define VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
78 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
79 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
80
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
81 /* Define this to use malloc/free with no freelist for all datatypes,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
82 the hope being that some debugging tools may help detect
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
83 freed memory references */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
84 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
85 #include <dmalloc.h>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86 #define ALLOC_NO_POOLS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
88
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89 #ifdef DEBUG_XEMACS
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
90 static Fixnum debug_allocation;
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
91 static Fixnum debug_allocation_backtrace_length;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
92 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
93
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94 /* Number of bytes of consing done since the last gc */
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
95 static EMACS_INT consing_since_gc;
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
96 EMACS_UINT total_consing;
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
97 EMACS_INT total_gc_usage;
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
98 int total_gc_usage_set;
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
99
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
100 int need_to_garbage_collect;
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
101 int need_to_check_c_alloca;
887
ccc3177ef10b [xemacs-hg @ 2002-06-28 14:21:41 by michaels]
michaels
parents: 872
diff changeset
102 int need_to_signal_post_gc;
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
103 int funcall_allocation_flag;
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
104 Bytecount __temp_alloca_size__;
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
105 Bytecount funcall_alloca_count;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
106
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
107 /* Determine now whether we need to garbage collect or not, to make
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
108 Ffuncall() faster */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
109 #define INCREMENT_CONS_COUNTER_1(size) \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
110 do \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
111 { \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
112 consing_since_gc += (size); \
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
113 total_consing += (size); \
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
114 if (profiling_active) \
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
115 profile_record_consing (size); \
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
116 recompute_need_to_garbage_collect (); \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
117 } while (0)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
118
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
119 #define debug_allocation_backtrace() \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
120 do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
121 if (debug_allocation_backtrace_length > 0) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
122 debug_short_backtrace (debug_allocation_backtrace_length); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
123 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
124
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
125 #ifdef DEBUG_XEMACS
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
126 #define INCREMENT_CONS_COUNTER(foosize, type) \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
127 do { \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
128 if (debug_allocation) \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
129 { \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
130 stderr_out ("allocating %s (size %ld)\n", type, \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
131 (long) foosize); \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
132 debug_allocation_backtrace (); \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
133 } \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
134 INCREMENT_CONS_COUNTER_1 (foosize); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
135 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
136 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137 do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138 if (debug_allocation > 1) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139 { \
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
140 stderr_out ("allocating noseeum %s (size %ld)\n", type, \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
141 (long) foosize); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
142 debug_allocation_backtrace (); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
144 INCREMENT_CONS_COUNTER_1 (foosize); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
145 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
149 INCREMENT_CONS_COUNTER_1 (size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
152 #define DECREMENT_CONS_COUNTER(size) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
153 consing_since_gc -= (size); \
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
154 total_consing -= (size); \
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
155 if (profiling_active) \
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
156 profile_record_unconsing (size); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
157 if (consing_since_gc < 0) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
158 consing_since_gc = 0; \
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
159 recompute_need_to_garbage_collect (); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
161
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
162 /* Number of bytes of consing since gc before another gc should be done. */
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
163 static EMACS_INT gc_cons_threshold;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
164
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
165 /* Percentage of consing of total data size before another GC. */
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
166 static EMACS_INT gc_cons_percentage;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
167
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
168 #ifdef ERROR_CHECK_GC
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
169 int always_gc; /* Debugging hack; equivalent to
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
170 (setq gc-cons-thresold -1) */
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
171 #else
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
172 #define always_gc 0
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
173 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
174
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
175 /* Nonzero during gc */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176 int gc_in_progress;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
177
1154
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
178 /* Nonzero means display messages at beginning and end of GC. */
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
179
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
180 int garbage_collection_messages;
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
181
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182 /* Number of times GC has happened at this level or below.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
183 * Level 0 is most volatile, contrary to usual convention.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
184 * (Of course, there's only one level at present) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
185 EMACS_INT gc_generation_number[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
186
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
187 /* This is just for use by the printer, to allow things to print uniquely */
3063
d30cd499e445 [xemacs-hg @ 2005-11-13 10:48:01 by ben]
ben
parents: 3024
diff changeset
188 int lrecord_uid_counter;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
189
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
190 /* Nonzero when calling certain hooks or doing other things where
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191 a GC would be bad */
1957
59e1bbea04fe [xemacs-hg @ 2004-03-19 02:59:08 by james]
james
parents: 1773
diff changeset
192 int gc_currently_forbidden;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
193
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194 /* Hooks. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
195 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
196 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
197
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
198 /* "Garbage collecting" */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
199 Lisp_Object Vgc_message;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
200 Lisp_Object Vgc_pointer_glyph;
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
201 static const Ascbyte gc_default_message[] = "Garbage collecting";
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
202 Lisp_Object Qgarbage_collecting;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
203
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
204 static Lisp_Object QSin_garbage_collection;
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
205
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
206 /* Non-zero means we're in the process of doing the dump */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
207 int purify_flag;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
209 /* Non-zero means we're pdumping out or in */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
210 #ifdef PDUMP
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
211 int in_pdump;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
212 #endif
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
213
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
214 #ifdef ERROR_CHECK_TYPES
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
215
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
216 Error_Behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN, ERROR_ME_DEBUG_WARN;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
217
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
218 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
219
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
220 /* Very cheesy ways of figuring out how much memory is being used for
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
221 data. #### Need better (system-dependent) ways. */
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
222 void *minimum_address_seen;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
223 void *maximum_address_seen;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
224
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
225 #ifndef MC_ALLOC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
226 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
227 c_readonly (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
228 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
231 #endif /* MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
232
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
233 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
234 lisp_readonly (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
235 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
236 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
237 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
238
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
239
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
240 /* Maximum amount of C stack to save when a GC happens. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
241
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
242 #ifndef MAX_SAVE_STACK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
243 #define MAX_SAVE_STACK 0 /* 16000 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
244 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
246 /* Non-zero means ignore malloc warnings. Set during initialization. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
247 int ignore_malloc_warnings;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
248
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
249
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
250 #ifndef MC_ALLOC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
251 static void *breathing_space;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254 release_breathing_space (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
255 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
256 if (breathing_space)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
257 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
258 void *tmp = breathing_space;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
259 breathing_space = 0;
1726
a8d8f419b459 [xemacs-hg @ 2003-09-30 15:26:34 by james]
james
parents: 1676
diff changeset
260 xfree (tmp, void *);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
261 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
262 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
263 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
264
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
265 /* malloc calls this if it finds we are near exhausting storage */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
266 void
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
267 malloc_warning (const char *str)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
268 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
269 if (ignore_malloc_warnings)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
270 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
271
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
272 warn_when_safe
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
273 (Qmemory, Qemergency,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
274 "%s\n"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
275 "Killing some buffers may delay running out of memory.\n"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
276 "However, certainly by the time you receive the 95%% warning,\n"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
277 "you should clean up, kill this Emacs, and start a new one.",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
278 str);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
279 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
280
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
281 /* Called if malloc returns zero */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
282 DOESNT_RETURN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
283 memory_full (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
284 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
285 /* Force a GC next time eval is called.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
286 It's better to loop garbage-collecting (we might reclaim enough
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
287 to win) than to loop beeping and barfing "Memory exhausted"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
288 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
289 consing_since_gc = gc_cons_threshold + 1;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
290 recompute_need_to_garbage_collect ();
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
291 #ifndef MC_ALLOC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
292 release_breathing_space ();
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
293 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
294
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
295 /* Flush some histories which might conceivably contain garbalogical
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
296 inhibitors. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
297 if (!NILP (Fboundp (Qvalues)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
298 Fset (Qvalues, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
299 Vcommand_history = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
300
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 551
diff changeset
301 out_of_memory ("Memory exhausted", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
302 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
303
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
304 static void
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
305 set_alloc_mins_and_maxes (void *val, Bytecount size)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
306 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
307 if (!val)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
308 return;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
309 if ((char *) val + size > (char *) maximum_address_seen)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
310 maximum_address_seen = (char *) val + size;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
311 if (!minimum_address_seen)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
312 minimum_address_seen =
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
313 #if SIZEOF_VOID_P == 8
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
314 (void *) 0xFFFFFFFFFFFFFFFF;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
315 #else
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
316 (void *) 0xFFFFFFFF;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
317 #endif
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
318 if ((char *) val < (char *) minimum_address_seen)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
319 minimum_address_seen = (char *) val;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
320 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
321
1315
70921960b980 [xemacs-hg @ 2003-02-20 08:19:28 by ben]
ben
parents: 1292
diff changeset
322 #ifdef ERROR_CHECK_MALLOC
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
323 static int in_malloc;
1333
1b0339b048ce [xemacs-hg @ 2003-03-02 09:38:37 by ben]
ben
parents: 1318
diff changeset
324 extern int regex_malloc_disallowed;
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
325
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
326 #define MALLOC_BEGIN() \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
327 do \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
328 { \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
329 assert (!in_malloc); \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
330 assert (!regex_malloc_disallowed); \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
331 in_malloc = 1; \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
332 } \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
333 while (0)
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
334
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
335 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
336 #define FREE_OR_REALLOC_BEGIN(block) \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
337 do \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
338 { \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
339 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
340 error until much later on for many system mallocs, such as \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
341 the one that comes with Solaris 2.3. FMH!! */ \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
342 assert (block != (void *) 0xDEADBEEF); \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
343 MALLOC_BEGIN (); \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
344 } \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
345 while (0)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
346 #else /* not MC_ALLOC */
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
347 #define FREE_OR_REALLOC_BEGIN(block) \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
348 do \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
349 { \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
350 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
351 error until much later on for many system mallocs, such as \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
352 the one that comes with Solaris 2.3. FMH!! */ \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
353 assert (block != (void *) 0xDEADBEEF); \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
354 /* You cannot free something within dumped space, because there is \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
355 no longer any sort of malloc structure associated with the block. \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
356 If you are tripping this, you may need to conditionalize on \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
357 DUMPEDP. */ \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
358 assert (!DUMPEDP (block)); \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
359 MALLOC_BEGIN (); \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
360 } \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
361 while (0)
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
362 #endif /* not MC_ALLOC */
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
363
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
364 #define MALLOC_END() \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
365 do \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
366 { \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
367 in_malloc = 0; \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
368 } \
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
369 while (0)
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
370
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
371 #else /* ERROR_CHECK_MALLOC */
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
372
2658
a48989ca6db3 [xemacs-hg @ 2005-03-13 09:20:58 by crestani]
crestani
parents: 2650
diff changeset
373 #define MALLOC_BEGIN()
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
374 #define FREE_OR_REALLOC_BEGIN(block)
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
375 #define MALLOC_END()
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
376
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
377 #endif /* ERROR_CHECK_MALLOC */
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
378
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
379 static void
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
380 malloc_after (void *val, Bytecount size)
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
381 {
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
382 if (!val && size != 0)
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
383 memory_full ();
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
384 set_alloc_mins_and_maxes (val, size);
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
385 }
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
386
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
387 /* like malloc, calloc, realloc, free but:
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
388
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
389 -- check for no memory left
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
390 -- set internal mins and maxes
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
391 -- with error-checking on, check for reentrancy, invalid freeing, etc.
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
392 */
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
393
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
394 #undef xmalloc
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
395 void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
396 xmalloc (Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
397 {
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
398 void *val;
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
399 MALLOC_BEGIN ();
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
400 val = malloc (size);
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
401 MALLOC_END ();
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
402 malloc_after (val, size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
403 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
404 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
405
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
406 #undef xcalloc
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407 static void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
408 xcalloc (Elemcount nelem, Bytecount elsize)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
409 {
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
410 void *val;
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
411 MALLOC_BEGIN ();
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
412 val= calloc (nelem, elsize);
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
413 MALLOC_END ();
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
414 malloc_after (val, nelem * elsize);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
415 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
416 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
417
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
418 void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
419 xmalloc_and_zero (Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
420 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
421 return xcalloc (size, sizeof (char));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
422 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
423
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
424 #undef xrealloc
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
425 void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
426 xrealloc (void *block, Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427 {
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
428 FREE_OR_REALLOC_BEGIN (block);
551
e9a3f8b4de53 [xemacs-hg @ 2001-05-21 05:26:06 by martinb]
martinb
parents: 460
diff changeset
429 block = realloc (block, size);
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
430 MALLOC_END ();
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
431 malloc_after (block, size);
551
e9a3f8b4de53 [xemacs-hg @ 2001-05-21 05:26:06 by martinb]
martinb
parents: 460
diff changeset
432 return block;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
433 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
434
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
435 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
436 xfree_1 (void *block)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
437 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
438 #ifdef ERROR_CHECK_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
439 assert (block);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
440 #endif /* ERROR_CHECK_MALLOC */
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
441 FREE_OR_REALLOC_BEGIN (block);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
442 free (block);
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
443 MALLOC_END ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
444 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
445
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
446 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
447
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
448 #ifndef MC_ALLOC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
449 static void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
450 deadbeef_memory (void *ptr, Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
451 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
452 UINT_32_BIT *ptr4 = (UINT_32_BIT *) ptr;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
453 Bytecount beefs = size >> 2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
454
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
455 /* In practice, size will always be a multiple of four. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
456 while (beefs--)
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
457 (*ptr4++) = 0xDEADBEEF; /* -559038737 base 10 */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
458 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
459 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
460
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
461 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
462
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
463
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
464 #define deadbeef_memory(ptr, size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
465
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
466 #endif /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
467
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
468 #undef xstrdup
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
469 char *
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
470 xstrdup (const char *str)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
471 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
472 int len = strlen (str) + 1; /* for stupid terminating 0 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
473 void *val = xmalloc (len);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
474
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
475 if (val == 0) return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
476 return (char *) memcpy (val, str, len);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
477 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
478
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
479 #ifdef NEED_STRDUP
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
480 char *
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
481 strdup (const char *s)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
482 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
483 return xstrdup (s);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
484 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
485 #endif /* NEED_STRDUP */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
486
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
487
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
488 #ifndef MC_ALLOC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
489 static void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
490 allocate_lisp_storage (Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
491 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
492 void *val = xmalloc (size);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
493 /* We don't increment the cons counter anymore. Calling functions do
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
494 that now because we have two different kinds of cons counters -- one
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
495 for normal objects, and one for no-see-um conses (and possibly others
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
496 similar) where the conses are used totally internally, never escape,
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
497 and are created and then freed and shouldn't logically increment the
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
498 cons counting. #### (Or perhaps, we should decrement it when an object
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
499 get freed?) */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
500
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
501 /* But we do now (as of 3-27-02) go and zero out the memory. This is a
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
502 good thing, as it will guarantee we won't get any intermittent bugs
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
503 coming from an uninitiated field. The speed loss is unnoticeable,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
504 esp. as the objects are not large -- large stuff like buffer text and
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
505 redisplay structures are allocated separately. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
506 memset (val, 0, size);
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
507
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
508 if (need_to_check_c_alloca)
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
509 xemacs_c_alloca (0);
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
510
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
511 return val;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
512 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
513 #endif /* not MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
514
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
515 #if defined (MC_ALLOC) && defined (ALLOC_TYPE_STATS)
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
516 static struct
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
517 {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
518 int instances_in_use;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
519 int bytes_in_use;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
520 int bytes_in_use_including_overhead;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
521 } lrecord_stats [countof (lrecord_implementations_table)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
522 + MODULE_DEFINABLE_TYPE_COUNT];
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
523
2775
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
524 int lrecord_string_data_instances_in_use;
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
525 int lrecord_string_data_bytes_in_use;
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
526 int lrecord_string_data_bytes_in_use_including_overhead;
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
527
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
528 void
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
529 init_lrecord_stats ()
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
530 {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
531 xzero (lrecord_stats);
2775
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
532 lrecord_string_data_instances_in_use = 0;
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
533 lrecord_string_data_bytes_in_use = 0;
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
534 lrecord_string_data_bytes_in_use_including_overhead = 0;
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
535 }
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
536
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
537 void
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
538 inc_lrecord_string_data_stats (Bytecount size)
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
539 {
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
540 lrecord_string_data_instances_in_use++;
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
541 lrecord_string_data_bytes_in_use += size;
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
542 lrecord_string_data_bytes_in_use_including_overhead += size;
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
543 }
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
544
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
545 void
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
546 dec_lrecord_string_data_stats (Bytecount size)
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
547 {
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
548 lrecord_string_data_instances_in_use--;
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
549 lrecord_string_data_bytes_in_use -= size;
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
550 lrecord_string_data_bytes_in_use_including_overhead -= size;
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
551 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
552
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
553 void
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
554 inc_lrecord_stats (Bytecount size, const struct lrecord_header *h)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
555 {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
556 int type_index = h->type;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
557 if (!size)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
558 size = detagged_lisp_object_size (h);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
559
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
560 lrecord_stats[type_index].instances_in_use++;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
561 lrecord_stats[type_index].bytes_in_use += size;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
562 lrecord_stats[type_index].bytes_in_use_including_overhead
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
563 #ifdef MEMORY_USAGE_STATS
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
564 += mc_alloced_storage_size (size, 0);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
565 #else /* not MEMORY_USAGE_STATS */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
566 += size;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
567 #endif /* not MEMORY_USAGE_STATS */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
568 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
569
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
570 void
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
571 dec_lrecord_stats (Bytecount size_including_overhead,
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
572 const struct lrecord_header *h)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
573 {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
574 int type_index = h->type;
2775
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
575 int size = detagged_lisp_object_size (h);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
576
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
577 lrecord_stats[type_index].instances_in_use--;
2775
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
578 lrecord_stats[type_index].bytes_in_use -= size;
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
579 lrecord_stats[type_index].bytes_in_use_including_overhead
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
580 -= size_including_overhead;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
581
2775
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
582 DECREMENT_CONS_COUNTER (size);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
583 }
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
584 #endif /* not (MC_ALLOC && ALLOC_TYPE_STATS) */
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
585
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
586 #ifndef MC_ALLOC
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
587 /* lcrecords are chained together through their "next" field.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
588 After doing the mark phase, GC will walk this linked list
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
589 and free any lcrecord which hasn't been marked. */
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
590 static struct old_lcrecord_header *all_lcrecords;
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
591 #endif /* not MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
592
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
593 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
594 /* The basic lrecord allocation functions. See lrecord.h for details. */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
595 void *
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
596 alloc_lrecord (Bytecount size,
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
597 const struct lrecord_implementation *implementation)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
598 {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
599 struct lrecord_header *lheader;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
600
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
601 type_checking_assert
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
602 ((implementation->static_size == 0 ?
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
603 implementation->size_in_bytes_method != NULL :
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
604 implementation->static_size == size));
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
605
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
606 lheader = (struct lrecord_header *) mc_alloc (size);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
607 gc_checking_assert (LRECORD_FREE_P (lheader));
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
608 set_lheader_implementation (lheader, implementation);
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
609 #ifdef ALLOC_TYPE_STATS
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
610 inc_lrecord_stats (size, lheader);
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
611 #endif /* ALLOC_TYPE_STATS */
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
612 INCREMENT_CONS_COUNTER (size, implementation->name);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
613 return lheader;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
614 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
615
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
616 void *
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
617 noseeum_alloc_lrecord (Bytecount size,
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
618 const struct lrecord_implementation *implementation)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
619 {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
620 struct lrecord_header *lheader;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
621
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
622 type_checking_assert
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
623 ((implementation->static_size == 0 ?
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
624 implementation->size_in_bytes_method != NULL :
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
625 implementation->static_size == size));
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
626
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
627 lheader = (struct lrecord_header *) mc_alloc (size);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
628 gc_checking_assert (LRECORD_FREE_P (lheader));
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
629 set_lheader_implementation (lheader, implementation);
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
630 #ifdef ALLOC_TYPE_STATS
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
631 inc_lrecord_stats (size, lheader);
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
632 #endif /* ALLOC_TYPE_STATS */
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
633 NOSEEUM_INCREMENT_CONS_COUNTER (size, implementation->name);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
634 return lheader;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
635 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
636
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
637 void
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
638 free_lrecord (Lisp_Object lrecord)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
639 {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
640 gc_checking_assert (!gc_in_progress);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
641 gc_checking_assert (!LRECORD_FREE_P (XRECORD_LHEADER (lrecord)));
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
642 gc_checking_assert (!XRECORD_LHEADER (lrecord)->free);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
643
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
644 MC_ALLOC_CALL_FINALIZER (XPNTR (lrecord));
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
645 mc_free (XPNTR (lrecord));
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
646 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
647 #else /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
649 /* The most basic of the lcrecord allocation functions. Not usually called
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
650 directly. Allocates an lrecord not managed by any lcrecord-list, of a
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
651 specified size. See lrecord.h. */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
652
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
653 void *
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
654 old_basic_alloc_lcrecord (Bytecount size,
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
655 const struct lrecord_implementation *implementation)
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
656 {
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
657 struct old_lcrecord_header *lcheader;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
658
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
659 type_checking_assert
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
660 ((implementation->static_size == 0 ?
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
661 implementation->size_in_bytes_method != NULL :
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
662 implementation->static_size == size)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
663 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
664 (! implementation->basic_p)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
665 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
666 (! (implementation->hash == NULL && implementation->equal != NULL)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
667
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
668 lcheader = (struct old_lcrecord_header *) allocate_lisp_storage (size);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
669 set_lheader_implementation (&lcheader->lheader, implementation);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
670 lcheader->next = all_lcrecords;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
671 #if 1 /* mly prefers to see small ID numbers */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
672 lcheader->uid = lrecord_uid_counter++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
673 #else /* jwz prefers to see real addrs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
674 lcheader->uid = (int) &lcheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
675 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
676 lcheader->free = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
677 all_lcrecords = lcheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
678 INCREMENT_CONS_COUNTER (size, implementation->name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
679 return lcheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
680 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
681
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
682 #if 0 /* Presently unused */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
683 /* Very, very poor man's EGC?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
684 * This may be slow and thrash pages all over the place.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
685 * Only call it if you really feel you must (and if the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
686 * lrecord was fairly recently allocated).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
687 * Otherwise, just let the GC do its job -- that's what it's there for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
688 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
689 void
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
690 very_old_free_lcrecord (struct old_lcrecord_header *lcrecord)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
691 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
692 if (all_lcrecords == lcrecord)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
693 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
694 all_lcrecords = lcrecord->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
695 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
696 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
697 {
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
698 struct old_lcrecord_header *header = all_lcrecords;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
699 for (;;)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
700 {
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
701 struct old_lcrecord_header *next = header->next;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
702 if (next == lcrecord)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
703 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
704 header->next = lrecord->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
705 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
706 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
707 else if (next == 0)
2500
3d8143fc88e1 [xemacs-hg @ 2005-01-24 23:33:30 by ben]
ben
parents: 2367
diff changeset
708 ABORT ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
709 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
710 header = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
711 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
712 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
713 if (lrecord->implementation->finalizer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
714 lrecord->implementation->finalizer (lrecord, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
715 xfree (lrecord);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
716 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
717 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
718 #endif /* Unused */
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
719 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
720
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
721
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
722 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
723 disksave_object_finalization_1 (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
724 {
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
725 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
726 mc_finalize_for_disksave ();
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
727 #else /* not MC_ALLOC */
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
728 struct old_lcrecord_header *header;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
729
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
730 for (header = all_lcrecords; header; header = header->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
731 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
732 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
733 !header->free)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
734 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
735 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
736 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
737 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
738
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
739 /* Bitwise copy all parts of a Lisp object other than the header */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
740
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
741 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
742 copy_lisp_object (Lisp_Object dst, Lisp_Object src)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
743 {
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
744 const struct lrecord_implementation *imp =
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
745 XRECORD_LHEADER_IMPLEMENTATION (src);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
746 Bytecount size = lisp_object_size (src);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
747
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
748 assert (imp == XRECORD_LHEADER_IMPLEMENTATION (dst));
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
749 assert (size == lisp_object_size (dst));
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
750
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
751 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
752 memcpy ((char *) XRECORD_LHEADER (dst) + sizeof (struct lrecord_header),
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
753 (char *) XRECORD_LHEADER (src) + sizeof (struct lrecord_header),
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
754 size - sizeof (struct lrecord_header));
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
755 #else /* not MC_ALLOC */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
756 if (imp->basic_p)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
757 memcpy ((char *) XRECORD_LHEADER (dst) + sizeof (struct lrecord_header),
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
758 (char *) XRECORD_LHEADER (src) + sizeof (struct lrecord_header),
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
759 size - sizeof (struct lrecord_header));
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
760 else
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
761 memcpy ((char *) XRECORD_LHEADER (dst) +
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
762 sizeof (struct old_lcrecord_header),
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
763 (char *) XRECORD_LHEADER (src) +
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
764 sizeof (struct old_lcrecord_header),
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
765 size - sizeof (struct old_lcrecord_header));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
766 #endif /* not MC_ALLOC */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
767 }
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
768
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
769
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
770 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
771 /* Debugger support */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
772 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
773 /* Give gdb/dbx enough information to decode Lisp Objects. We make
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
774 sure certain symbols are always defined, so gdb doesn't complain
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
775 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
776 to see how this is used. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
777
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
778 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
779 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
780
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
781 #ifdef USE_UNION_TYPE
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
782 unsigned char dbg_USE_UNION_TYPE = 1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
783 #else
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
784 unsigned char dbg_USE_UNION_TYPE = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
785 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
786
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
787 unsigned char dbg_valbits = VALBITS;
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
788 unsigned char dbg_gctypebits = GCTYPEBITS;
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
789
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
790 /* On some systems, the above definitions will be optimized away by
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
791 the compiler or linker unless they are referenced in some function. */
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
792 long dbg_inhibit_dbg_symbol_deletion (void);
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
793 long
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
794 dbg_inhibit_dbg_symbol_deletion (void)
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
795 {
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
796 return
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
797 (dbg_valmask +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
798 dbg_typemask +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
799 dbg_USE_UNION_TYPE +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
800 dbg_valbits +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
801 dbg_gctypebits);
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
802 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
803
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
804 /* Macros turned into functions for ease of debugging.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
805 Debuggers don't know about macros! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
806 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
807 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
808 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
809 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
810 return EQ (obj1, obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
811 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
812
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
813
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
814 #ifdef MC_ALLOC
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
815 #define DECLARE_FIXED_TYPE_ALLOC(type, structture) struct __foo__
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
816 #else
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
817 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
818 /* Fixed-size type macros */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
819 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
820
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
821 /* For fixed-size types that are commonly used, we malloc() large blocks
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
822 of memory at a time and subdivide them into chunks of the correct
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
823 size for an object of that type. This is more efficient than
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
824 malloc()ing each object separately because we save on malloc() time
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
825 and overhead due to the fewer number of malloc()ed blocks, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
826 also because we don't need any extra pointers within each object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
827 to keep them threaded together for GC purposes. For less common
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
828 (and frequently large-size) types, we use lcrecords, which are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
829 malloc()ed individually and chained together through a pointer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
830 in the lcrecord header. lcrecords do not need to be fixed-size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
831 (i.e. two objects of the same type need not have the same size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
832 however, the size of a particular object cannot vary dynamically).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
833 It is also much easier to create a new lcrecord type because no
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
834 additional code needs to be added to alloc.c. Finally, lcrecords
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
835 may be more efficient when there are only a small number of them.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
836
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
837 The types that are stored in these large blocks (or "frob blocks")
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
838 are cons, all number types except fixnum, compiled-function, symbol,
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
839 marker, extent, event, and string.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
840
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
841 Note that strings are special in that they are actually stored in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
842 two parts: a structure containing information about the string, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
843 the actual data associated with the string. The former structure
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
844 (a struct Lisp_String) is a fixed-size structure and is managed the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
845 same way as all the other such types. This structure contains a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
846 pointer to the actual string data, which is stored in structures of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
847 type struct string_chars_block. Each string_chars_block consists
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
848 of a pointer to a struct Lisp_String, followed by the data for that
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
849 string, followed by another pointer to a Lisp_String, followed by
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
850 the data for that string, etc. At GC time, the data in these
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
851 blocks is compacted by searching sequentially through all the
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
852 blocks and compressing out any holes created by unmarked strings.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
853 Strings that are more than a certain size (bigger than the size of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
854 a string_chars_block, although something like half as big might
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
855 make more sense) are malloc()ed separately and not stored in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
856 string_chars_blocks. Furthermore, no one string stretches across
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
857 two string_chars_blocks.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
858
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
859 Vectors are each malloc()ed separately as lcrecords.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
860
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
861 In the following discussion, we use conses, but it applies equally
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
862 well to the other fixed-size types.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
863
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
864 We store cons cells inside of cons_blocks, allocating a new
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
865 cons_block with malloc() whenever necessary. Cons cells reclaimed
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
866 by GC are put on a free list to be reallocated before allocating
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
867 any new cons cells from the latest cons_block. Each cons_block is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
868 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
869 the versions in malloc.c and gmalloc.c) really allocates in units
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
870 of powers of two and uses 4 bytes for its own overhead.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
871
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
872 What GC actually does is to search through all the cons_blocks,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
873 from the most recently allocated to the oldest, and put all
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
874 cons cells that are not marked (whether or not they're already
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
875 free) on a cons_free_list. The cons_free_list is a stack, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
876 so the cons cells in the oldest-allocated cons_block end up
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
877 at the head of the stack and are the first to be reallocated.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
878 If any cons_block is entirely free, it is freed with free()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
879 and its cons cells removed from the cons_free_list. Because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
880 the cons_free_list ends up basically in memory order, we have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
881 a high locality of reference (assuming a reasonable turnover
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
882 of allocating and freeing) and have a reasonable probability
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
883 of entirely freeing up cons_blocks that have been more recently
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
884 allocated. This stage is called the "sweep stage" of GC, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
885 is executed after the "mark stage", which involves starting
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
886 from all places that are known to point to in-use Lisp objects
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
887 (e.g. the obarray, where are all symbols are stored; the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
888 current catches and condition-cases; the backtrace list of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
889 currently executing functions; the gcpro list; etc.) and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
890 recursively marking all objects that are accessible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
891
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
892 At the beginning of the sweep stage, the conses in the cons blocks
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
893 are in one of three states: in use and marked, in use but not
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
894 marked, and not in use (already freed). Any conses that are marked
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
895 have been marked in the mark stage just executed, because as part
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
896 of the sweep stage we unmark any marked objects. The way we tell
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
897 whether or not a cons cell is in use is through the LRECORD_FREE_P
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
898 macro. This uses a special lrecord type `lrecord_type_free',
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
899 which is never associated with any valid object.
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
900
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
901 Conses on the free_cons_list are threaded through a pointer stored
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
902 in the conses themselves. Because the cons is still in a
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
903 cons_block and needs to remain marked as not in use for the next
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
904 time that GC happens, we need room to store both the "free"
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
905 indicator and the chaining pointer. So this pointer is stored
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
906 after the lrecord header (actually where C places a pointer after
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
907 the lrecord header; they are not necessarily contiguous). This
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
908 implies that all fixed-size types must be big enough to contain at
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
909 least one pointer. This is true for all current fixed-size types,
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
910 with the possible exception of Lisp_Floats, for which we define the
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
911 meat of the struct using a union of a pointer and a double to
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
912 ensure adequate space for the free list chain pointer.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
913
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
914 Some types of objects need additional "finalization" done
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
915 when an object is converted from in use to not in use;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
916 this is the purpose of the ADDITIONAL_FREE_type macro.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
917 For example, markers need to be removed from the chain
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
918 of markers that is kept in each buffer. This is because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
919 markers in a buffer automatically disappear if the marker
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
920 is no longer referenced anywhere (the same does not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
921 apply to extents, however).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
922
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
923 WARNING: Things are in an extremely bizarre state when
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
924 the ADDITIONAL_FREE_type macros are called, so beware!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
925
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
926 When ERROR_CHECK_GC is defined, we do things differently so as to
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
927 maximize our chances of catching places where there is insufficient
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
928 GCPROing. The thing we want to avoid is having an object that
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
929 we're using but didn't GCPRO get freed by GC and then reallocated
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
930 while we're in the process of using it -- this will result in
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
931 something seemingly unrelated getting trashed, and is extremely
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
932 difficult to track down. If the object gets freed but not
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
933 reallocated, we can usually catch this because we set most of the
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
934 bytes of a freed object to 0xDEADBEEF. (The lisp object type is set
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
935 to the invalid type `lrecord_type_free', however, and a pointer
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
936 used to chain freed objects together is stored after the lrecord
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
937 header; we play some tricks with this pointer to make it more
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
938 bogus, so crashes are more likely to occur right away.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
939
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
940 We want freed objects to stay free as long as possible,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
941 so instead of doing what we do above, we maintain the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
942 free objects in a first-in first-out queue. We also
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
943 don't recompute the free list each GC, unlike above;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
944 this ensures that the queue ordering is preserved.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
945 [This means that we are likely to have worse locality
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
946 of reference, and that we can never free a frob block
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
947 once it's allocated. (Even if we know that all cells
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
948 in it are free, there's no easy way to remove all those
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
949 cells from the free list because the objects on the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
950 free list are unlikely to be in memory order.)]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
951 Furthermore, we never take objects off the free list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
952 unless there's a large number (usually 1000, but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
953 varies depending on type) of them already on the list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
954 This way, we ensure that an object that gets freed will
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
955 remain free for the next 1000 (or whatever) times that
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
956 an object of that type is allocated. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
957
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
958 #ifndef MALLOC_OVERHEAD
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
959 #ifdef GNU_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
960 #define MALLOC_OVERHEAD 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
961 #elif defined (rcheck)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
962 #define MALLOC_OVERHEAD 20
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
963 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
964 #define MALLOC_OVERHEAD 8
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
965 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
966 #endif /* MALLOC_OVERHEAD */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
967
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
968 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
969 /* If we released our reserve (due to running out of memory),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
970 and we have a fair amount free once again,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
971 try to set aside another reserve in case we run out once more.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
972
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
973 This is called when a relocatable block is freed in ralloc.c. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
974 void refill_memory_reserve (void);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
975 void
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
976 refill_memory_reserve (void)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
977 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
978 if (breathing_space == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
979 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
980 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
981 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
982
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
983 #ifdef ALLOC_NO_POOLS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
984 # define TYPE_ALLOC_SIZE(type, structtype) 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
985 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
986 # define TYPE_ALLOC_SIZE(type, structtype) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
987 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
988 / sizeof (structtype))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
989 #endif /* ALLOC_NO_POOLS */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
990
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
991 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
992 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
993 struct type##_block \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
994 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
995 struct type##_block *prev; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
996 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
997 }; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
998 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
999 static struct type##_block *current_##type##_block; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1000 static int current_##type##_block_index; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1001 \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1002 static Lisp_Free *type##_free_list; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1003 static Lisp_Free *type##_free_list_tail; \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1004 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1005 static void \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1006 init_##type##_alloc (void) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1007 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1008 current_##type##_block = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1009 current_##type##_block_index = \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1010 countof (current_##type##_block->block); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1011 type##_free_list = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1012 type##_free_list_tail = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1013 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1014 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1015 static int gc_count_num_##type##_in_use; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1016 static int gc_count_num_##type##_freelist
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1017
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1018 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1019 if (current_##type##_block_index \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1020 == countof (current_##type##_block->block)) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1021 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1022 struct type##_block *AFTFB_new = (struct type##_block *) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1023 allocate_lisp_storage (sizeof (struct type##_block)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1024 AFTFB_new->prev = current_##type##_block; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1025 current_##type##_block = AFTFB_new; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1026 current_##type##_block_index = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1027 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1028 (result) = \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1029 &(current_##type##_block->block[current_##type##_block_index++]); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1030 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1031
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1032 /* Allocate an instance of a type that is stored in blocks.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1033 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1034 structure type. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1035
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1036 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1037
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1038 /* Note: if you get crashes in this function, suspect incorrect calls
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1039 to free_cons() and friends. This happened once because the cons
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1040 cell was not GC-protected and was getting collected before
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1041 free_cons() was called. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1042
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1043 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1044 if (gc_count_num_##type##_freelist > \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1045 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1046 { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1047 result = (structtype *) type##_free_list; \
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1048 assert (LRECORD_FREE_P (result)); \
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1049 /* Before actually using the chain pointer, we complement \
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1050 all its bits; see PUT_FIXED_TYPE_ON_FREE_LIST(). */ \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1051 type##_free_list = (Lisp_Free *) \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1052 (~ (EMACS_UINT) (type##_free_list->chain)); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1053 gc_count_num_##type##_freelist--; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1054 } \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1055 else \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1056 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1057 MARK_LRECORD_AS_NOT_FREE (result); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1058 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1059
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1060 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1061
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1062 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1063 if (type##_free_list) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1064 { \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1065 result = (structtype *) type##_free_list; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1066 type##_free_list = type##_free_list->chain; \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1067 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1068 else \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1069 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1070 MARK_LRECORD_AS_NOT_FREE (result); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1071 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1072
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1073 #endif /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1074
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1075
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1076 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1077 do \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1078 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1079 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1080 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1081 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1082
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1083 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1084 do \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1085 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1086 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1087 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1088 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1089
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1090 /* Lisp_Free is the type to represent a free list member inside a frob
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1091 block of any lisp object type. */
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1092 typedef struct Lisp_Free
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1093 {
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1094 struct lrecord_header lheader;
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1095 struct Lisp_Free *chain;
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1096 } Lisp_Free;
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1097
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1098 #define LRECORD_FREE_P(ptr) \
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1099 (((struct lrecord_header *) ptr)->type == lrecord_type_free)
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1100
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1101 #define MARK_LRECORD_AS_FREE(ptr) \
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1102 ((void) (((struct lrecord_header *) ptr)->type = lrecord_type_free))
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1103
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1104 #ifdef ERROR_CHECK_GC
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1105 #define MARK_LRECORD_AS_NOT_FREE(ptr) \
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1106 ((void) (((struct lrecord_header *) ptr)->type = lrecord_type_undefined))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1107 #else
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1108 #define MARK_LRECORD_AS_NOT_FREE(ptr) DO_NOTHING
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1109 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1110
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1111 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1112
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1113 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1114 if (type##_free_list_tail) \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1115 { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1116 /* When we store the chain pointer, we complement all \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1117 its bits; this should significantly increase its \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1118 bogosity in case someone tries to use the value, and \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1119 should make us crash faster if someone overwrites the \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1120 pointer because when it gets un-complemented in \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1121 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1122 extremely bogus. */ \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1123 type##_free_list_tail->chain = \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1124 (Lisp_Free *) ~ (EMACS_UINT) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1125 } \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1126 else \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1127 type##_free_list = (Lisp_Free *) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1128 type##_free_list_tail = (Lisp_Free *) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1129 } while (0)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1130
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1131 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1132
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1133 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1134 ((Lisp_Free *) (ptr))->chain = type##_free_list; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1135 type##_free_list = (Lisp_Free *) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1136 } while (0) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1137
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1138 #endif /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1139
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1140 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1141
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1142 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1143 structtype *FFT_ptr = (ptr); \
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1144 gc_checking_assert (!LRECORD_FREE_P (FFT_ptr)); \
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
1145 gc_checking_assert (!DUMPEDP (FFT_ptr)); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1146 ADDITIONAL_FREE_##type (FFT_ptr); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1147 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1148 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1149 MARK_LRECORD_AS_FREE (FFT_ptr); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1150 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1151
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1152 /* Like FREE_FIXED_TYPE() but used when we are explicitly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1153 freeing a structure through free_cons(), free_marker(), etc.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1154 rather than through the normal process of sweeping.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1155 We attempt to undo the changes made to the allocation counters
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1156 as a result of this structure being allocated. This is not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1157 completely necessary but helps keep things saner: e.g. this way,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1158 repeatedly allocating and freeing a cons will not result in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1159 the consing-since-gc counter advancing, which would cause a GC
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1160 and somewhat defeat the purpose of explicitly freeing.
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1161
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1162 We also disable this mechanism entirely when ALLOC_NO_POOLS is
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1163 set, which is used for Purify and the like. */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1164
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1165 #ifndef ALLOC_NO_POOLS
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1166 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1167 do { FREE_FIXED_TYPE (type, structtype, ptr); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1168 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1169 gc_count_num_##type##_freelist++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1170 } while (0)
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1171 #else
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1172 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1173 #endif
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
1174 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1175
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1176 #ifdef MC_ALLOC
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1177 #define ALLOCATE_FIXED_TYPE_AND_SET_IMPL(type, lisp_type, var, lrec_ptr) \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1178 do { \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1179 (var) = alloc_lrecord_type (lisp_type, lrec_ptr); \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1180 } while (0)
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1181 #define NOSEEUM_ALLOCATE_FIXED_TYPE_AND_SET_IMPL(type, lisp_type, var, \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1182 lrec_ptr) \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1183 do { \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1184 (var) = noseeum_alloc_lrecord_type (lisp_type, lrec_ptr); \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1185 } while (0)
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1186 #else /* not MC_ALLOC */
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1187 #define ALLOCATE_FIXED_TYPE_AND_SET_IMPL(type, lisp_type, var, lrec_ptr) \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1188 do \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1189 { \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1190 ALLOCATE_FIXED_TYPE (type, lisp_type, var); \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1191 set_lheader_implementation (&(var)->lheader, lrec_ptr); \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1192 } while (0)
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1193 #define NOSEEUM_ALLOCATE_FIXED_TYPE_AND_SET_IMPL(type, lisp_type, var, \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1194 lrec_ptr) \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1195 do \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1196 { \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1197 NOSEEUM_ALLOCATE_FIXED_TYPE (type, lisp_type, var); \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1198 set_lheader_implementation (&(var)->lheader, lrec_ptr); \
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1199 } while (0)
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1200 #endif /* MC_ALLOC */
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1201
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1202
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1203
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1204 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1205 /* Cons allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1206 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1207
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1208 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1209 /* conses are used and freed so often that we set this really high */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1210 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1211 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1212
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1213 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1214 mark_cons (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1215 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1216 if (NILP (XCDR (obj)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1217 return XCAR (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1218
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1219 mark_object (XCAR (obj));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1220 return XCDR (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1221 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1222
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1223 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1224 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1225 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1226 depth++;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1227 while (internal_equal (XCAR (ob1), XCAR (ob2), depth))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1228 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1229 ob1 = XCDR (ob1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1230 ob2 = XCDR (ob2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1231 if (! CONSP (ob1) || ! CONSP (ob2))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1232 return internal_equal (ob1, ob2, depth);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1233 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1234 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1235 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1236
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1237 static const struct memory_description cons_description[] = {
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
1238 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car_) },
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
1239 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr_) },
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1240 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1241 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1242
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
1243 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
1244 1, /*dumpable-flag*/
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
1245 mark_cons, print_cons, 0,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
1246 cons_equal,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
1247 /*
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
1248 * No `hash' method needed.
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
1249 * internal_hash knows how to
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
1250 * handle conses.
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
1251 */
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
1252 0,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
1253 cons_description,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
1254 Lisp_Cons);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1255
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1256 DEFUN ("cons", Fcons, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1257 Create a new cons, give it CAR and CDR as components, and return it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1258 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1259 (car, cdr))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1260 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1261 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1262 Lisp_Object val;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1263 Lisp_Cons *c;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1264
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1265 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (cons, Lisp_Cons, c, &lrecord_cons);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1266 val = wrap_cons (c);
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
1267 XSETCAR (val, car);
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
1268 XSETCDR (val, cdr);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1269 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1270 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1271
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1272 /* This is identical to Fcons() but it used for conses that we're
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1273 going to free later, and is useful when trying to track down
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1274 "real" consing. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1275 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1276 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1277 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1278 Lisp_Object val;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1279 Lisp_Cons *c;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1280
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1281 NOSEEUM_ALLOCATE_FIXED_TYPE_AND_SET_IMPL (cons, Lisp_Cons, c, &lrecord_cons);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1282 val = wrap_cons (c);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1283 XCAR (val) = car;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1284 XCDR (val) = cdr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1285 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1286 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1287
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1288 DEFUN ("list", Flist, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1289 Return a newly created list with specified arguments as elements.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1290 Any number of arguments, even zero arguments, are allowed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1291 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1292 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1293 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1294 Lisp_Object val = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1295 Lisp_Object *argp = args + nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1296
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1297 while (argp > args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1298 val = Fcons (*--argp, val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1299 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1300 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1301
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1302 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1303 list1 (Lisp_Object obj0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1304 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1305 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1306 return Fcons (obj0, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1307 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1308
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1309 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1310 list2 (Lisp_Object obj0, Lisp_Object obj1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1311 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1312 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1313 return Fcons (obj0, Fcons (obj1, Qnil));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1314 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1315
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1316 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1317 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1318 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1319 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1320 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1321 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1322
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1323 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1324 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1325 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1326 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1327 return Fcons (obj0, Fcons (obj1, obj2));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1328 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1329
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1330 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1331 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1332 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1333 return Fcons (Fcons (key, value), alist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1334 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1335
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1336 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1337 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1338 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1339 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1340 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1341 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1342
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1343 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1344 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1345 Lisp_Object obj4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1346 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1347 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1348 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1349 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1350
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1351 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1352 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1353 Lisp_Object obj4, Lisp_Object obj5)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1354 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1355 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1356 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1357 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1358
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1359 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1360 Return a new list of length LENGTH, with each element being OBJECT.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1361 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1362 (length, object))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1363 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1364 CHECK_NATNUM (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1365
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1366 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1367 Lisp_Object val = Qnil;
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
1368 EMACS_INT size = XINT (length);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1369
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1370 while (size--)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1371 val = Fcons (object, val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1372 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1373 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1374 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1375
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1376
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1377 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1378 /* Float allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1379 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1380
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1381 /*** With enhanced number support, these are short floats */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1382
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1383 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1384 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1385
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1386 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1387 make_float (double float_value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1388 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1389 Lisp_Float *f;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1390
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1391 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (float, Lisp_Float, f, &lrecord_float);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1392
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1393 /* Avoid dump-time `uninitialized memory read' purify warnings. */
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1394 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1395 zero_lrecord (f);
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1396
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1397 float_data (f) = float_value;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1398 return wrap_float (f);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1399 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1400
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1401
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1402 /************************************************************************/
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1403 /* Enhanced number allocation */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1404 /************************************************************************/
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1405
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1406 /*** Bignum ***/
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1407 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1408 DECLARE_FIXED_TYPE_ALLOC (bignum, Lisp_Bignum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1409 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bignum 250
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1410
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1411 /* WARNING: This function returns a bignum even if its argument fits into a
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1412 fixnum. See Fcanonicalize_number(). */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1413 Lisp_Object
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1414 make_bignum (long bignum_value)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1415 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1416 Lisp_Bignum *b;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1417
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1418 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (bignum, Lisp_Bignum, b, &lrecord_bignum);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1419 bignum_init (bignum_data (b));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1420 bignum_set_long (bignum_data (b), bignum_value);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1421 return wrap_bignum (b);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1422 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1423
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1424 /* WARNING: This function returns a bignum even if its argument fits into a
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1425 fixnum. See Fcanonicalize_number(). */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1426 Lisp_Object
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1427 make_bignum_bg (bignum bg)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1428 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1429 Lisp_Bignum *b;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1430
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1431 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (bignum, Lisp_Bignum, b, &lrecord_bignum);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1432 bignum_init (bignum_data (b));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1433 bignum_set (bignum_data (b), bg);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1434 return wrap_bignum (b);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1435 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1436 #endif /* HAVE_BIGNUM */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1437
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1438 /*** Ratio ***/
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1439 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1440 DECLARE_FIXED_TYPE_ALLOC (ratio, Lisp_Ratio);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1441 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_ratio 250
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1442
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1443 Lisp_Object
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1444 make_ratio (long numerator, unsigned long denominator)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1445 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1446 Lisp_Ratio *r;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1447
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1448 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (ratio, Lisp_Ratio, r, &lrecord_ratio);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1449 ratio_init (ratio_data (r));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1450 ratio_set_long_ulong (ratio_data (r), numerator, denominator);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1451 ratio_canonicalize (ratio_data (r));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1452 return wrap_ratio (r);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1453 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1454
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1455 Lisp_Object
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1456 make_ratio_bg (bignum numerator, bignum denominator)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1457 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1458 Lisp_Ratio *r;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1459
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1460 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (ratio, Lisp_Ratio, r, &lrecord_ratio);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1461 ratio_init (ratio_data (r));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1462 ratio_set_bignum_bignum (ratio_data (r), numerator, denominator);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1463 ratio_canonicalize (ratio_data (r));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1464 return wrap_ratio (r);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1465 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1466
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1467 Lisp_Object
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1468 make_ratio_rt (ratio rat)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1469 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1470 Lisp_Ratio *r;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1471
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1472 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (ratio, Lisp_Ratio, r, &lrecord_ratio);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1473 ratio_init (ratio_data (r));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1474 ratio_set (ratio_data (r), rat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1475 return wrap_ratio (r);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1476 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1477 #endif /* HAVE_RATIO */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1478
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1479 /*** Bigfloat ***/
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1480 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1481 DECLARE_FIXED_TYPE_ALLOC (bigfloat, Lisp_Bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1482 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigfloat 250
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1483
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1484 /* This function creates a bigfloat with the default precision if the
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1485 PRECISION argument is zero. */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1486 Lisp_Object
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1487 make_bigfloat (double float_value, unsigned long precision)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1488 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1489 Lisp_Bigfloat *f;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1490
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1491 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (bigfloat, Lisp_Bigfloat, f, &lrecord_bigfloat);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1492 if (precision == 0UL)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1493 bigfloat_init (bigfloat_data (f));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1494 else
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1495 bigfloat_init_prec (bigfloat_data (f), precision);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1496 bigfloat_set_double (bigfloat_data (f), float_value);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1497 return wrap_bigfloat (f);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1498 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1499
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1500 /* This function creates a bigfloat with the precision of its argument */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1501 Lisp_Object
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1502 make_bigfloat_bf (bigfloat float_value)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1503 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1504 Lisp_Bigfloat *f;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1505
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1506 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (bigfloat, Lisp_Bigfloat, f, &lrecord_bigfloat);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1507 bigfloat_init_prec (bigfloat_data (f), bigfloat_get_prec (float_value));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1508 bigfloat_set (bigfloat_data (f), float_value);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1509 return wrap_bigfloat (f);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1510 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1511 #endif /* HAVE_BIGFLOAT */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1512
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
1513 /************************************************************************/
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1514 /* Vector allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1515 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1516
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1517 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1518 mark_vector (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1519 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1520 Lisp_Vector *ptr = XVECTOR (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1521 int len = vector_length (ptr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1522 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1523
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1524 for (i = 0; i < len - 1; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1525 mark_object (ptr->contents[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1526 return (len > 0) ? ptr->contents[len - 1] : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1527 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1528
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1529 static Bytecount
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1530 size_vector (const void *lheader)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1531 {
456
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 454
diff changeset
1532 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, contents,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1533 ((Lisp_Vector *) lheader)->size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1534 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1535
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1536 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1537 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1538 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1539 int len = XVECTOR_LENGTH (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1540 if (len != XVECTOR_LENGTH (obj2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1541 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1542
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1543 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1544 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1545 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1546 while (len--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1547 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1548 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1549 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1550 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1551 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1552
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1553 static Hashcode
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1554 vector_hash (Lisp_Object obj, int depth)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1555 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1556 return HASH2 (XVECTOR_LENGTH (obj),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1557 internal_array_hash (XVECTOR_DATA (obj),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1558 XVECTOR_LENGTH (obj),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1559 depth + 1));
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1560 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1561
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1562 static const struct memory_description vector_description[] = {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1563 { XD_LONG, offsetof (Lisp_Vector, size) },
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1564 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) },
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1565 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1566 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1567
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1568 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("vector", vector,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1569 1, /*dumpable-flag*/
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1570 mark_vector, print_vector, 0,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1571 vector_equal,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1572 vector_hash,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1573 vector_description,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1574 size_vector, Lisp_Vector);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1575 /* #### should allocate `small' vectors from a frob-block */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1576 static Lisp_Vector *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1577 make_vector_internal (Elemcount sizei)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1578 {
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1579 /* no `next' field; we use lcrecords */
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1580 Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object,
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1581 contents, sizei);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1582 Lisp_Vector *p =
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1583 (Lisp_Vector *) BASIC_ALLOC_LCRECORD (sizem, &lrecord_vector);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1584
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1585 p->size = sizei;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1586 return p;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1587 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1588
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1589 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1590 make_vector (Elemcount length, Lisp_Object object)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1591 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1592 Lisp_Vector *vecp = make_vector_internal (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1593 Lisp_Object *p = vector_data (vecp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1594
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1595 while (length--)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1596 *p++ = object;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1597
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1598 return wrap_vector (vecp);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1599 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1600
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1601 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1602 Return a new vector of length LENGTH, with each element being OBJECT.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1603 See also the function `vector'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1604 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1605 (length, object))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1606 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1607 CONCHECK_NATNUM (length);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1608 return make_vector (XINT (length), object);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1609 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1610
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1611 DEFUN ("vector", Fvector, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1612 Return a newly created vector with specified arguments as elements.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1613 Any number of arguments, even zero arguments, are allowed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1614 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1615 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1616 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1617 Lisp_Vector *vecp = make_vector_internal (nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1618 Lisp_Object *p = vector_data (vecp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1619
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1620 while (nargs--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1621 *p++ = *args++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1622
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1623 return wrap_vector (vecp);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1624 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1625
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1626 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1627 vector1 (Lisp_Object obj0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1628 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1629 return Fvector (1, &obj0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1630 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1631
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1632 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1633 vector2 (Lisp_Object obj0, Lisp_Object obj1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1634 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1635 Lisp_Object args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1636 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1637 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1638 return Fvector (2, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1639 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1640
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1641 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1642 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1643 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1644 Lisp_Object args[3];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1645 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1646 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1647 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1648 return Fvector (3, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1649 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1650
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1651 #if 0 /* currently unused */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1652
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1653 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1654 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1655 Lisp_Object obj3)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1656 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1657 Lisp_Object args[4];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1658 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1659 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1660 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1661 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1662 return Fvector (4, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1663 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1664
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1665 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1666 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1667 Lisp_Object obj3, Lisp_Object obj4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1668 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1669 Lisp_Object args[5];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1670 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1671 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1672 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1673 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1674 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1675 return Fvector (5, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1676 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1677
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1678 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1679 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1680 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1681 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1682 Lisp_Object args[6];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1683 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1684 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1685 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1686 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1687 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1688 args[5] = obj5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1689 return Fvector (6, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1690 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1691
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1692 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1693 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1694 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1695 Lisp_Object obj6)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1696 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1697 Lisp_Object args[7];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1698 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1699 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1700 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1701 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1702 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1703 args[5] = obj5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1704 args[6] = obj6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1705 return Fvector (7, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1706 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1707
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1708 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1709 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1710 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1711 Lisp_Object obj6, Lisp_Object obj7)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1712 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1713 Lisp_Object args[8];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1714 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1715 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1716 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1717 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1718 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1719 args[5] = obj5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1720 args[6] = obj6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1721 args[7] = obj7;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1722 return Fvector (8, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1723 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1724 #endif /* unused */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1725
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1726 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1727 /* Bit Vector allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1728 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1729
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1730 /* #### should allocate `small' bit vectors from a frob-block */
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1731 static Lisp_Bit_Vector *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1732 make_bit_vector_internal (Elemcount sizei)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1733 {
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1734 /* no `next' field; we use lcrecords */
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1735 Elemcount num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1736 Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector,
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1737 unsigned long,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1738 bits, num_longs);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
1739 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *)
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1740 BASIC_ALLOC_LCRECORD (sizem, &lrecord_bit_vector);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1741
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1742 bit_vector_length (p) = sizei;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1743 return p;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1744 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1745
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1746 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1747 make_bit_vector (Elemcount length, Lisp_Object bit)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1748 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1749 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1750 Elemcount num_longs = BIT_VECTOR_LONG_STORAGE (length);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1751
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1752 CHECK_BIT (bit);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1753
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1754 if (ZEROP (bit))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1755 memset (p->bits, 0, num_longs * sizeof (long));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1756 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1757 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1758 Elemcount bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1759 memset (p->bits, ~0, num_longs * sizeof (long));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1760 /* But we have to make sure that the unused bits in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1761 last long are 0, so that equal/hash is easy. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1762 if (bits_in_last)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1763 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1764 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1765
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1766 return wrap_bit_vector (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1767 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1768
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1769 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1770 make_bit_vector_from_byte_vector (unsigned char *bytevec, Elemcount length)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1771 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1772 Elemcount i;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1773 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1774
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1775 for (i = 0; i < length; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1776 set_bit_vector_bit (p, i, bytevec[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1777
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1778 return wrap_bit_vector (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1779 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1780
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1781 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1782 Return a new bit vector of length LENGTH. with each bit set to BIT.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1783 BIT must be one of the integers 0 or 1. See also the function `bit-vector'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1784 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1785 (length, bit))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1786 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1787 CONCHECK_NATNUM (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1788
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1789 return make_bit_vector (XINT (length), bit);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1790 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1791
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1792 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1793 Return a newly created bit vector with specified arguments as elements.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1794 Any number of arguments, even zero arguments, are allowed.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1795 Each argument must be one of the integers 0 or 1.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1796 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1797 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1798 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1799 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1800 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1801
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1802 for (i = 0; i < nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1803 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1804 CHECK_BIT (args[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1805 set_bit_vector_bit (p, i, !ZEROP (args[i]));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1806 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1807
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1808 return wrap_bit_vector (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1809 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1810
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1811
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1812 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1813 /* Compiled-function allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1814 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1815
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1816 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1817 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1818
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1819 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1820 make_compiled_function (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1821 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1822 Lisp_Compiled_Function *f;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1823
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1824 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (compiled_function, Lisp_Compiled_Function,
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1825 f, &lrecord_compiled_function);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1826
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1827 f->stack_depth = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1828 f->specpdl_depth = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1829 f->flags.documentationp = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1830 f->flags.interactivep = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1831 f->flags.domainp = 0; /* I18N3 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1832 f->instructions = Qzero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1833 f->constants = Qzero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1834 f->arglist = Qnil;
1739
9ddedfc70c4a [xemacs-hg @ 2003-10-10 18:04:23 by james]
james
parents: 1737
diff changeset
1835 f->args = NULL;
9ddedfc70c4a [xemacs-hg @ 2003-10-10 18:04:23 by james]
james
parents: 1737
diff changeset
1836 f->max_args = f->min_args = f->args_in_array = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1837 f->doc_and_interactive = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1838 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1839 f->annotated = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1840 #endif
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1841 return wrap_compiled_function (f);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1842 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1843
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1844 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1845 Return a new compiled-function object.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1846 Usage: (arglist instructions constants stack-depth
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1847 &optional doc-string interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1848 Note that, unlike all other emacs-lisp functions, calling this with five
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1849 arguments is NOT the same as calling it with six arguments, the last of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1850 which is nil. If the INTERACTIVE arg is specified as nil, then that means
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1851 that this function was defined with `(interactive)'. If the arg is not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1852 specified, then that means the function is not interactive.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1853 This is terrible behavior which is retained for compatibility with old
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1854 `.elc' files which expect these semantics.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1855 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1856 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1857 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1858 /* In a non-insane world this function would have this arglist...
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1859 (arglist instructions constants stack_depth &optional doc_string interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1860 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1861 Lisp_Object fun = make_compiled_function ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1862 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1863
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1864 Lisp_Object arglist = args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1865 Lisp_Object instructions = args[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1866 Lisp_Object constants = args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1867 Lisp_Object stack_depth = args[3];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1868 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1869 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1870
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1871 if (nargs < 4 || nargs > 6)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1872 return Fsignal (Qwrong_number_of_arguments,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1873 list2 (intern ("make-byte-code"), make_int (nargs)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1874
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1875 /* Check for valid formal parameter list now, to allow us to use
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1876 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1877 {
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1878 EXTERNAL_LIST_LOOP_2 (symbol, arglist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1879 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1880 CHECK_SYMBOL (symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1881 if (EQ (symbol, Qt) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1882 EQ (symbol, Qnil) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1883 SYMBOL_IS_KEYWORD (symbol))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 551
diff changeset
1884 invalid_constant_2
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1885 ("Invalid constant symbol in formal parameter list",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1886 symbol, arglist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1887 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1888 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1889 f->arglist = arglist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1890
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1891 /* `instructions' is a string or a cons (string . int) for a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1892 lazy-loaded function. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1893 if (CONSP (instructions))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1894 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1895 CHECK_STRING (XCAR (instructions));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1896 CHECK_INT (XCDR (instructions));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1897 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1898 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1899 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1900 CHECK_STRING (instructions);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1901 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1902 f->instructions = instructions;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1903
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1904 if (!NILP (constants))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1905 CHECK_VECTOR (constants);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1906 f->constants = constants;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1907
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1908 CHECK_NATNUM (stack_depth);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1909 f->stack_depth = (unsigned short) XINT (stack_depth);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1910
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1911 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1912 if (!NILP (Vcurrent_compiled_function_annotation))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1913 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1914 else if (!NILP (Vload_file_name_internal_the_purecopy))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1915 f->annotated = Vload_file_name_internal_the_purecopy;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1916 else if (!NILP (Vload_file_name_internal))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1917 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1918 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1919 GCPRO1 (fun); /* don't let fun get reaped */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1920 Vload_file_name_internal_the_purecopy =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1921 Ffile_name_nondirectory (Vload_file_name_internal);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1922 f->annotated = Vload_file_name_internal_the_purecopy;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1923 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1924 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1925 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1926
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1927 /* doc_string may be nil, string, int, or a cons (string . int).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1928 interactive may be list or string (or unbound). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1929 f->doc_and_interactive = Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1930 #ifdef I18N3
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1931 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1932 f->doc_and_interactive = Vfile_domain;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1933 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1934 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1935 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1936 f->doc_and_interactive
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1937 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1938 Fcons (interactive, f->doc_and_interactive));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1939 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1940 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1941 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1942 f->doc_and_interactive
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1943 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1944 Fcons (doc_string, f->doc_and_interactive));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1945 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1946 if (UNBOUNDP (f->doc_and_interactive))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1947 f->doc_and_interactive = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1948
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1949 return fun;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1950 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1951
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1952
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1953 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1954 /* Symbol allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1955 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1956
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1957 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1958 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1959
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1960 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1961 Return a newly allocated uninterned symbol whose name is NAME.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1962 Its value and function definition are void, and its property list is nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1963 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1964 (name))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1965 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1966 Lisp_Symbol *p;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1967
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1968 CHECK_STRING (name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1969
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1970 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (symbol, Lisp_Symbol, p, &lrecord_symbol);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1971 p->name = name;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1972 p->plist = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1973 p->value = Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1974 p->function = Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1975 symbol_next (p) = 0;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1976 return wrap_symbol (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1977 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1978
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1979
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1980 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1981 /* Extent allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1982 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1983
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1984 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1985 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1986
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1987 struct extent *
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1988 allocate_extent (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1989 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1990 struct extent *e;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1991
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
1992 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (extent, struct extent, e, &lrecord_extent);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1993 extent_object (e) = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1994 set_extent_start (e, -1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1995 set_extent_end (e, -1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1996 e->plist = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1997
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1998 xzero (e->flags);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1999
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2000 extent_face (e) = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2001 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2002 e->flags.detachable = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2003
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2004 return e;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2005 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2006
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2007
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2008 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2009 /* Event allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2010 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2011
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2012 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2013 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2014
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2015 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2016 allocate_event (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2017 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2018 Lisp_Event *e;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2019
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2020 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (event, Lisp_Event, e, &lrecord_event);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2021
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2022 return wrap_event (e);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2023 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2024
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2025 #ifdef EVENT_DATA_AS_OBJECTS
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2026 DECLARE_FIXED_TYPE_ALLOC (key_data, Lisp_Key_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2027 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_key_data 1000
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2028
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2029 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2030 make_key_data (void)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2031 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2032 Lisp_Key_Data *d;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2033
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2034 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (key_data, Lisp_Key_Data, d,
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2035 &lrecord_key_data);
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2036 zero_lrecord (d);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2037 d->keysym = Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2038
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2039 return wrap_key_data (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2040 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2041
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2042 DECLARE_FIXED_TYPE_ALLOC (button_data, Lisp_Button_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2043 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_button_data 1000
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2044
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2045 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2046 make_button_data (void)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2047 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2048 Lisp_Button_Data *d;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2049
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2050 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (button_data, Lisp_Button_Data, d, &lrecord_button_data);
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2051 zero_lrecord (d);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2052 return wrap_button_data (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2053 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2054
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2055 DECLARE_FIXED_TYPE_ALLOC (motion_data, Lisp_Motion_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2056 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_motion_data 1000
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2057
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2058 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2059 make_motion_data (void)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2060 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2061 Lisp_Motion_Data *d;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2062
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2063 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (motion_data, Lisp_Motion_Data, d, &lrecord_motion_data);
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2064 zero_lrecord (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2065
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2066 return wrap_motion_data (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2067 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2068
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2069 DECLARE_FIXED_TYPE_ALLOC (process_data, Lisp_Process_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2070 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_process_data 1000
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2071
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2072 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2073 make_process_data (void)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2074 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2075 Lisp_Process_Data *d;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2076
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2077 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (process_data, Lisp_Process_Data, d, &lrecord_process_data);
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2078 zero_lrecord (d);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2079 d->process = Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2080
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2081 return wrap_process_data (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2082 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2083
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2084 DECLARE_FIXED_TYPE_ALLOC (timeout_data, Lisp_Timeout_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2085 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_timeout_data 1000
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2086
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2087 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2088 make_timeout_data (void)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2089 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2090 Lisp_Timeout_Data *d;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2091
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2092 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (timeout_data, Lisp_Timeout_Data, d, &lrecord_timeout_data);
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2093 zero_lrecord (d);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2094 d->function = Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2095 d->object = Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2096
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2097 return wrap_timeout_data (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2098 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2099
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2100 DECLARE_FIXED_TYPE_ALLOC (magic_data, Lisp_Magic_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2101 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_magic_data 1000
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2102
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2103 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2104 make_magic_data (void)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2105 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2106 Lisp_Magic_Data *d;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2107
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2108 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (magic_data, Lisp_Magic_Data, d, &lrecord_magic_data);
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2109 zero_lrecord (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2110
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2111 return wrap_magic_data (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2112 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2113
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2114 DECLARE_FIXED_TYPE_ALLOC (magic_eval_data, Lisp_Magic_Eval_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2115 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_magic_eval_data 1000
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2116
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2117 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2118 make_magic_eval_data (void)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2119 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2120 Lisp_Magic_Eval_Data *d;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2121
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2122 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (magic_eval_data, Lisp_Magic_Eval_Data, d, &lrecord_magic_eval_data);
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2123 zero_lrecord (d);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2124 d->object = Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2125
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2126 return wrap_magic_eval_data (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2127 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2128
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2129 DECLARE_FIXED_TYPE_ALLOC (eval_data, Lisp_Eval_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2130 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_eval_data 1000
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2131
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2132 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2133 make_eval_data (void)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2134 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2135 Lisp_Eval_Data *d;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2136
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2137 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (eval_data, Lisp_Eval_Data, d, &lrecord_eval_data);
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2138 zero_lrecord (d);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2139 d->function = Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2140 d->object = Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2141
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2142 return wrap_eval_data (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2143 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2144
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2145 DECLARE_FIXED_TYPE_ALLOC (misc_user_data, Lisp_Misc_User_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2146 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_misc_user_data 1000
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2147
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2148 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2149 make_misc_user_data (void)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2150 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2151 Lisp_Misc_User_Data *d;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2152
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2153 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (misc_user_data, Lisp_Misc_User_Data, d, &lrecord_misc_user_data);
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2154 zero_lrecord (d);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2155 d->function = Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2156 d->object = Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2157
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2158 return wrap_misc_user_data (d);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2159 }
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2160
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2161 #endif /* EVENT_DATA_AS_OBJECTS */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2162
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2163 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2164 /* Marker allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2165 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2166
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2167 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2168 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2169
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2170 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2171 Return a new marker which does not point at any place.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2172 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2173 ())
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2174 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2175 Lisp_Marker *p;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2176
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2177 ALLOCATE_FIXED_TYPE_AND_SET_IMPL (marker, Lisp_Marker, p, &lrecord_marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2178 p->buffer = 0;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2179 p->membpos = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2180 marker_next (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2181 marker_prev (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2182 p->insertion_type = 0;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2183 return wrap_marker (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2184 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2185
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2186 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2187 noseeum_make_marker (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2188 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2189 Lisp_Marker *p;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2190
3017
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2191 NOSEEUM_ALLOCATE_FIXED_TYPE_AND_SET_IMPL (marker, Lisp_Marker, p,
1e7cc382eb16 [xemacs-hg @ 2005-10-24 10:07:26 by ben]
ben
parents: 2994
diff changeset
2192 &lrecord_marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2193 p->buffer = 0;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2194 p->membpos = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2195 marker_next (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2196 marker_prev (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2197 p->insertion_type = 0;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2198 return wrap_marker (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2199 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2200
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2201
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2202 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2203 /* String allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2204 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2205
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2206 /* The data for "short" strings generally resides inside of structs of type
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2207 string_chars_block. The Lisp_String structure is allocated just like any
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2208 other basic lrecord, and these are freelisted when they get garbage
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2209 collected. The data for short strings get compacted, but the data for
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2210 large strings do not.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2211
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2212 Previously Lisp_String structures were relocated, but this caused a lot
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2213 of bus-errors because the C code didn't include enough GCPRO's for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2214 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2215 that the reference would get relocated).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2216
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2217 This new method makes things somewhat bigger, but it is MUCH safer. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2218
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2219 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2220 /* strings are used and freed quite often */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2221 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2222 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2223
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2224 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2225 mark_string (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2226 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2227 if (CONSP (XSTRING_PLIST (obj)) && EXTENT_INFOP (XCAR (XSTRING_PLIST (obj))))
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2228 flush_cached_extent_info (XCAR (XSTRING_PLIST (obj)));
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2229 return XSTRING_PLIST (obj);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2230 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2231
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2232 static int
2286
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2260
diff changeset
2233 string_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2234 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2235 Bytecount len;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2236 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2237 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2238 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2239
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2240 static const struct memory_description string_description[] = {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2241 { XD_BYTECOUNT, offsetof (Lisp_String, size_) },
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2242 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data_), XD_INDIRECT(0, 1) },
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2243 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2244 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2245 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2246
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2247 /* We store the string's extent info as the first element of the string's
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2248 property list; and the string's MODIFF as the first or second element
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2249 of the string's property list (depending on whether the extent info
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2250 is present), but only if the string has been modified. This is ugly
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2251 but it reduces the memory allocated for the string in the vast
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2252 majority of cases, where the string is never modified and has no
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2253 extent info.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2254
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2255 #### This means you can't use an int as a key in a string's plist. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2256
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2257 static Lisp_Object *
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2258 string_plist_ptr (Lisp_Object string)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2259 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2260 Lisp_Object *ptr = &XSTRING_PLIST (string);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2261
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2262 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2263 ptr = &XCDR (*ptr);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2264 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2265 ptr = &XCDR (*ptr);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2266 return ptr;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2267 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2268
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2269 static Lisp_Object
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2270 string_getprop (Lisp_Object string, Lisp_Object property)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2271 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2272 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2273 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2274
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2275 static int
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2276 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2277 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2278 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2279 return 1;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2280 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2281
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2282 static int
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2283 string_remprop (Lisp_Object string, Lisp_Object property)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2284 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2285 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2286 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2287
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2288 static Lisp_Object
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2289 string_plist (Lisp_Object string)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2290 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2291 return *string_plist_ptr (string);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2292 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2293
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2294 #ifndef MC_ALLOC
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2295 /* No `finalize', or `hash' methods.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2296 internal_hash() already knows how to hash strings and finalization
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2297 is done with the ADDITIONAL_FREE_string macro, which is the
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2298 standard way to do finalization when using
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2299 SWEEP_FIXED_TYPE_BLOCK(). */
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2300
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2301 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2302 1, /*dumpable-flag*/
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2303 mark_string, print_string,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2304 0, string_equal, 0,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2305 string_description,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2306 string_getprop,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2307 string_putprop,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2308 string_remprop,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2309 string_plist,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2310 Lisp_String);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2311 #endif /* not MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2312
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2313 /* String blocks contain this many useful bytes. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2314 #define STRING_CHARS_BLOCK_SIZE \
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2315 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2316 ((2 * sizeof (struct string_chars_block *)) \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2317 + sizeof (EMACS_INT))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2318 /* Block header for small strings. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2319 struct string_chars_block
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2320 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2321 EMACS_INT pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2322 struct string_chars_block *next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2323 struct string_chars_block *prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2324 /* Contents of string_chars_block->string_chars are interleaved
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2325 string_chars structures (see below) and the actual string data */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2326 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2327 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2328
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2329 static struct string_chars_block *first_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2330 static struct string_chars_block *current_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2331
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2332 /* If SIZE is the length of a string, this returns how many bytes
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2333 * the string occupies in string_chars_block->string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2334 * (including alignment padding).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2335 */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2336 #define STRING_FULLSIZE(size) \
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2337 ALIGN_FOR_TYPE (((size) + 1 + sizeof (Lisp_String *)), Lisp_String *)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2338
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2339 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2340 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2341
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2342 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL)
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2343 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL))
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2344
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2345 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2346 static void
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2347 finalize_string (void *header, int for_disksave)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2348 {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2349 if (!for_disksave)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2350 {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2351 Lisp_String *s = (Lisp_String *) header;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2352 Bytecount size = s->size_;
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
2353 #ifdef ALLOC_TYPE_STATS
2775
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
2354 dec_lrecord_string_data_stats (size);
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
2355 #endif /* ALLOC_TYPE_STATS */
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2356 if (BIG_STRING_SIZE_P (size))
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2357 xfree (s->data_, Ibyte *);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2358 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2359 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2360
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2361 DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2362 1, /*dumpable-flag*/
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2363 mark_string, print_string,
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2364 finalize_string,
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2365 string_equal, 0,
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2366 string_description,
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2367 string_getprop,
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2368 string_putprop,
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2369 string_remprop,
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2370 string_plist,
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2371 Lisp_String);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2372
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2373 #endif /* MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2374
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2375 struct string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2376 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2377 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2378 unsigned char chars[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2379 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2380
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2381 struct unused_string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2382 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2383 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2384 EMACS_INT fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2385 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2386
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2387 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2388 init_string_chars_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2389 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2390 first_string_chars_block = xnew (struct string_chars_block);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2391 first_string_chars_block->prev = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2392 first_string_chars_block->next = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2393 first_string_chars_block->pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2394 current_string_chars_block = first_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2395 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2396
1550
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2397 static Ibyte *
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2398 allocate_big_string_chars (Bytecount length)
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2399 {
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2400 Ibyte *p = xnew_array (Ibyte, length);
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2401 INCREMENT_CONS_COUNTER (length, "string chars");
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2402 return p;
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2403 }
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2404
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2405 static struct string_chars *
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2406 allocate_string_chars_struct (Lisp_Object string_it_goes_with,
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2407 Bytecount fullsize)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2408 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2409 struct string_chars *s_chars;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2410
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2411 if (fullsize <=
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2412 (countof (current_string_chars_block->string_chars)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2413 - current_string_chars_block->pos))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2414 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2415 /* This string can fit in the current string chars block */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2416 s_chars = (struct string_chars *)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2417 (current_string_chars_block->string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2418 + current_string_chars_block->pos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2419 current_string_chars_block->pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2420 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2421 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2422 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2423 /* Make a new current string chars block */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2424 struct string_chars_block *new_scb = xnew (struct string_chars_block);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2425
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2426 current_string_chars_block->next = new_scb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2427 new_scb->prev = current_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2428 new_scb->next = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2429 current_string_chars_block = new_scb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2430 new_scb->pos = fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2431 s_chars = (struct string_chars *)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2432 current_string_chars_block->string_chars;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2433 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2434
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2435 s_chars->string = XSTRING (string_it_goes_with);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2436
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2437 INCREMENT_CONS_COUNTER (fullsize, "string chars");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2438
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2439 return s_chars;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2440 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2441
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2442 #ifdef SLEDGEHAMMER_CHECK_ASCII_BEGIN
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2443 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2444 sledgehammer_check_ascii_begin (Lisp_Object str)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2445 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2446 Bytecount i;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2447
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2448 for (i = 0; i < XSTRING_LENGTH (str); i++)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2449 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2450 if (!byte_ascii_p (string_byte (str, i)))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2451 break;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2452 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2453
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2454 assert (i == (Bytecount) XSTRING_ASCII_BEGIN (str) ||
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2455 (i > MAX_STRING_ASCII_BEGIN &&
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2456 (Bytecount) XSTRING_ASCII_BEGIN (str) ==
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2457 (Bytecount) MAX_STRING_ASCII_BEGIN));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2458 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2459 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2460
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2461 /* You do NOT want to be calling this! (And if you do, you must call
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
2462 XSET_STRING_ASCII_BEGIN() after modifying the string.) Use ALLOCA ()
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2463 instead and then call make_string() like the rest of the world. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2464
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2465 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2466 make_uninit_string (Bytecount length)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2467 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2468 Lisp_String *s;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2469 Bytecount fullsize = STRING_FULLSIZE (length);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2470
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2471 assert (length >= 0 && fullsize > 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2472
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2473 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2474 s = alloc_lrecord_type (Lisp_String, &lrecord_string);
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
2475 #ifdef ALLOC_TYPE_STATS
2775
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
2476 inc_lrecord_string_data_stats (length);
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
2477 #endif /* ALLOC_TYPE_STATS */
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2478 #else /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2479 /* Allocate the string header */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2480 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2481 xzero (*s);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2482 set_lheader_implementation (&s->u.lheader, &lrecord_string);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2483 #endif /* not MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2484
3063
d30cd499e445 [xemacs-hg @ 2005-11-13 10:48:01 by ben]
ben
parents: 3024
diff changeset
2485 /* The above allocations set the UID field, which overlaps with the
d30cd499e445 [xemacs-hg @ 2005-11-13 10:48:01 by ben]
ben
parents: 3024
diff changeset
2486 ascii-length field, to some non-zero value. We need to zero it. */
d30cd499e445 [xemacs-hg @ 2005-11-13 10:48:01 by ben]
ben
parents: 3024
diff changeset
2487 XSET_STRING_ASCII_BEGIN (wrap_string (s), 0);
d30cd499e445 [xemacs-hg @ 2005-11-13 10:48:01 by ben]
ben
parents: 3024
diff changeset
2488
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2489 set_lispstringp_data (s, BIG_STRING_FULLSIZE_P (fullsize)
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2490 ? allocate_big_string_chars (length + 1)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2491 : allocate_string_chars_struct (wrap_string (s),
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2492 fullsize)->chars);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2493
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2494 set_lispstringp_length (s, length);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2495 s->plist = Qnil;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2496 set_string_byte (wrap_string (s), length, 0);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2497
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2498 return wrap_string (s);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2499 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2500
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2501 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2502 static void verify_string_chars_integrity (void);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2503 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2504
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2505 /* Resize the string S so that DELTA bytes can be inserted starting
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2506 at POS. If DELTA < 0, it means deletion starting at POS. If
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2507 POS < 0, resize the string but don't copy any characters. Use
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2508 this if you're planning on completely overwriting the string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2509 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2510
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2511 void
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2512 resize_string (Lisp_Object s, Bytecount pos, Bytecount delta)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2513 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2514 Bytecount oldfullsize, newfullsize;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2515 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2516 verify_string_chars_integrity ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2517 #endif
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
2518 #ifdef ERROR_CHECK_TEXT
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2519 if (pos >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2520 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2521 assert (pos <= XSTRING_LENGTH (s));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2522 if (delta < 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2523 assert (pos + (-delta) <= XSTRING_LENGTH (s));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2524 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2525 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2526 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2527 if (delta < 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2528 assert ((-delta) <= XSTRING_LENGTH (s));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2529 }
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
2530 #endif /* ERROR_CHECK_TEXT */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2531
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2532 if (delta == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2533 /* simplest case: no size change. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2534 return;
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2535
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2536 if (pos >= 0 && delta < 0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2537 /* If DELTA < 0, the functions below will delete the characters
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2538 before POS. We want to delete characters *after* POS, however,
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2539 so convert this to the appropriate form. */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2540 pos += -delta;
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2541
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2542 oldfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s));
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2543 newfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s) + delta);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2544
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2545 if (BIG_STRING_FULLSIZE_P (oldfullsize))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2546 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2547 if (BIG_STRING_FULLSIZE_P (newfullsize))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2548 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2549 /* Both strings are big. We can just realloc().
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2550 But careful! If the string is shrinking, we have to
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2551 memmove() _before_ realloc(), and if growing, we have to
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2552 memmove() _after_ realloc() - otherwise the access is
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2553 illegal, and we might crash. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2554 Bytecount len = XSTRING_LENGTH (s) + 1 - pos;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2555
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2556 if (delta < 0 && pos >= 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2557 memmove (XSTRING_DATA (s) + pos + delta,
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2558 XSTRING_DATA (s) + pos, len);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2559 XSET_STRING_DATA
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2560 (s, (Ibyte *) xrealloc (XSTRING_DATA (s),
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2561 XSTRING_LENGTH (s) + delta + 1));
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2562 if (delta > 0 && pos >= 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2563 memmove (XSTRING_DATA (s) + pos + delta, XSTRING_DATA (s) + pos,
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2564 len);
1550
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2565 /* Bump the cons counter.
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2566 Conservative; Martin let the increment be delta. */
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2567 INCREMENT_CONS_COUNTER (newfullsize, "string chars");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2568 }
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2569 else /* String has been demoted from BIG_STRING. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2570 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2571 Ibyte *new_data =
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2572 allocate_string_chars_struct (s, newfullsize)->chars;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2573 Ibyte *old_data = XSTRING_DATA (s);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2574
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2575 if (pos >= 0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2576 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2577 memcpy (new_data, old_data, pos);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2578 memcpy (new_data + pos + delta, old_data + pos,
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2579 XSTRING_LENGTH (s) + 1 - pos);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2580 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2581 XSET_STRING_DATA (s, new_data);
1726
a8d8f419b459 [xemacs-hg @ 2003-09-30 15:26:34 by james]
james
parents: 1676
diff changeset
2582 xfree (old_data, Ibyte *);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2583 }
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2584 }
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2585 else /* old string is small */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2586 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2587 if (oldfullsize == newfullsize)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2588 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2589 /* special case; size change but the necessary
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2590 allocation size won't change (up or down; code
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2591 somewhere depends on there not being any unused
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2592 allocation space, modulo any alignment
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2593 constraints). */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2594 if (pos >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2595 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2596 Ibyte *addroff = pos + XSTRING_DATA (s);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2597
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2598 memmove (addroff + delta, addroff,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2599 /* +1 due to zero-termination. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2600 XSTRING_LENGTH (s) + 1 - pos);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2601 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2602 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2603 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2604 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2605 Ibyte *old_data = XSTRING_DATA (s);
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2606 Ibyte *new_data =
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2607 BIG_STRING_FULLSIZE_P (newfullsize)
1550
6e7ace1ab32d [xemacs-hg @ 2003-06-30 09:38:38 by stephent]
stephent
parents: 1346
diff changeset
2608 ? allocate_big_string_chars (XSTRING_LENGTH (s) + delta + 1)
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2609 : allocate_string_chars_struct (s, newfullsize)->chars;
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2610
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2611 if (pos >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2612 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2613 memcpy (new_data, old_data, pos);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2614 memcpy (new_data + pos + delta, old_data + pos,
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2615 XSTRING_LENGTH (s) + 1 - pos);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2616 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2617 XSET_STRING_DATA (s, new_data);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2618
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2619 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2620 /* We need to mark this chunk of the string_chars_block
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2621 as unused so that compact_string_chars() doesn't
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2622 freak. */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2623 struct string_chars *old_s_chars = (struct string_chars *)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2624 ((char *) old_data - offsetof (struct string_chars, chars));
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2625 /* Sanity check to make sure we aren't hosed by strange
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2626 alignment/padding. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2627 assert (old_s_chars->string == XSTRING (s));
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2628 MARK_STRING_CHARS_AS_FREE (old_s_chars);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2629 ((struct unused_string_chars *) old_s_chars)->fullsize =
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2630 oldfullsize;
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2631 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2632 }
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2633 }
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2634
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2635 XSET_STRING_LENGTH (s, XSTRING_LENGTH (s) + delta);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2636 /* If pos < 0, the string won't be zero-terminated.
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2637 Terminate now just to make sure. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2638 XSTRING_DATA (s)[XSTRING_LENGTH (s)] = '\0';
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2639
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2640 if (pos >= 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2641 /* We also have to adjust all of the extent indices after the
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2642 place we did the change. We say "pos - 1" because
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2643 adjust_extents() is exclusive of the starting position
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2644 passed to it. */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2645 adjust_extents (s, pos - 1, XSTRING_LENGTH (s), delta);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2646
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2647 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2648 verify_string_chars_integrity ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2649 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2650 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2651
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2652 #ifdef MULE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2653
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2654 /* WARNING: If you modify an existing string, you must call
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2655 CHECK_LISP_WRITEABLE() before and bump_string_modiff() afterwards. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2656 void
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2657 set_string_char (Lisp_Object s, Charcount i, Ichar c)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2658 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2659 Ibyte newstr[MAX_ICHAR_LEN];
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2660 Bytecount bytoff = string_index_char_to_byte (s, i);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2661 Bytecount oldlen = itext_ichar_len (XSTRING_DATA (s) + bytoff);
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2662 Bytecount newlen = set_itext_ichar (newstr, c);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2663
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2664 sledgehammer_check_ascii_begin (s);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2665 if (oldlen != newlen)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2666 resize_string (s, bytoff, newlen - oldlen);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2667 /* Remember, XSTRING_DATA (s) might have changed so we can't cache it. */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2668 memcpy (XSTRING_DATA (s) + bytoff, newstr, newlen);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2669 if (oldlen != newlen)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2670 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2671 if (newlen > 1 && i <= (Charcount) XSTRING_ASCII_BEGIN (s))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2672 /* Everything starting with the new char is no longer part of
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2673 ascii_begin */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2674 XSET_STRING_ASCII_BEGIN (s, i);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2675 else if (newlen == 1 && i == (Charcount) XSTRING_ASCII_BEGIN (s))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2676 /* We've extended ascii_begin, and we have to figure out how much by */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2677 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2678 Bytecount j;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2679 for (j = (Bytecount) i + 1; j < XSTRING_LENGTH (s); j++)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2680 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2681 if (!byte_ascii_p (XSTRING_DATA (s)[j]))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2682 break;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2683 }
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2684 XSET_STRING_ASCII_BEGIN (s, min (j, (Bytecount) MAX_STRING_ASCII_BEGIN));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2685 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2686 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2687 sledgehammer_check_ascii_begin (s);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2688 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2689
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2690 #endif /* MULE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2691
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2692 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2693 Return a new string consisting of LENGTH copies of CHARACTER.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2694 LENGTH must be a non-negative integer.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2695 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2696 (length, character))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2697 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2698 CHECK_NATNUM (length);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2699 CHECK_CHAR_COERCE_INT (character);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2700 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2701 Ibyte init_str[MAX_ICHAR_LEN];
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2702 int len = set_itext_ichar (init_str, XCHAR (character));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2703 Lisp_Object val = make_uninit_string (len * XINT (length));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2704
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2705 if (len == 1)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2706 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2707 /* Optimize the single-byte case */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2708 memset (XSTRING_DATA (val), XCHAR (character), XSTRING_LENGTH (val));
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2709 XSET_STRING_ASCII_BEGIN (val, min (MAX_STRING_ASCII_BEGIN,
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2710 len * XINT (length)));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2711 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2712 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2713 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
2714 EMACS_INT i;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2715 Ibyte *ptr = XSTRING_DATA (val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2716
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2717 for (i = XINT (length); i; i--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2718 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2719 Ibyte *init_ptr = init_str;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2720 switch (len)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2721 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2722 case 4: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2723 case 3: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2724 case 2: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2725 case 1: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2726 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2727 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2728 }
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2729 sledgehammer_check_ascii_begin (val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2730 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2731 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2732 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2733
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2734 DEFUN ("string", Fstring, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2735 Concatenate all the argument characters and make the result a string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2736 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2737 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2738 {
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
2739 Ibyte *storage = alloca_ibytes (nargs * MAX_ICHAR_LEN);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2740 Ibyte *p = storage;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2741
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2742 for (; nargs; nargs--, args++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2743 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2744 Lisp_Object lisp_char = *args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2745 CHECK_CHAR_COERCE_INT (lisp_char);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2746 p += set_itext_ichar (p, XCHAR (lisp_char));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2747 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2748 return make_string (storage, p - storage);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2749 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2750
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2751 /* Initialize the ascii_begin member of a string to the correct value. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2752
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2753 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2754 init_string_ascii_begin (Lisp_Object string)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2755 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2756 #ifdef MULE
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2757 int i;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2758 Bytecount length = XSTRING_LENGTH (string);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2759 Ibyte *contents = XSTRING_DATA (string);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2760
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2761 for (i = 0; i < length; i++)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2762 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2763 if (!byte_ascii_p (contents[i]))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2764 break;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2765 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2766 XSET_STRING_ASCII_BEGIN (string, min (i, MAX_STRING_ASCII_BEGIN));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2767 #else
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2768 XSET_STRING_ASCII_BEGIN (string, min (XSTRING_LENGTH (string),
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2769 MAX_STRING_ASCII_BEGIN));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2770 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2771 sledgehammer_check_ascii_begin (string);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2772 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2773
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2774 /* Take some raw memory, which MUST already be in internal format,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2775 and package it up into a Lisp string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2776 Lisp_Object
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2777 make_string (const Ibyte *contents, Bytecount length)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2778 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2779 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2780
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2781 /* Make sure we find out about bad make_string's when they happen */
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
2782 #if defined (ERROR_CHECK_TEXT) && defined (MULE)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2783 bytecount_to_charcount (contents, length); /* Just for the assertions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2784 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2785
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2786 val = make_uninit_string (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2787 memcpy (XSTRING_DATA (val), contents, length);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2788 init_string_ascii_begin (val);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2789 sledgehammer_check_ascii_begin (val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2790 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2791 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2792
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2793 /* Take some raw memory, encoded in some external data format,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2794 and convert it into a Lisp string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2795 Lisp_Object
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2796 make_ext_string (const Extbyte *contents, EMACS_INT length,
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2797 Lisp_Object coding_system)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2798 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2799 Lisp_Object string;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2800 TO_INTERNAL_FORMAT (DATA, (contents, length),
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2801 LISP_STRING, string,
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2802 coding_system);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2803 return string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2804 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2805
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2806 Lisp_Object
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2807 build_intstring (const Ibyte *str)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2808 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2809 /* Some strlen's crash and burn if passed null. */
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2810 return make_string (str, (str ? qxestrlen (str) : (Bytecount) 0));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2811 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2812
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2813 Lisp_Object
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2814 build_string (const CIbyte *str)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2815 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2816 /* Some strlen's crash and burn if passed null. */
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2817 return make_string ((const Ibyte *) str, (str ? strlen (str) : 0));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2818 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2819
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2820 Lisp_Object
593
5fd7ba8b56e7 [xemacs-hg @ 2001-05-31 12:45:27 by ben]
ben
parents: 578
diff changeset
2821 build_ext_string (const Extbyte *str, Lisp_Object coding_system)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2822 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2823 /* Some strlen's crash and burn if passed null. */
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
2824 return make_ext_string ((const Extbyte *) str,
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
2825 (str ? dfc_external_data_len (str, coding_system) :
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
2826 0),
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2827 coding_system);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2828 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2829
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2830 Lisp_Object
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2831 build_msg_intstring (const Ibyte *str)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2832 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2833 return build_intstring (GETTEXT (str));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2834 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2835
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2836 Lisp_Object
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2837 build_msg_string (const CIbyte *str)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2838 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2839 return build_string (CGETTEXT (str));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2840 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2841
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2842 Lisp_Object
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2843 make_string_nocopy (const Ibyte *contents, Bytecount length)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2844 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2845 Lisp_String *s;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2846 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2847
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2848 /* Make sure we find out about bad make_string_nocopy's when they happen */
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
2849 #if defined (ERROR_CHECK_TEXT) && defined (MULE)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2850 bytecount_to_charcount (contents, length); /* Just for the assertions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2851 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2852
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2853 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2854 s = alloc_lrecord_type (Lisp_String, &lrecord_string);
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
2855 #ifdef ALLOC_TYPE_STATS
2775
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
2856 inc_lrecord_string_data_stats (length);
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
2857 #endif /* ALLOC_TYPE_STATS */
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2858 mcpro (wrap_pointer_1 (s)); /* otherwise nocopy_strings get
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2859 collected and static data is tried to
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2860 be freed. */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2861 #else /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2862 /* Allocate the string header */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2863 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2864 set_lheader_implementation (&s->u.lheader, &lrecord_string);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2865 SET_C_READONLY_RECORD_HEADER (&s->u.lheader);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2866 #endif /* not MC_ALLOC */
3063
d30cd499e445 [xemacs-hg @ 2005-11-13 10:48:01 by ben]
ben
parents: 3024
diff changeset
2867 /* Don't need to XSET_STRING_ASCII_BEGIN() here because it happens in
d30cd499e445 [xemacs-hg @ 2005-11-13 10:48:01 by ben]
ben
parents: 3024
diff changeset
2868 init_string_ascii_begin(). */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2869 s->plist = Qnil;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2870 set_lispstringp_data (s, (Ibyte *) contents);
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2871 set_lispstringp_length (s, length);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2872 val = wrap_string (s);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2873 init_string_ascii_begin (val);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2874 sledgehammer_check_ascii_begin (val);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2875
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2876 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2877 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2878
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2879
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
2880 #ifndef MC_ALLOC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2881 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2882 /* lcrecord lists */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2883 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2884
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2885 /* Lcrecord lists are used to manage the allocation of particular
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
2886 sorts of lcrecords, to avoid calling BASIC_ALLOC_LCRECORD() (and thus
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2887 malloc() and garbage-collection junk) as much as possible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2888 It is similar to the Blocktype class.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2889
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2890 See detailed comment in lcrecord.h.
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2891 */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2892
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2893 const struct memory_description free_description[] = {
2551
9f70af3ac939 [xemacs-hg @ 2005-02-03 16:14:02 by james]
james
parents: 2532
diff changeset
2894 { XD_LISP_OBJECT, offsetof (struct free_lcrecord_header, chain), 0, { 0 },
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2895 XD_FLAG_FREE_LISP_OBJECT },
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2896 { XD_END }
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2897 };
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2898
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2899 DEFINE_LRECORD_IMPLEMENTATION ("free", free,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2900 0, /*dumpable-flag*/
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2901 0, internal_object_printer,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2902 0, 0, 0, free_description,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2903 struct free_lcrecord_header);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2904
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2905 const struct memory_description lcrecord_list_description[] = {
2551
9f70af3ac939 [xemacs-hg @ 2005-02-03 16:14:02 by james]
james
parents: 2532
diff changeset
2906 { XD_LISP_OBJECT, offsetof (struct lcrecord_list, free), 0, { 0 },
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2907 XD_FLAG_FREE_LISP_OBJECT },
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2908 { XD_END }
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2909 };
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2910
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2911 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2912 mark_lcrecord_list (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2913 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2914 struct lcrecord_list *list = XLCRECORD_LIST (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2915 Lisp_Object chain = list->free;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2916
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2917 while (!NILP (chain))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2918 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2919 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2920 struct free_lcrecord_header *free_header =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2921 (struct free_lcrecord_header *) lheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2922
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2923 gc_checking_assert
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2924 (/* There should be no other pointers to the free list. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2925 ! MARKED_RECORD_HEADER_P (lheader)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2926 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2927 /* Only lcrecords should be here. */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2928 ! list->implementation->basic_p
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2929 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2930 /* Only free lcrecords should be here. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2931 free_header->lcheader.free
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2932 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2933 /* The type of the lcrecord must be right. */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2934 lheader->type == lrecord_type_free
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2935 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2936 /* So must the size. */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2937 (list->implementation->static_size == 0 ||
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2938 list->implementation->static_size == list->size)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2939 );
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2940
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2941 MARK_RECORD_HEADER (lheader);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2942 chain = free_header->chain;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2943 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2944
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2945 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2946 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2947
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2948 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2949 0, /*dumpable-flag*/
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2950 mark_lcrecord_list, internal_object_printer,
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2951 0, 0, 0, lcrecord_list_description,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2952 struct lcrecord_list);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
2953
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2954 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2955 make_lcrecord_list (Elemcount size,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2956 const struct lrecord_implementation *implementation)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2957 {
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
2958 /* Don't use old_alloc_lcrecord_type() avoid infinite recursion
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2959 allocating this, */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2960 struct lcrecord_list *p = (struct lcrecord_list *)
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
2961 old_basic_alloc_lcrecord (sizeof (struct lcrecord_list),
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
2962 &lrecord_lcrecord_list);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2963
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2964 p->implementation = implementation;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2965 p->size = size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2966 p->free = Qnil;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2967 return wrap_lcrecord_list (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2968 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2969
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2970 Lisp_Object
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2971 alloc_managed_lcrecord (Lisp_Object lcrecord_list)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2972 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2973 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2974 if (!NILP (list->free))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2975 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2976 Lisp_Object val = list->free;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2977 struct free_lcrecord_header *free_header =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2978 (struct free_lcrecord_header *) XPNTR (val);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2979 struct lrecord_header *lheader = &free_header->lcheader.lheader;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2980
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2981 #ifdef ERROR_CHECK_GC
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2982 /* Major overkill here. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2983 /* There should be no other pointers to the free list. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2984 assert (! MARKED_RECORD_HEADER_P (lheader));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2985 /* Only free lcrecords should be here. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2986 assert (free_header->lcheader.free);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2987 assert (lheader->type == lrecord_type_free);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2988 /* Only lcrecords should be here. */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2989 assert (! (list->implementation->basic_p));
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2990 #if 0 /* Not used anymore, now that we set the type of the header to
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2991 lrecord_type_free. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2992 /* The type of the lcrecord must be right. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2993 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2994 #endif /* 0 */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2995 /* So must the size. */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2996 assert (list->implementation->static_size == 0 ||
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
2997 list->implementation->static_size == list->size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2998 #endif /* ERROR_CHECK_GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2999
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3000 list->free = free_header->chain;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3001 free_header->lcheader.free = 0;
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3002 /* Put back the correct type, as we set it to lrecord_type_free. */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3003 lheader->type = list->implementation->lrecord_type_index;
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
3004 old_zero_sized_lcrecord (free_header, list->size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3005 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3006 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3007 else
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
3008 return wrap_pointer_1 (old_basic_alloc_lcrecord (list->size,
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
3009 list->implementation));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3010 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3011
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3012 /* "Free" a Lisp object LCRECORD by placing it on its associated free list
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3013 LCRECORD_LIST; next time alloc_managed_lcrecord() is called with the
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3014 same LCRECORD_LIST as its parameter, it will return an object from the
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3015 free list, which may be this one. Be VERY VERY SURE there are no
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3016 pointers to this object hanging around anywhere where they might be
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3017 used!
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3018
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3019 The first thing this does before making any global state change is to
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3020 call the finalize method of the object, if it exists. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3021
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3022 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3023 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3024 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3025 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3026 struct free_lcrecord_header *free_header =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3027 (struct free_lcrecord_header *) XPNTR (lcrecord);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3028 struct lrecord_header *lheader = &free_header->lcheader.lheader;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3029 const struct lrecord_implementation *implementation
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3030 = LHEADER_IMPLEMENTATION (lheader);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3031
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3032 /* Finalizer methods may try to free objects within them, which typically
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3033 won't be marked and thus are scheduled for demolition. Putting them
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3034 on the free list would be very bad, as we'd have xfree()d memory in
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3035 the list. Even if for some reason the objects are still live
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3036 (generally a logic error!), we still will have problems putting such
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3037 an object on the free list right now (e.g. we'd have to avoid calling
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3038 the finalizer twice, etc.). So basically, those finalizers should not
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3039 be freeing any objects if during GC. Abort now to catch those
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3040 problems. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3041 gc_checking_assert (!gc_in_progress);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3042
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3043 /* Make sure the size is correct. This will catch, for example,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3044 putting a window configuration on the wrong free list. */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3045 gc_checking_assert (detagged_lisp_object_size (lheader) == list->size);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3046 /* Make sure the object isn't already freed. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3047 gc_checking_assert (!free_header->lcheader.free);
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3048 /* Freeing stuff in dumped memory is bad. If you trip this, you
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3049 may need to check for this before freeing. */
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3050 gc_checking_assert (!OBJECT_DUMPED_P (lcrecord));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3051
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3052 if (implementation->finalizer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3053 implementation->finalizer (lheader, 0);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3054 /* Yes, there are two ways to indicate freeness -- the type is
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3055 lrecord_type_free or the ->free flag is set. We used to do only the
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3056 latter; now we do the former as well for KKCC purposes. Probably
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3057 safer in any case, as we will lose quicker this way than keeping
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3058 around an lrecord of apparently correct type but bogus junk in it. */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3059 MARK_LRECORD_AS_FREE (lheader);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3060 free_header->chain = list->free;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3061 free_header->lcheader.free = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3062 list->free = lcrecord;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3063 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3064
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3065 static Lisp_Object all_lcrecord_lists[countof (lrecord_implementations_table)];
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3066
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3067 void *
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3068 alloc_automanaged_lcrecord (Bytecount size,
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3069 const struct lrecord_implementation *imp)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3070 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3071 if (EQ (all_lcrecord_lists[imp->lrecord_type_index], Qzero))
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3072 all_lcrecord_lists[imp->lrecord_type_index] =
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3073 make_lcrecord_list (size, imp);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3074
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3075 return XPNTR (alloc_managed_lcrecord
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3076 (all_lcrecord_lists[imp->lrecord_type_index]));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3077 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3078
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3079 void
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
3080 old_free_lcrecord (Lisp_Object rec)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3081 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3082 int type = XRECORD_LHEADER (rec)->type;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3083
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3084 assert (!EQ (all_lcrecord_lists[type], Qzero));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3085
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3086 free_managed_lcrecord (all_lcrecord_lists[type], rec);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3087 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3088 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3089
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3090
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3091 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3092 Kept for compatibility, returns its argument.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3093 Old:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3094 Make a copy of OBJECT in pure storage.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3095 Recursively copies contents of vectors and cons cells.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3096 Does not copy symbols.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3097 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3098 (object))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3099 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3100 return object;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3101 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3102
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3103
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3104 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3105 /* Garbage Collection */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3106 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3107
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3108 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3109 Additional ones may be defined by a module (none yet). We leave some
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3110 room in `lrecord_implementations_table' for such new lisp object types. */
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
3111 const struct lrecord_implementation *lrecord_implementations_table[(int)lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT];
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
3112 int lrecord_type_count = lrecord_type_last_built_in_type;
1676
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3113 #ifndef USE_KKCC
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3114 /* Object marker functions are in the lrecord_implementation structure.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3115 But copying them to a parallel array is much more cache-friendly.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3116 This hack speeds up (garbage-collect) by about 5%. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3117 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
1676
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3118 #endif /* not USE_KKCC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3119
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3120 struct gcpro *gcprolist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3121
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3122 /* We want the staticpro list relocated, but not the pointers found
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3123 therein, because they refer to locations in the global data segment, not
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3124 in the heap; we only dump heap objects. Hence we use a trivial
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3125 description, as for pointerless objects. (Note that the data segment
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3126 objects, which are global variables like Qfoo or Vbar, themselves are
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3127 pointers to heap objects. Each needs to be described to pdump as a
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3128 "root pointer"; this happens in the call to staticpro(). */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3129 static const struct memory_description staticpro_description_1[] = {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3130 { XD_END }
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3131 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3132
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3133 static const struct sized_memory_description staticpro_description = {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3134 sizeof (Lisp_Object *),
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3135 staticpro_description_1
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3136 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3137
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3138 static const struct memory_description staticpros_description_1[] = {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3139 XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description),
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3140 { XD_END }
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3141 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3142
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3143 static const struct sized_memory_description staticpros_description = {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3144 sizeof (Lisp_Object_ptr_dynarr),
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3145 staticpros_description_1
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3146 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3147
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3148 #ifdef DEBUG_XEMACS
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3149
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3150 static const struct memory_description staticpro_one_name_description_1[] = {
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3151 { XD_ASCII_STRING, 0 },
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3152 { XD_END }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3153 };
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3154
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3155 static const struct sized_memory_description staticpro_one_name_description = {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3156 sizeof (char *),
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3157 staticpro_one_name_description_1
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3158 };
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3159
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3160 static const struct memory_description staticpro_names_description_1[] = {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3161 XD_DYNARR_DESC (char_ptr_dynarr, &staticpro_one_name_description),
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3162 { XD_END }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3163 };
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3164
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3165
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3166 extern const struct sized_memory_description staticpro_names_description;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3167
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3168 const struct sized_memory_description staticpro_names_description = {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3169 sizeof (char_ptr_dynarr),
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3170 staticpro_names_description_1
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3171 };
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3172
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3173 /* Help debug crashes gc-marking a staticpro'ed object. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3174
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3175 Lisp_Object_ptr_dynarr *staticpros;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3176 char_ptr_dynarr *staticpro_names;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3177
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3178 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3179 garbage collection, and for dumping. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3180 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3181 staticpro_1 (Lisp_Object *varaddress, char *varname)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3182 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3183 Dynarr_add (staticpros, varaddress);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3184 Dynarr_add (staticpro_names, varname);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3185 dump_add_root_lisp_object (varaddress);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3186 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3187
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3188
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3189 Lisp_Object_ptr_dynarr *staticpros_nodump;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3190 char_ptr_dynarr *staticpro_nodump_names;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3191
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3192 /* Mark the Lisp_Object at heap VARADDRESS as a root object for
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3193 garbage collection, but not for dumping. (See below.) */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3194 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3195 staticpro_nodump_1 (Lisp_Object *varaddress, char *varname)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3196 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3197 Dynarr_add (staticpros_nodump, varaddress);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3198 Dynarr_add (staticpro_nodump_names, varname);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3199 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3200
996
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3201 #ifdef HAVE_SHLIB
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3202 /* Stop treating the Lisp_Object at non-heap VARADDRESS as a root object
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3203 for garbage collection, but not for dumping. */
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3204 void
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3205 unstaticpro_nodump_1 (Lisp_Object *varaddress, char *varname)
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3206 {
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3207 Dynarr_delete_object (staticpros, varaddress);
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3208 Dynarr_delete_object (staticpro_names, varname);
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3209 }
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3210 #endif
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3211
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3212 #else /* not DEBUG_XEMACS */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3213
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3214 Lisp_Object_ptr_dynarr *staticpros;
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3215
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3216 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3217 garbage collection, and for dumping. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3218 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3219 staticpro (Lisp_Object *varaddress)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3220 {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3221 Dynarr_add (staticpros, varaddress);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3222 dump_add_root_lisp_object (varaddress);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3223 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3224
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3225
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3226 Lisp_Object_ptr_dynarr *staticpros_nodump;
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3227
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3228 /* Mark the Lisp_Object at heap VARADDRESS as a root object for garbage
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3229 collection, but not for dumping. This is used for objects where the
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3230 only sure pointer is in the heap (rather than in the global data
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3231 segment, as must be the case for pdump root pointers), but not inside of
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3232 another Lisp object (where it will be marked as a result of that Lisp
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3233 object's mark method). The call to staticpro_nodump() must occur *BOTH*
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3234 at initialization time and at "reinitialization" time (startup, after
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3235 pdump load.) (For example, this is the case with the predicate symbols
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3236 for specifier and coding system types. The pointer to this symbol is
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3237 inside of a methods structure, which is allocated on the heap. The
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3238 methods structure will be written out to the pdump data file, and may be
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3239 reloaded at a different address.)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3240
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3241 #### The necessity for reinitialization is a bug in pdump. Pdump should
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3242 automatically regenerate the staticpro()s for these symbols when it
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3243 loads the data in. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3244
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3245 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3246 staticpro_nodump (Lisp_Object *varaddress)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3247 {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3248 Dynarr_add (staticpros_nodump, varaddress);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3249 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3250
996
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3251 #ifdef HAVE_SHLIB
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3252 /* Unmark the Lisp_Object at non-heap VARADDRESS as a root object for
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3253 garbage collection, but not for dumping. */
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3254 void
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3255 unstaticpro_nodump (Lisp_Object *varaddress)
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3256 {
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3257 Dynarr_delete_object (staticpros, varaddress);
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3258 }
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3259 #endif
25e260cb7994 [xemacs-hg @ 2002-09-10 15:27:02 by james]
james
parents: 945
diff changeset
3260
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3261 #endif /* not DEBUG_XEMACS */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3262
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3263
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3264
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3265
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3266
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3267 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3268 static const struct memory_description mcpro_description_1[] = {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3269 { XD_END }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3270 };
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3271
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3272 static const struct sized_memory_description mcpro_description = {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3273 sizeof (Lisp_Object *),
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3274 mcpro_description_1
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3275 };
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3276
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3277 static const struct memory_description mcpros_description_1[] = {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3278 XD_DYNARR_DESC (Lisp_Object_dynarr, &mcpro_description),
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3279 { XD_END }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3280 };
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3281
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3282 static const struct sized_memory_description mcpros_description = {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3283 sizeof (Lisp_Object_dynarr),
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3284 mcpros_description_1
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3285 };
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3286
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3287 #ifdef DEBUG_XEMACS
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3288
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3289 static const struct memory_description mcpro_one_name_description_1[] = {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3290 { XD_ASCII_STRING, 0 },
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3291 { XD_END }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3292 };
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3293
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3294 static const struct sized_memory_description mcpro_one_name_description = {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3295 sizeof (char *),
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3296 mcpro_one_name_description_1
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3297 };
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3298
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3299 static const struct memory_description mcpro_names_description_1[] = {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3300 XD_DYNARR_DESC (char_ptr_dynarr, &mcpro_one_name_description),
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3301 { XD_END }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3302 };
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3303
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3304 extern const struct sized_memory_description mcpro_names_description;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3305
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3306 const struct sized_memory_description mcpro_names_description = {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3307 sizeof (char_ptr_dynarr),
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3308 mcpro_names_description_1
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3309 };
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3310
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3311 /* Help debug crashes gc-marking a mcpro'ed object. */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3312
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3313 Lisp_Object_dynarr *mcpros;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3314 char_ptr_dynarr *mcpro_names;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3315
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3316 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3317 garbage collection, and for dumping. */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3318 void
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3319 mcpro_1 (Lisp_Object varaddress, char *varname)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3320 {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3321 Dynarr_add (mcpros, varaddress);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3322 Dynarr_add (mcpro_names, varname);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3323 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3324
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3325 #else /* not DEBUG_XEMACS */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3326
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3327 Lisp_Object_dynarr *mcpros;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3328
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3329 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3330 garbage collection, and for dumping. */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3331 void
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3332 mcpro (Lisp_Object varaddress)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3333 {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3334 Dynarr_add (mcpros, varaddress);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3335 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3336
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3337 #endif /* not DEBUG_XEMACS */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3338 #endif /* MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3339
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3340 #ifdef ERROR_CHECK_GC
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3341 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3342 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3343 struct lrecord_header * GCLI_lh = (lheader); \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3344 assert (GCLI_lh != 0); \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3345 assert (GCLI_lh->type < (unsigned int) lrecord_type_count); \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3346 } while (0)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3347 #else /* not MC_ALLOC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3348 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3349 struct lrecord_header * GCLI_lh = (lheader); \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3350 assert (GCLI_lh != 0); \
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
3351 assert (GCLI_lh->type < (unsigned int) lrecord_type_count); \
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3352 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3353 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3354 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3355 } while (0)
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3356 #endif /* not MC_ALLOC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3357 #else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3358 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3359 #endif
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3360
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3361
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3362 static const struct memory_description lisp_object_description_1[] = {
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3363 { XD_LISP_OBJECT, 0 },
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3364 { XD_END }
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3365 };
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3366
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3367 const struct sized_memory_description lisp_object_description = {
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3368 sizeof (Lisp_Object),
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3369 lisp_object_description_1
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3370 };
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3371
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3372 #if defined (USE_KKCC) || defined (PDUMP)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3373
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3374 /* This function extracts the value of a count variable described somewhere
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3375 else in the description. It is converted corresponding to the type */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3376 EMACS_INT
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3377 lispdesc_indirect_count_1 (EMACS_INT code,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3378 const struct memory_description *idesc,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3379 const void *idata)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3380 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3381 EMACS_INT count;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3382 const void *irdata;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3383
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3384 int line = XD_INDIRECT_VAL (code);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3385 int delta = XD_INDIRECT_DELTA (code);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3386
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3387 irdata = ((char *) idata) +
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3388 lispdesc_indirect_count (idesc[line].offset, idesc, idata);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3389 switch (idesc[line].type)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3390 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3391 case XD_BYTECOUNT:
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3392 count = * (Bytecount *) irdata;
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3393 break;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3394 case XD_ELEMCOUNT:
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3395 count = * (Elemcount *) irdata;
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3396 break;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3397 case XD_HASHCODE:
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3398 count = * (Hashcode *) irdata;
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3399 break;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3400 case XD_INT:
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3401 count = * (int *) irdata;
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3402 break;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3403 case XD_LONG:
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3404 count = * (long *) irdata;
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3405 break;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3406 default:
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3407 stderr_out ("Unsupported count type : %d (line = %d, code = %ld)\n",
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3408 idesc[line].type, line, (long) code);
2666
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3409 #if defined(USE_KKCC) && defined(DEBUG_XEMACS)
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3410 if (gc_in_progress)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3411 kkcc_backtrace ();
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3412 #endif
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3413 #ifdef PDUMP
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3414 if (in_pdump)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3415 pdump_backtrace ();
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3416 #endif
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3417 count = 0; /* warning suppression */
2500
3d8143fc88e1 [xemacs-hg @ 2005-01-24 23:33:30 by ben]
ben
parents: 2367
diff changeset
3418 ABORT ();
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3419 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3420 count += delta;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3421 return count;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3422 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3423
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3424 /* SDESC is a "description map" (basically, a list of offsets used for
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3425 successive indirections) and OBJ is the first object to indirect off of.
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3426 Return the description ultimately found. */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3427
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3428 const struct sized_memory_description *
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3429 lispdesc_indirect_description_1 (const void *obj,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3430 const struct sized_memory_description *sdesc)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3431 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3432 int pos;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3433
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3434 for (pos = 0; sdesc[pos].size >= 0; pos++)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3435 obj = * (const void **) ((const char *) obj + sdesc[pos].size);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3436
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3437 return (const struct sized_memory_description *) obj;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3438 }
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3439
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3440 /* Compute the size of the data at RDATA, described by a single entry
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3441 DESC1 in a description array. OBJ and DESC are used for
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3442 XD_INDIRECT references. */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3443
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3444 static Bytecount
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3445 lispdesc_one_description_line_size (void *rdata,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3446 const struct memory_description *desc1,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3447 const void *obj,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3448 const struct memory_description *desc)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3449 {
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3450 union_switcheroo:
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3451 switch (desc1->type)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3452 {
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3453 case XD_LISP_OBJECT_ARRAY:
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3454 {
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3455 EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3456 return (val * sizeof (Lisp_Object));
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3457 }
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3458 case XD_LISP_OBJECT:
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3459 case XD_LO_LINK:
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3460 return sizeof (Lisp_Object);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3461 case XD_OPAQUE_PTR:
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3462 return sizeof (void *);
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3463 case XD_BLOCK_PTR:
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3464 {
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3465 EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3466 return val * sizeof (void *);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3467 }
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3468 case XD_BLOCK_ARRAY:
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3469 {
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3470 EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3471
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3472 return (val *
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3473 lispdesc_block_size
2551
9f70af3ac939 [xemacs-hg @ 2005-02-03 16:14:02 by james]
james
parents: 2532
diff changeset
3474 (rdata,
9f70af3ac939 [xemacs-hg @ 2005-02-03 16:14:02 by james]
james
parents: 2532
diff changeset
3475 lispdesc_indirect_description (obj, desc1->data2.descr)));
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3476 }
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3477 case XD_OPAQUE_DATA_PTR:
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3478 return sizeof (void *);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3479 case XD_UNION_DYNAMIC_SIZE:
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3480 {
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3481 /* If an explicit size was given in the first-level structure
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3482 description, use it; else compute size based on current union
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3483 constant. */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3484 const struct sized_memory_description *sdesc =
2551
9f70af3ac939 [xemacs-hg @ 2005-02-03 16:14:02 by james]
james
parents: 2532
diff changeset
3485 lispdesc_indirect_description (obj, desc1->data2.descr);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3486 if (sdesc->size)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3487 return sdesc->size;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3488 else
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3489 {
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3490 desc1 = lispdesc_process_xd_union (desc1, desc, obj);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3491 if (desc1)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3492 goto union_switcheroo;
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3493 break;
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3494 }
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3495 }
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3496 case XD_UNION:
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3497 {
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3498 /* If an explicit size was given in the first-level structure
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3499 description, use it; else compute size based on maximum of all
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3500 possible structures. */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3501 const struct sized_memory_description *sdesc =
2551
9f70af3ac939 [xemacs-hg @ 2005-02-03 16:14:02 by james]
james
parents: 2532
diff changeset
3502 lispdesc_indirect_description (obj, desc1->data2.descr);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3503 if (sdesc->size)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3504 return sdesc->size;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3505 else
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3506 {
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3507 int count;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3508 Bytecount max_size = -1, size;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3509
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3510 desc1 = sdesc->description;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3511
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3512 for (count = 0; desc1[count].type != XD_END; count++)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3513 {
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3514 size = lispdesc_one_description_line_size (rdata,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3515 &desc1[count],
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3516 obj, desc);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3517 if (size > max_size)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3518 max_size = size;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3519 }
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3520 return max_size;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3521 }
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3522 }
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3523 case XD_ASCII_STRING:
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3524 return sizeof (void *);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3525 case XD_DOC_STRING:
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3526 return sizeof (void *);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3527 case XD_INT_RESET:
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3528 return sizeof (int);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3529 case XD_BYTECOUNT:
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3530 return sizeof (Bytecount);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3531 case XD_ELEMCOUNT:
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3532 return sizeof (Elemcount);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3533 case XD_HASHCODE:
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3534 return sizeof (Hashcode);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3535 case XD_INT:
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3536 return sizeof (int);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3537 case XD_LONG:
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3538 return sizeof (long);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3539 default:
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3540 stderr_out ("Unsupported dump type : %d\n", desc1->type);
2500
3d8143fc88e1 [xemacs-hg @ 2005-01-24 23:33:30 by ben]
ben
parents: 2367
diff changeset
3541 ABORT ();
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3542 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3543
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3544 return 0;
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3545 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3546
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3547
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3548 /* Return the size of the memory block (NOT necessarily a structure!)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3549 described by SDESC and pointed to by OBJ. If SDESC records an
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3550 explicit size (i.e. non-zero), it is simply returned; otherwise,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3551 the size is calculated by the maximum offset and the size of the
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3552 object at that offset, rounded up to the maximum alignment. In
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3553 this case, we may need the object, for example when retrieving an
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3554 "indirect count" of an inlined array (the count is not constant,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3555 but is specified by one of the elements of the memory block). (It
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3556 is generally not a problem if we return an overly large size -- we
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3557 will simply end up reserving more space than necessary; but if the
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3558 size is too small we could be in serious trouble, in particular
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3559 with nested inlined structures, where there may be alignment
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3560 padding in the middle of a block. #### In fact there is an (at
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3561 least theoretical) problem with an overly large size -- we may
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3562 trigger a protection fault when reading from invalid memory. We
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3563 need to handle this -- perhaps in a stupid but dependable way,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3564 i.e. by trapping SIGSEGV and SIGBUS.) */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3565
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3566 Bytecount
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3567 lispdesc_block_size_1 (const void *obj, Bytecount size,
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3568 const struct memory_description *desc)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3569 {
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3570 EMACS_INT max_offset = -1;
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3571 int max_offset_pos = -1;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3572 int pos;
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3573
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3574 if (size)
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3575 return size;
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3576
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3577 for (pos = 0; desc[pos].type != XD_END; pos++)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3578 {
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3579 EMACS_INT offset = lispdesc_indirect_count (desc[pos].offset, desc, obj);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3580 if (offset == max_offset)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3581 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3582 stderr_out ("Two relocatable elements at same offset?\n");
2500
3d8143fc88e1 [xemacs-hg @ 2005-01-24 23:33:30 by ben]
ben
parents: 2367
diff changeset
3583 ABORT ();
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3584 }
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3585 else if (offset > max_offset)
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3586 {
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3587 max_offset = offset;
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3588 max_offset_pos = pos;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3589 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3590 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3591
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3592 if (max_offset_pos < 0)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3593 return 0;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3594
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3595 {
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3596 Bytecount size_at_max;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3597 size_at_max =
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3598 lispdesc_one_description_line_size ((char *) obj + max_offset,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3599 &desc[max_offset_pos], obj, desc);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3600
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3601 /* We have no way of knowing the required alignment for this structure,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3602 so just make it maximally aligned. */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3603 return MAX_ALIGN_SIZE (max_offset + size_at_max);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3604 }
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3605 }
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3606
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3607 #endif /* defined (USE_KKCC) || defined (PDUMP) */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3608
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3609 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3610 #define GC_CHECK_NOT_FREE(lheader) \
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3611 gc_checking_assert (! LRECORD_FREE_P (lheader));
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3612 #else /* MC_ALLOC */
1276
beb703ae34fd [xemacs-hg @ 2003-02-08 15:03:45 by michaels]
michaels
parents: 1265
diff changeset
3613 #define GC_CHECK_NOT_FREE(lheader) \
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3614 gc_checking_assert (! LRECORD_FREE_P (lheader)); \
1276
beb703ae34fd [xemacs-hg @ 2003-02-08 15:03:45 by michaels]
michaels
parents: 1265
diff changeset
3615 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p || \
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
3616 ! ((struct old_lcrecord_header *) lheader)->free)
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3617 #endif /* MC_ALLOC */
1276
beb703ae34fd [xemacs-hg @ 2003-02-08 15:03:45 by michaels]
michaels
parents: 1265
diff changeset
3618
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3619 #ifdef USE_KKCC
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3620 /* The following functions implement the new mark algorithm.
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3621 They mark objects according to their descriptions. They
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3622 are modeled on the corresponding pdumper procedures. */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3623
2666
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3624 #ifdef DEBUG_XEMACS
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3625 /* The backtrace for the KKCC mark functions. */
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3626 #define KKCC_INIT_BT_STACK_SIZE 4096
1676
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3627
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3628 typedef struct
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3629 {
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3630 void *obj;
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3631 const struct memory_description *desc;
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3632 int pos;
2666
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3633 } kkcc_bt_stack_entry;
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3634
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3635 static kkcc_bt_stack_entry *kkcc_bt;
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3636 static int kkcc_bt_stack_size;
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3637 static int kkcc_bt_depth = 0;
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3638
2666
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3639 static void
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3640 kkcc_bt_init (void)
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3641 {
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3642 kkcc_bt_depth = 0;
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3643 kkcc_bt_stack_size = KKCC_INIT_BT_STACK_SIZE;
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3644 kkcc_bt = (kkcc_bt_stack_entry *)
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3645 malloc (kkcc_bt_stack_size * sizeof (kkcc_bt_stack_entry));
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3646 if (!kkcc_bt)
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3647 {
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3648 stderr_out ("KKCC backtrace stack init failed for size %d\n",
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3649 kkcc_bt_stack_size);
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3650 ABORT ();
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3651 }
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3652 }
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3653
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3654 void
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3655 kkcc_backtrace (void)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3656 {
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3657 int i;
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3658 stderr_out ("KKCC mark stack backtrace :\n");
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3659 for (i = kkcc_bt_depth - 1; i >= 0; i--)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3660 {
2650
fc554bcc59e7 [xemacs-hg @ 2005-03-11 08:42:30 by crestani]
crestani
parents: 2645
diff changeset
3661 Lisp_Object obj = wrap_pointer_1 (kkcc_bt[i].obj);
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3662 stderr_out (" [%d]", i);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3663 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3664 if ((XRECORD_LHEADER (obj)->type >= lrecord_type_last_built_in_type)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3665 #else /* not MC_ALLOC */
2650
fc554bcc59e7 [xemacs-hg @ 2005-03-11 08:42:30 by crestani]
crestani
parents: 2645
diff changeset
3666 if ((XRECORD_LHEADER (obj)->type >= lrecord_type_free)
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3667 #endif /* not MC_ALLOC */
2650
fc554bcc59e7 [xemacs-hg @ 2005-03-11 08:42:30 by crestani]
crestani
parents: 2645
diff changeset
3668 || (!LRECORDP (obj))
fc554bcc59e7 [xemacs-hg @ 2005-03-11 08:42:30 by crestani]
crestani
parents: 2645
diff changeset
3669 || (!XRECORD_LHEADER_IMPLEMENTATION (obj)))
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3670 {
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3671 stderr_out (" non Lisp Object");
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3672 }
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3673 else
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3674 {
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3675 stderr_out (" %s",
2650
fc554bcc59e7 [xemacs-hg @ 2005-03-11 08:42:30 by crestani]
crestani
parents: 2645
diff changeset
3676 XRECORD_LHEADER_IMPLEMENTATION (obj)->name);
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3677 }
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3678 stderr_out (" (addr: 0x%x, desc: 0x%x, ",
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3679 (int) kkcc_bt[i].obj,
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3680 (int) kkcc_bt[i].desc);
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3681 if (kkcc_bt[i].pos >= 0)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3682 stderr_out ("pos: %d)\n", kkcc_bt[i].pos);
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3683 else
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3684 stderr_out ("root set)\n");
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3685 }
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3686 }
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3687
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3688 static void
2666
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3689 kkcc_bt_stack_realloc (void)
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3690 {
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3691 kkcc_bt_stack_size *= 2;
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3692 kkcc_bt = (kkcc_bt_stack_entry *)
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3693 realloc (kkcc_bt, kkcc_bt_stack_size * sizeof (kkcc_bt_stack_entry));
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3694 if (!kkcc_bt)
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3695 {
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3696 stderr_out ("KKCC backtrace stack realloc failed for size %d\n",
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3697 kkcc_bt_stack_size);
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3698 ABORT ();
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3699 }
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3700 }
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3701
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3702 static void
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3703 kkcc_bt_free (void)
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3704 {
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3705 free (kkcc_bt);
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3706 kkcc_bt = 0;
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3707 kkcc_bt_stack_size = 0;
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3708 }
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3709
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3710 static void
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3711 kkcc_bt_push (void *obj, const struct memory_description *desc,
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3712 int level, int pos)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3713 {
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3714 kkcc_bt_depth = level;
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3715 kkcc_bt[kkcc_bt_depth].obj = obj;
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3716 kkcc_bt[kkcc_bt_depth].desc = desc;
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3717 kkcc_bt[kkcc_bt_depth].pos = pos;
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3718 kkcc_bt_depth++;
2666
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3719 if (kkcc_bt_depth >= kkcc_bt_stack_size)
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3720 kkcc_bt_stack_realloc ();
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3721 }
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3722
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3723 #else /* not DEBUG_XEMACS */
2666
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3724 #define kkcc_bt_init()
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3725 #define kkcc_bt_push(obj, desc, level, pos)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3726 #endif /* not DEBUG_XEMACS */
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3727
2666
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3728 /* Object memory descriptions are in the lrecord_implementation structure.
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3729 But copying them to a parallel array is much more cache-friendly. */
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3730 const struct memory_description *lrecord_memory_descriptions[countof (lrecord_implementations_table)];
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3731
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3732 /* the initial stack size in kkcc_gc_stack_entries */
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3733 #define KKCC_INIT_GC_STACK_SIZE 16384
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3734
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3735 typedef struct
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3736 {
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3737 void *data;
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3738 const struct memory_description *desc;
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3739 #ifdef DEBUG_XEMACS
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3740 int level;
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3741 int pos;
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3742 #endif
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3743 } kkcc_gc_stack_entry;
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3744
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3745 static kkcc_gc_stack_entry *kkcc_gc_stack_ptr;
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3746 static kkcc_gc_stack_entry *kkcc_gc_stack_top;
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3747 static kkcc_gc_stack_entry *kkcc_gc_stack_last_entry;
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3748 static int kkcc_gc_stack_size;
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3749
1676
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3750 static void
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3751 kkcc_gc_stack_init (void)
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3752 {
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3753 kkcc_gc_stack_size = KKCC_INIT_GC_STACK_SIZE;
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3754 kkcc_gc_stack_ptr = (kkcc_gc_stack_entry *)
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3755 malloc (kkcc_gc_stack_size * sizeof (kkcc_gc_stack_entry));
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3756 if (!kkcc_gc_stack_ptr)
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3757 {
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3758 stderr_out ("stack init failed for size %d\n", kkcc_gc_stack_size);
2666
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3759 ABORT ();
1676
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3760 }
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3761 kkcc_gc_stack_top = kkcc_gc_stack_ptr - 1;
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3762 kkcc_gc_stack_last_entry = kkcc_gc_stack_ptr + kkcc_gc_stack_size - 1;
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3763 }
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3764
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3765 static void
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3766 kkcc_gc_stack_free (void)
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3767 {
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3768 free (kkcc_gc_stack_ptr);
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3769 kkcc_gc_stack_ptr = 0;
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3770 kkcc_gc_stack_top = 0;
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3771 kkcc_gc_stack_size = 0;
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3772 }
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3773
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3774 static void
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3775 kkcc_gc_stack_realloc (void)
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3776 {
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3777 int current_offset = (int)(kkcc_gc_stack_top - kkcc_gc_stack_ptr);
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3778 kkcc_gc_stack_size *= 2;
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3779 kkcc_gc_stack_ptr = (kkcc_gc_stack_entry *)
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3780 realloc (kkcc_gc_stack_ptr,
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3781 kkcc_gc_stack_size * sizeof (kkcc_gc_stack_entry));
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3782 if (!kkcc_gc_stack_ptr)
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3783 {
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3784 stderr_out ("stack realloc failed for size %d\n", kkcc_gc_stack_size);
2666
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3785 ABORT ();
1676
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3786 }
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3787 kkcc_gc_stack_top = kkcc_gc_stack_ptr + current_offset;
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3788 kkcc_gc_stack_last_entry = kkcc_gc_stack_ptr + kkcc_gc_stack_size - 1;
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3789 }
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3790
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3791 #define KKCC_GC_STACK_FULL (kkcc_gc_stack_top >= kkcc_gc_stack_last_entry)
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3792 #define KKCC_GC_STACK_EMPTY (kkcc_gc_stack_top < kkcc_gc_stack_ptr)
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3793
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3794 static void
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3795 #ifdef DEBUG_XEMACS
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3796 kkcc_gc_stack_push_1 (void *data, const struct memory_description *desc,
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3797 int level, int pos)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3798 #else
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3799 kkcc_gc_stack_push_1 (void *data, const struct memory_description *desc)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3800 #endif
1676
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3801 {
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3802 if (KKCC_GC_STACK_FULL)
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3803 kkcc_gc_stack_realloc();
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3804 kkcc_gc_stack_top++;
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3805 kkcc_gc_stack_top->data = data;
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3806 kkcc_gc_stack_top->desc = desc;
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3807 #ifdef DEBUG_XEMACS
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3808 kkcc_gc_stack_top->level = level;
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3809 kkcc_gc_stack_top->pos = pos;
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3810 #endif
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3811 }
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3812
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3813 #ifdef DEBUG_XEMACS
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3814 #define kkcc_gc_stack_push(data, desc, level, pos) \
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3815 kkcc_gc_stack_push_1 (data, desc, level, pos)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3816 #else
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3817 #define kkcc_gc_stack_push(data, desc, level, pos) \
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3818 kkcc_gc_stack_push_1 (data, desc)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3819 #endif
1676
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3820
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3821 static kkcc_gc_stack_entry *
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3822 kkcc_gc_stack_pop (void)
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3823 {
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3824 if (KKCC_GC_STACK_EMPTY)
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3825 return 0;
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3826 kkcc_gc_stack_top--;
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3827 return kkcc_gc_stack_top + 1;
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3828 }
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3829
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3830 void
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3831 #ifdef DEBUG_XEMACS
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3832 kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj, int level, int pos)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3833 #else
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3834 kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3835 #endif
1676
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3836 {
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3837 if (XTYPE (obj) == Lisp_Type_Record)
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3838 {
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3839 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3840 const struct memory_description *desc;
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3841 GC_CHECK_LHEADER_INVARIANTS (lheader);
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3842 desc = RECORD_DESCRIPTION (lheader);
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3843 if (! MARKED_RECORD_HEADER_P (lheader))
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3844 {
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3845 MARK_RECORD_HEADER (lheader);
2666
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3846 kkcc_gc_stack_push ((void*) lheader, desc, level, pos);
1676
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3847 }
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3848 }
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3849 }
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
3850
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3851 #ifdef DEBUG_XEMACS
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3852 #define kkcc_gc_stack_push_lisp_object(obj, level, pos) \
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3853 kkcc_gc_stack_push_lisp_object_1 (obj, level, pos)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3854 #else
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3855 #define kkcc_gc_stack_push_lisp_object(obj, level, pos) \
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3856 kkcc_gc_stack_push_lisp_object_1 (obj)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3857 #endif
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3858
1265
de6cf052e10b [xemacs-hg @ 2003-02-07 00:49:41 by ben]
ben
parents: 1242
diff changeset
3859 #ifdef ERROR_CHECK_GC
de6cf052e10b [xemacs-hg @ 2003-02-07 00:49:41 by ben]
ben
parents: 1242
diff changeset
3860 #define KKCC_DO_CHECK_FREE(obj, allow_free) \
de6cf052e10b [xemacs-hg @ 2003-02-07 00:49:41 by ben]
ben
parents: 1242
diff changeset
3861 do \
de6cf052e10b [xemacs-hg @ 2003-02-07 00:49:41 by ben]
ben
parents: 1242
diff changeset
3862 { \
de6cf052e10b [xemacs-hg @ 2003-02-07 00:49:41 by ben]
ben
parents: 1242
diff changeset
3863 if (!allow_free && XTYPE (obj) == Lisp_Type_Record) \
de6cf052e10b [xemacs-hg @ 2003-02-07 00:49:41 by ben]
ben
parents: 1242
diff changeset
3864 { \
de6cf052e10b [xemacs-hg @ 2003-02-07 00:49:41 by ben]
ben
parents: 1242
diff changeset
3865 struct lrecord_header *lheader = XRECORD_LHEADER (obj); \
de6cf052e10b [xemacs-hg @ 2003-02-07 00:49:41 by ben]
ben
parents: 1242
diff changeset
3866 GC_CHECK_NOT_FREE (lheader); \
de6cf052e10b [xemacs-hg @ 2003-02-07 00:49:41 by ben]
ben
parents: 1242
diff changeset
3867 } \
de6cf052e10b [xemacs-hg @ 2003-02-07 00:49:41 by ben]
ben
parents: 1242
diff changeset
3868 } while (0)
de6cf052e10b [xemacs-hg @ 2003-02-07 00:49:41 by ben]
ben
parents: 1242
diff changeset
3869 #else
de6cf052e10b [xemacs-hg @ 2003-02-07 00:49:41 by ben]
ben
parents: 1242
diff changeset
3870 #define KKCC_DO_CHECK_FREE(obj, allow_free)
de6cf052e10b [xemacs-hg @ 2003-02-07 00:49:41 by ben]
ben
parents: 1242
diff changeset
3871 #endif
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3872
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3873 #ifdef ERROR_CHECK_GC
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3874 #ifdef DEBUG_XEMACS
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3875 static void
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3876 mark_object_maybe_checking_free_1 (Lisp_Object obj, int allow_free,
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3877 int level, int pos)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3878 #else
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3879 static void
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3880 mark_object_maybe_checking_free_1 (Lisp_Object obj, int allow_free)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3881 #endif
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3882 {
1265
de6cf052e10b [xemacs-hg @ 2003-02-07 00:49:41 by ben]
ben
parents: 1242
diff changeset
3883 KKCC_DO_CHECK_FREE (obj, allow_free);
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3884 kkcc_gc_stack_push_lisp_object (obj, level, pos);
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3885 }
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3886
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3887 #ifdef DEBUG_XEMACS
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3888 #define mark_object_maybe_checking_free(obj, allow_free, level, pos) \
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3889 mark_object_maybe_checking_free_1 (obj, allow_free, level, pos)
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3890 #else
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3891 #define mark_object_maybe_checking_free(obj, allow_free, level, pos) \
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3892 mark_object_maybe_checking_free_1 (obj, allow_free)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3893 #endif
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3894 #else /* not ERROR_CHECK_GC */
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3895 #define mark_object_maybe_checking_free(obj, allow_free, level, pos) \
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3896 kkcc_gc_stack_push_lisp_object (obj, level, pos)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3897 #endif /* not ERROR_CHECK_GC */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3898
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3899
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3900 /* This function loops all elements of a struct pointer and calls
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3901 mark_with_description with each element. */
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3902 static void
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3903 #ifdef DEBUG_XEMACS
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3904 mark_struct_contents_1 (const void *data,
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3905 const struct sized_memory_description *sdesc,
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3906 int count, int level, int pos)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3907 #else
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3908 mark_struct_contents_1 (const void *data,
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3909 const struct sized_memory_description *sdesc,
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
3910 int count)
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3911 #endif
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3912 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3913 int i;
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3914 Bytecount elsize;
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3915 elsize = lispdesc_block_size (data, sdesc);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3916
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3917 for (i = 0; i < count; i++)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3918 {
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3919 kkcc_gc_stack_push (((char *) data) + elsize * i, sdesc->description,
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3920 level, pos);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3921 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3922 }
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
3923
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3924 #ifdef DEBUG_XEMACS
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3925 #define mark_struct_contents(data, sdesc, count, level, pos) \
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3926 mark_struct_contents_1 (data, sdesc, count, level, pos)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3927 #else
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3928 #define mark_struct_contents(data, sdesc, count, level, pos) \
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3929 mark_struct_contents_1 (data, sdesc, count)
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3930 #endif
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3931
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3932 /* This function implements the KKCC mark algorithm.
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3933 Instead of calling mark_object, all the alive Lisp_Objects are pushed
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3934 on the kkcc_gc_stack. This function processes all elements on the stack
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3935 according to their descriptions. */
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3936 static void
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3937 kkcc_marking (void)
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3938 {
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3939 kkcc_gc_stack_entry *stack_entry = 0;
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3940 void *data = 0;
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3941 const struct memory_description *desc = 0;
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3942 int pos;
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3943 #ifdef DEBUG_XEMACS
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3944 int level = 0;
2666
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
3945 kkcc_bt_init ();
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3946 #endif
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3947
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3948 while ((stack_entry = kkcc_gc_stack_pop ()) != 0)
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3949 {
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3950 data = stack_entry->data;
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3951 desc = stack_entry->desc;
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3952 #ifdef DEBUG_XEMACS
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3953 level = stack_entry->level + 1;
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3954 #endif
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3955
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
3956 kkcc_bt_push (data, desc, stack_entry->level, stack_entry->pos);
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3957
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3958 gc_checking_assert (data);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3959 gc_checking_assert (desc);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3960
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3961 for (pos = 0; desc[pos].type != XD_END; pos++)
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3962 {
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3963 const struct memory_description *desc1 = &desc[pos];
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3964 const void *rdata =
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3965 (const char *) data + lispdesc_indirect_count (desc1->offset,
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3966 desc, data);
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3967 union_switcheroo:
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3968
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3969 /* If the flag says don't mark, then don't mark. */
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3970 if ((desc1->flags) & XD_FLAG_NO_KKCC)
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3971 continue;
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3972
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3973 switch (desc1->type)
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3974 {
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3975 case XD_BYTECOUNT:
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3976 case XD_ELEMCOUNT:
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3977 case XD_HASHCODE:
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3978 case XD_INT:
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3979 case XD_LONG:
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3980 case XD_INT_RESET:
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3981 case XD_LO_LINK:
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3982 case XD_OPAQUE_PTR:
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3983 case XD_OPAQUE_DATA_PTR:
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
3984 case XD_ASCII_STRING:
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3985 case XD_DOC_STRING:
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3986 break;
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3987 case XD_LISP_OBJECT:
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3988 {
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3989 const Lisp_Object *stored_obj = (const Lisp_Object *) rdata;
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3990
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3991 /* Because of the way that tagged objects work (pointers and
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3992 Lisp_Objects have the same representation), XD_LISP_OBJECT
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3993 can be used for untagged pointers. They might be NULL,
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3994 though. */
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3995 if (EQ (*stored_obj, Qnull_pointer))
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3996 break;
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3997 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3998 mark_object_maybe_checking_free (*stored_obj, 0, level, pos);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
3999 #else /* not MC_ALLOC */
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4000 mark_object_maybe_checking_free
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
4001 (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT,
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
4002 level, pos);
2775
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
4003 #endif /* not MC_ALLOC */
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4004 break;
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4005 }
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4006 case XD_LISP_OBJECT_ARRAY:
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4007 {
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4008 int i;
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4009 EMACS_INT count =
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4010 lispdesc_indirect_count (desc1->data1, desc, data);
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4011
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4012 for (i = 0; i < count; i++)
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4013 {
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4014 const Lisp_Object *stored_obj =
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4015 (const Lisp_Object *) rdata + i;
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4016
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4017 if (EQ (*stored_obj, Qnull_pointer))
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4018 break;
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4019 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4020 mark_object_maybe_checking_free (*stored_obj, 0, level, pos);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4021 #else /* not MC_ALLOC */
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4022 mark_object_maybe_checking_free
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
4023 (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT,
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
4024 level, pos);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4025 #endif /* not MC_ALLOC */
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4026 }
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4027 break;
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4028 }
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
4029 case XD_BLOCK_PTR:
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4030 {
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4031 EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc,
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4032 data);
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4033 const struct sized_memory_description *sdesc =
2551
9f70af3ac939 [xemacs-hg @ 2005-02-03 16:14:02 by james]
james
parents: 2532
diff changeset
4034 lispdesc_indirect_description (data, desc1->data2.descr);
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4035 const char *dobj = * (const char **) rdata;
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4036 if (dobj)
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
4037 mark_struct_contents (dobj, sdesc, count, level, pos);
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4038 break;
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4039 }
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
4040 case XD_BLOCK_ARRAY:
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4041 {
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4042 EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc,
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4043 data);
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4044 const struct sized_memory_description *sdesc =
2551
9f70af3ac939 [xemacs-hg @ 2005-02-03 16:14:02 by james]
james
parents: 2532
diff changeset
4045 lispdesc_indirect_description (data, desc1->data2.descr);
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4046
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
4047 mark_struct_contents (rdata, sdesc, count, level, pos);
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4048 break;
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4049 }
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4050 case XD_UNION:
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4051 case XD_UNION_DYNAMIC_SIZE:
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4052 desc1 = lispdesc_process_xd_union (desc1, desc, data);
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4053 if (desc1)
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4054 goto union_switcheroo;
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4055 break;
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4056
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4057 default:
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4058 stderr_out ("Unsupported description type : %d\n", desc1->type);
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
4059 kkcc_backtrace ();
2500
3d8143fc88e1 [xemacs-hg @ 2005-01-24 23:33:30 by ben]
ben
parents: 2367
diff changeset
4060 ABORT ();
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4061 }
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4062 }
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4063 }
2666
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
4064 #ifdef DEBUG_XEMACS
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
4065 kkcc_bt_free ();
7bf1f40e6acb [xemacs-hg @ 2005-03-15 11:56:32 by crestani]
crestani
parents: 2659
diff changeset
4066 #endif
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4067 }
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4068 #endif /* USE_KKCC */
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4069
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4070 /* Mark reference to a Lisp_Object. If the object referred to has not been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4071 seen yet, recursively mark all the references contained in it. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4072
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4073 void
2286
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2260
diff changeset
4074 mark_object (
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2260
diff changeset
4075 #ifdef USE_KKCC
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2260
diff changeset
4076 Lisp_Object UNUSED (obj)
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2260
diff changeset
4077 #else
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2260
diff changeset
4078 Lisp_Object obj
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2260
diff changeset
4079 #endif
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2260
diff changeset
4080 )
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4081 {
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4082 #ifdef USE_KKCC
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4083 /* this code should never be reached when configured for KKCC */
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4084 stderr_out ("KKCC: Invalid mark_object call.\n");
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4085 stderr_out ("Replace mark_object with kkcc_gc_stack_push_lisp_object.\n");
2500
3d8143fc88e1 [xemacs-hg @ 2005-01-24 23:33:30 by ben]
ben
parents: 2367
diff changeset
4086 ABORT ();
1676
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
4087 #else /* not USE_KKCC */
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4088
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4089 tail_recurse:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4090
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4091 /* Checks we used to perform */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4092 /* if (EQ (obj, Qnull_pointer)) return; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4093 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4094 /* if (PURIFIED (XPNTR (obj))) return; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4095
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4096 if (XTYPE (obj) == Lisp_Type_Record)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4097 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4098 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4099
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4100 GC_CHECK_LHEADER_INVARIANTS (lheader);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4101
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4102 /* We handle this separately, above, so we can mark free objects */
1265
de6cf052e10b [xemacs-hg @ 2003-02-07 00:49:41 by ben]
ben
parents: 1242
diff changeset
4103 GC_CHECK_NOT_FREE (lheader);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4104
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4105 /* All c_readonly objects have their mark bit set,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4106 so that we only need to check the mark bit here. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4107 if (! MARKED_RECORD_HEADER_P (lheader))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4108 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4109 MARK_RECORD_HEADER (lheader);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4110
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4111 if (RECORD_MARKER (lheader))
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4112 {
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4113 obj = RECORD_MARKER (lheader) (obj);
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4114 if (!NILP (obj)) goto tail_recurse;
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
4115 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4116 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4117 }
1676
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
4118 #endif /* not KKCC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4119 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4120
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4121
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4122 #ifndef MC_ALLOC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4123 static int gc_count_num_short_string_in_use;
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
4124 static Bytecount gc_count_string_total_size;
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
4125 static Bytecount gc_count_short_string_total_size;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4126
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4127 /* static int gc_count_total_records_used, gc_count_records_total_size; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4128
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4129
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4130 /* stats on lcrecords in use - kinda kludgy */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4131
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4132 static struct
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4133 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4134 int instances_in_use;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4135 int bytes_in_use;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4136 int instances_freed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4137 int bytes_freed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4138 int instances_on_free_list;
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 665
diff changeset
4139 } lcrecord_stats [countof (lrecord_implementations_table)
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 665
diff changeset
4140 + MODULE_DEFINABLE_TYPE_COUNT];
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4141
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4142 static void
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4143 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4144 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
4145 int type_index = h->type;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4146
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
4147 if (((struct old_lcrecord_header *) h)->free)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4148 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4149 gc_checking_assert (!free_p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4150 lcrecord_stats[type_index].instances_on_free_list++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4151 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4152 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4153 {
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4154 Bytecount sz = detagged_lisp_object_size (h);
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4155
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4156 if (free_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4157 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4158 lcrecord_stats[type_index].instances_freed++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4159 lcrecord_stats[type_index].bytes_freed += sz;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4160 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4161 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4162 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4163 lcrecord_stats[type_index].instances_in_use++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4164 lcrecord_stats[type_index].bytes_in_use += sz;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4165 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4166 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4167 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4168 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4169
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4170
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4171 #ifndef MC_ALLOC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4172 /* Free all unmarked records */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4173 static void
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
4174 sweep_lcrecords_1 (struct old_lcrecord_header **prev, int *used)
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
4175 {
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
4176 struct old_lcrecord_header *header;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4177 int num_used = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4178 /* int total_size = 0; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4179
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4180 xzero (lcrecord_stats); /* Reset all statistics to 0. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4181
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4182 /* First go through and call all the finalize methods.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4183 Then go through and free the objects. There used to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4184 be only one loop here, with the call to the finalizer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4185 occurring directly before the xfree() below. That
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4186 is marginally faster but much less safe -- if the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4187 finalize method for an object needs to reference any
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4188 other objects contained within it (and many do),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4189 we could easily be screwed by having already freed that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4190 other object. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4191
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4192 for (header = *prev; header; header = header->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4193 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4194 struct lrecord_header *h = &(header->lheader);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4195
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4196 GC_CHECK_LHEADER_INVARIANTS (h);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4197
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4198 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4199 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4200 if (LHEADER_IMPLEMENTATION (h)->finalizer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4201 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4202 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4203 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4204
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4205 for (header = *prev; header; )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4206 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4207 struct lrecord_header *h = &(header->lheader);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4208 if (MARKED_RECORD_HEADER_P (h))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4209 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4210 if (! C_READONLY_RECORD_HEADER_P (h))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4211 UNMARK_RECORD_HEADER (h);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4212 num_used++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4213 /* total_size += n->implementation->size_in_bytes (h);*/
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4214 /* #### May modify header->next on a C_READONLY lcrecord */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4215 prev = &(header->next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4216 header = *prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4217 tick_lcrecord_stats (h, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4218 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4219 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4220 {
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
4221 struct old_lcrecord_header *next = header->next;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4222 *prev = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4223 tick_lcrecord_stats (h, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4224 /* used to call finalizer right here. */
3024
b7f26b2f78bd [xemacs-hg @ 2005-10-25 08:32:40 by ben]
ben
parents: 3017
diff changeset
4225 xfree (header, struct old_lcrecord_header *);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4226 header = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4227 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4228 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4229 *used = num_used;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4230 /* *total = total_size; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4231 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4232
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4233 /* And the Lord said: Thou shalt use the `c-backslash-region' command
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4234 to make macros prettier. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4235
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4236 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4237
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4238 #define SWEEP_FIXED_TYPE_BLOCK_1(typename, obj_type, lheader) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4239 do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4240 struct typename##_block *SFTB_current; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4241 int SFTB_limit; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4242 int num_free = 0, num_used = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4243 \
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
4244 for (SFTB_current = current_##typename##_block, \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4245 SFTB_limit = current_##typename##_block_index; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4246 SFTB_current; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4247 ) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4248 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4249 int SFTB_iii; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4250 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4251 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4252 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4253 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4254 \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4255 if (LRECORD_FREE_P (SFTB_victim)) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4256 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4257 num_free++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4258 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4259 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4260 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4261 num_used++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4262 } \
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4263 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4264 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4265 num_free++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4266 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4267 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4268 else \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4269 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4270 num_used++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4271 UNMARK_##typename (SFTB_victim); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4272 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4273 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4274 SFTB_current = SFTB_current->prev; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4275 SFTB_limit = countof (current_##typename##_block->block); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4276 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4277 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4278 gc_count_num_##typename##_in_use = num_used; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4279 gc_count_num_##typename##_freelist = num_free; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4280 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4281
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4282 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4283
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4284 #define SWEEP_FIXED_TYPE_BLOCK_1(typename, obj_type, lheader) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4285 do { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4286 struct typename##_block *SFTB_current; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4287 struct typename##_block **SFTB_prev; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4288 int SFTB_limit; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4289 int num_free = 0, num_used = 0; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4290 \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4291 typename##_free_list = 0; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4292 \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4293 for (SFTB_prev = &current_##typename##_block, \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4294 SFTB_current = current_##typename##_block, \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4295 SFTB_limit = current_##typename##_block_index; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4296 SFTB_current; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4297 ) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4298 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4299 int SFTB_iii; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4300 int SFTB_empty = 1; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4301 Lisp_Free *SFTB_old_free_list = typename##_free_list; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4302 \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4303 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4304 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4305 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4306 \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4307 if (LRECORD_FREE_P (SFTB_victim)) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4308 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4309 num_free++; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4310 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4311 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4312 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4313 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4314 SFTB_empty = 0; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4315 num_used++; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4316 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4317 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4318 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4319 num_free++; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4320 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4321 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4322 else \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4323 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4324 SFTB_empty = 0; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4325 num_used++; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4326 UNMARK_##typename (SFTB_victim); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4327 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4328 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4329 if (!SFTB_empty) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4330 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4331 SFTB_prev = &(SFTB_current->prev); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4332 SFTB_current = SFTB_current->prev; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4333 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4334 else if (SFTB_current == current_##typename##_block \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4335 && !SFTB_current->prev) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4336 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4337 /* No real point in freeing sole allocation block */ \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4338 break; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4339 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4340 else \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4341 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4342 struct typename##_block *SFTB_victim_block = SFTB_current; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4343 if (SFTB_victim_block == current_##typename##_block) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4344 current_##typename##_block_index \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4345 = countof (current_##typename##_block->block); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4346 SFTB_current = SFTB_current->prev; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4347 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4348 *SFTB_prev = SFTB_current; \
1726
a8d8f419b459 [xemacs-hg @ 2003-09-30 15:26:34 by james]
james
parents: 1676
diff changeset
4349 xfree (SFTB_victim_block, struct typename##_block *); \
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4350 /* Restore free list to what it was before victim was swept */ \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4351 typename##_free_list = SFTB_old_free_list; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4352 num_free -= SFTB_limit; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4353 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4354 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4355 SFTB_limit = countof (current_##typename##_block->block); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4356 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4357 \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4358 gc_count_num_##typename##_in_use = num_used; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4359 gc_count_num_##typename##_freelist = num_free; \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4360 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4361
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4362 #endif /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4363
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4364 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4365 SWEEP_FIXED_TYPE_BLOCK_1 (typename, obj_type, lheader)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4366
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4367 #endif /* not MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4368
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4369
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4370 #ifndef MC_ALLOC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4371 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4372 sweep_conses (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4373 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4374 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4375 #define ADDITIONAL_FREE_cons(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4376
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4377 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4378 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4379 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4380
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4381 /* Explicitly free a cons cell. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4382 void
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4383 free_cons (Lisp_Object cons)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4384 {
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4385 #ifndef MC_ALLOC /* to avoid compiler warning */
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4386 Lisp_Cons *ptr = XCONS (cons);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4387 #endif /* MC_ALLOC */
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4388
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4389 #ifdef ERROR_CHECK_GC
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4390 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4391 Lisp_Cons *ptr = XCONS (cons);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4392 #endif /* MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4393 /* If the CAR is not an int, then it will be a pointer, which will
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4394 always be four-byte aligned. If this cons cell has already been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4395 placed on the free list, however, its car will probably contain
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4396 a chain pointer to the next cons on the list, which has cleverly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4397 had all its 0's and 1's inverted. This allows for a quick
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4398 check to make sure we're not freeing something already freed.
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4399
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4400 NOTE: This check may not be necessary. Freeing an object sets its
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4401 type to lrecord_type_free, which will trip up the XCONS() above -- as
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4402 well as a check in FREE_FIXED_TYPE(). */
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4403 if (POINTER_TYPE_P (XTYPE (cons_car (ptr))))
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4404 ASSERT_VALID_POINTER (XPNTR (cons_car (ptr)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4405 #endif /* ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4406
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4407 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4408 free_lrecord (cons);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4409 #else /* not MC_ALLOC */
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4410 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4411 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4412 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4413
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4414 /* explicitly free a list. You **must make sure** that you have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4415 created all the cons cells that make up this list and that there
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4416 are no pointers to any of these cons cells anywhere else. If there
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4417 are, you will lose. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4418
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4419 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4420 free_list (Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4421 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4422 Lisp_Object rest, next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4423
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4424 for (rest = list; !NILP (rest); rest = next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4425 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4426 next = XCDR (rest);
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4427 free_cons (rest);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4428 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4429 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4430
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4431 /* explicitly free an alist. You **must make sure** that you have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4432 created all the cons cells that make up this alist and that there
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4433 are no pointers to any of these cons cells anywhere else. If there
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4434 are, you will lose. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4435
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4436 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4437 free_alist (Lisp_Object alist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4438 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4439 Lisp_Object rest, next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4440
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4441 for (rest = alist; !NILP (rest); rest = next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4442 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4443 next = XCDR (rest);
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4444 free_cons (XCAR (rest));
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4445 free_cons (rest);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4446 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4447 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4448
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4449 #ifndef MC_ALLOC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4450 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4451 sweep_compiled_functions (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4452 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4453 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
945
7924b28c57a4 [xemacs-hg @ 2002-08-01 08:38:32 by michaels]
michaels
parents: 943
diff changeset
4454 #define ADDITIONAL_FREE_compiled_function(ptr) \
1726
a8d8f419b459 [xemacs-hg @ 2003-09-30 15:26:34 by james]
james
parents: 1676
diff changeset
4455 if (ptr->args_in_array) xfree (ptr->args, Lisp_Object *)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4456
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4457 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4458 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4459
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4460 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4461 sweep_floats (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4462 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4463 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4464 #define ADDITIONAL_FREE_float(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4465
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4466 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4467 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4468
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4469 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4470 static void
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4471 sweep_bignums (void)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4472 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4473 #define UNMARK_bignum(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4474 #define ADDITIONAL_FREE_bignum(ptr) bignum_fini (ptr->data)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4475
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4476 SWEEP_FIXED_TYPE_BLOCK (bignum, Lisp_Bignum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4477 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4478 #endif /* HAVE_BIGNUM */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4479
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4480 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4481 static void
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4482 sweep_ratios (void)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4483 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4484 #define UNMARK_ratio(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4485 #define ADDITIONAL_FREE_ratio(ptr) ratio_fini (ptr->data)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4486
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4487 SWEEP_FIXED_TYPE_BLOCK (ratio, Lisp_Ratio);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4488 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4489 #endif /* HAVE_RATIO */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4490
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4491 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4492 static void
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4493 sweep_bigfloats (void)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4494 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4495 #define UNMARK_bigfloat(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4496 #define ADDITIONAL_FREE_bigfloat(ptr) bigfloat_fini (ptr->bf)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4497
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4498 SWEEP_FIXED_TYPE_BLOCK (bigfloat, Lisp_Bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4499 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4500 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
4501
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4502 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4503 sweep_symbols (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4504 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4505 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4506 #define ADDITIONAL_FREE_symbol(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4507
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4508 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4509 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4510
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4511 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4512 sweep_extents (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4513 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4514 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4515 #define ADDITIONAL_FREE_extent(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4516
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4517 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4518 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4519
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4520 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4521 sweep_events (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4522 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4523 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4524 #define ADDITIONAL_FREE_event(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4525
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4526 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4527 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4528 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4529
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4530 #ifdef EVENT_DATA_AS_OBJECTS
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4531
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4532 #ifndef MC_ALLOC
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4533 static void
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4534 sweep_key_data (void)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4535 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4536 #define UNMARK_key_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4537 #define ADDITIONAL_FREE_key_data(ptr)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4538
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4539 SWEEP_FIXED_TYPE_BLOCK (key_data, Lisp_Key_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4540 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4541 #endif /* not MC_ALLOC */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4542
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4543 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4544 free_key_data (Lisp_Object ptr)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4545 {
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4546 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4547 free_lrecord (ptr);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4548 #else /* not MC_ALLOC */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4549 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (key_data, Lisp_Key_Data, XKEY_DATA (ptr));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4550 #endif /* not MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4551 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4552
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4553 #ifndef MC_ALLOC
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4554 static void
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4555 sweep_button_data (void)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4556 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4557 #define UNMARK_button_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4558 #define ADDITIONAL_FREE_button_data(ptr)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4559
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4560 SWEEP_FIXED_TYPE_BLOCK (button_data, Lisp_Button_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4561 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4562 #endif /* not MC_ALLOC */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4563
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4564 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4565 free_button_data (Lisp_Object ptr)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4566 {
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4567 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4568 free_lrecord (ptr);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4569 #else /* not MC_ALLOC */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4570 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (button_data, Lisp_Button_Data, XBUTTON_DATA (ptr));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4571 #endif /* not MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4572 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4573
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4574 #ifndef MC_ALLOC
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4575 static void
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4576 sweep_motion_data (void)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4577 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4578 #define UNMARK_motion_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4579 #define ADDITIONAL_FREE_motion_data(ptr)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4580
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4581 SWEEP_FIXED_TYPE_BLOCK (motion_data, Lisp_Motion_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4582 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4583 #endif /* not MC_ALLOC */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4584
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4585 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4586 free_motion_data (Lisp_Object ptr)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4587 {
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4588 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4589 free_lrecord (ptr);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4590 #else /* not MC_ALLOC */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4591 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (motion_data, Lisp_Motion_Data, XMOTION_DATA (ptr));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4592 #endif /* not MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4593 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4594
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4595 #ifndef MC_ALLOC
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4596 static void
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4597 sweep_process_data (void)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4598 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4599 #define UNMARK_process_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4600 #define ADDITIONAL_FREE_process_data(ptr)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4601
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4602 SWEEP_FIXED_TYPE_BLOCK (process_data, Lisp_Process_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4603 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4604 #endif /* not MC_ALLOC */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4605
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4606 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4607 free_process_data (Lisp_Object ptr)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4608 {
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4609 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4610 free_lrecord (ptr);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4611 #else /* not MC_ALLOC */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4612 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (process_data, Lisp_Process_Data, XPROCESS_DATA (ptr));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4613 #endif /* not MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4614 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4615
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4616 #ifndef MC_ALLOC
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4617 static void
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4618 sweep_timeout_data (void)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4619 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4620 #define UNMARK_timeout_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4621 #define ADDITIONAL_FREE_timeout_data(ptr)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4622
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4623 SWEEP_FIXED_TYPE_BLOCK (timeout_data, Lisp_Timeout_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4624 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4625 #endif /* not MC_ALLOC */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4626
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4627 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4628 free_timeout_data (Lisp_Object ptr)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4629 {
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4630 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4631 free_lrecord (ptr);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4632 #else /* not MC_ALLOC */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4633 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (timeout_data, Lisp_Timeout_Data, XTIMEOUT_DATA (ptr));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4634 #endif /* not MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4635 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4636
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4637 #ifndef MC_ALLOC
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4638 static void
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4639 sweep_magic_data (void)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4640 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4641 #define UNMARK_magic_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4642 #define ADDITIONAL_FREE_magic_data(ptr)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4643
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4644 SWEEP_FIXED_TYPE_BLOCK (magic_data, Lisp_Magic_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4645 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4646 #endif /* not MC_ALLOC */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4647
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4648 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4649 free_magic_data (Lisp_Object ptr)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4650 {
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4651 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4652 free_lrecord (ptr);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4653 #else /* not MC_ALLOC */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4654 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (magic_data, Lisp_Magic_Data, XMAGIC_DATA (ptr));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4655 #endif /* not MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4656 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4657
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4658 #ifndef MC_ALLOC
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4659 static void
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4660 sweep_magic_eval_data (void)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4661 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4662 #define UNMARK_magic_eval_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4663 #define ADDITIONAL_FREE_magic_eval_data(ptr)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4664
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4665 SWEEP_FIXED_TYPE_BLOCK (magic_eval_data, Lisp_Magic_Eval_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4666 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4667 #endif /* not MC_ALLOC */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4668
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4669 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4670 free_magic_eval_data (Lisp_Object ptr)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4671 {
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4672 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4673 free_lrecord (ptr);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4674 #else /* not MC_ALLOC */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4675 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (magic_eval_data, Lisp_Magic_Eval_Data, XMAGIC_EVAL_DATA (ptr));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4676 #endif /* not MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4677 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4678
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4679 #ifndef MC_ALLOC
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4680 static void
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4681 sweep_eval_data (void)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4682 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4683 #define UNMARK_eval_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4684 #define ADDITIONAL_FREE_eval_data(ptr)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4685
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4686 SWEEP_FIXED_TYPE_BLOCK (eval_data, Lisp_Eval_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4687 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4688 #endif /* not MC_ALLOC */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4689
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4690 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4691 free_eval_data (Lisp_Object ptr)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4692 {
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4693 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4694 free_lrecord (ptr);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4695 #else /* not MC_ALLOC */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4696 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (eval_data, Lisp_Eval_Data, XEVAL_DATA (ptr));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4697 #endif /* not MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4698 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4699
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4700 #ifndef MC_ALLOC
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4701 static void
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4702 sweep_misc_user_data (void)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4703 {
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4704 #define UNMARK_misc_user_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4705 #define ADDITIONAL_FREE_misc_user_data(ptr)
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4706
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4707 SWEEP_FIXED_TYPE_BLOCK (misc_user_data, Lisp_Misc_User_Data);
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4708 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4709 #endif /* not MC_ALLOC */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4710
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4711 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4712 free_misc_user_data (Lisp_Object ptr)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4713 {
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4714 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4715 free_lrecord (ptr);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4716 #else /* not MC_ALLOC */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4717 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (misc_user_data, Lisp_Misc_User_Data, XMISC_USER_DATA (ptr));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4718 #endif /* not MC_ALLOC */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4719 }
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4720
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4721 #endif /* EVENT_DATA_AS_OBJECTS */
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
4722
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4723 #ifndef MC_ALLOC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4724 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4725 sweep_markers (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4726 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4727 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4728 #define ADDITIONAL_FREE_marker(ptr) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4729 do { Lisp_Object tem; \
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4730 tem = wrap_marker (ptr); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4731 unchain_marker (tem); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4732 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4733
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4734 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4735 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4736 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4737
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4738 /* Explicitly free a marker. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4739 void
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4740 free_marker (Lisp_Object ptr)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4741 {
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4742 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4743 free_lrecord (ptr);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4744 #else /* not MC_ALLOC */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4745 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, XMARKER (ptr));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4746 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4747 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4748
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4749
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4750 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4751
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4752 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4753 verify_string_chars_integrity (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4754 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4755 struct string_chars_block *sb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4756
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4757 /* Scan each existing string block sequentially, string by string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4758 for (sb = first_string_chars_block; sb; sb = sb->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4759 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4760 int pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4761 /* POS is the index of the next string in the block. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4762 while (pos < sb->pos)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4763 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4764 struct string_chars *s_chars =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4765 (struct string_chars *) &(sb->string_chars[pos]);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
4766 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4767 int size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4768 int fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4769
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4770 /* If the string_chars struct is marked as free (i.e. the
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4771 STRING pointer is NULL) then this is an unused chunk of
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4772 string storage. (See below.) */
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4773
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4774 if (STRING_CHARS_FREE_P (s_chars))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4775 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4776 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4777 pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4778 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4779 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4780
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4781 string = s_chars->string;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4782 /* Must be 32-bit aligned. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4783 assert ((((int) string) & 3) == 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4784
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4785 size = string->size_;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4786 fullsize = STRING_FULLSIZE (size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4787
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4788 assert (!BIG_STRING_FULLSIZE_P (fullsize));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4789 assert (XSTRING_DATA (string) == s_chars->chars);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4790 pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4791 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4792 assert (pos == sb->pos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4793 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4794 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4795
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4796 #endif /* defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY) */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4797
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4798 /* Compactify string chars, relocating the reference to each --
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4799 free any empty string_chars_block we see. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4800 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4801 compact_string_chars (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4802 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4803 struct string_chars_block *to_sb = first_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4804 int to_pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4805 struct string_chars_block *from_sb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4806
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4807 /* Scan each existing string block sequentially, string by string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4808 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4809 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4810 int from_pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4811 /* FROM_POS is the index of the next string in the block. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4812 while (from_pos < from_sb->pos)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4813 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4814 struct string_chars *from_s_chars =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4815 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4816 struct string_chars *to_s_chars;
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
4817 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4818 int size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4819 int fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4820
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4821 /* If the string_chars struct is marked as free (i.e. the
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4822 STRING pointer is NULL) then this is an unused chunk of
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4823 string storage. This happens under Mule when a string's
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4824 size changes in such a way that its fullsize changes.
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4825 (Strings can change size because a different-length
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4826 character can be substituted for another character.)
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4827 In this case, after the bogus string pointer is the
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4828 "fullsize" of this entry, i.e. how many bytes to skip. */
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4829
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
4830 if (STRING_CHARS_FREE_P (from_s_chars))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4831 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4832 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4833 from_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4834 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4835 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4836
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4837 string = from_s_chars->string;
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
4838 gc_checking_assert (!(LRECORD_FREE_P (string)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4839
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4840 size = string->size_;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4841 fullsize = STRING_FULLSIZE (size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4842
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4843 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4844
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4845 /* Just skip it if it isn't marked. */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4846 if (! MARKED_RECORD_HEADER_P (&(string->u.lheader)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4847 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4848 from_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4849 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4850 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4851
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4852 /* If it won't fit in what's left of TO_SB, close TO_SB out
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4853 and go on to the next string_chars_block. We know that TO_SB
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4854 cannot advance past FROM_SB here since FROM_SB is large enough
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4855 to currently contain this string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4856 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4857 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4858 to_sb->pos = to_pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4859 to_sb = to_sb->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4860 to_pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4861 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4862
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4863 /* Compute new address of this string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4864 and update TO_POS for the space being used. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4865 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4866
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4867 /* Copy the string_chars to the new place. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4868 if (from_s_chars != to_s_chars)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4869 memmove (to_s_chars, from_s_chars, fullsize);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4870
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4871 /* Relocate FROM_S_CHARS's reference */
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
4872 set_lispstringp_data (string, &(to_s_chars->chars[0]));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4873
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4874 from_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4875 to_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4876 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4877 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4878
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4879 /* Set current to the last string chars block still used and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4880 free any that follow. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4881 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4882 struct string_chars_block *victim;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4883
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4884 for (victim = to_sb->next; victim; )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4885 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4886 struct string_chars_block *next = victim->next;
1726
a8d8f419b459 [xemacs-hg @ 2003-09-30 15:26:34 by james]
james
parents: 1676
diff changeset
4887 xfree (victim, struct string_chars_block *);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4888 victim = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4889 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4890
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4891 current_string_chars_block = to_sb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4892 current_string_chars_block->pos = to_pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4893 current_string_chars_block->next = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4894 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4895 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4896
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4897 #ifndef MC_ALLOC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4898 #if 1 /* Hack to debug missing purecopy's */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4899 static int debug_string_purity;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4900
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4901 static void
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4902 debug_string_purity_print (Lisp_Object p)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4903 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4904 Charcount i;
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
4905 Charcount s = string_char_length (p);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4906 stderr_out ("\"");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4907 for (i = 0; i < s; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4908 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
4909 Ichar ch = string_ichar (p, i);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4910 if (ch < 32 || ch >= 126)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4911 stderr_out ("\\%03o", ch);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4912 else if (ch == '\\' || ch == '\"')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4913 stderr_out ("\\%c", ch);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4914 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4915 stderr_out ("%c", ch);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4916 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4917 stderr_out ("\"\n");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4918 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4919 #endif /* 1 */
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4920 #endif /* not MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4921
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4922 #ifndef MC_ALLOC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4923 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4924 sweep_strings (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4925 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
4926 int num_small_used = 0;
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
4927 Bytecount num_small_bytes = 0, num_bytes = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4928 int debug = debug_string_purity;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4929
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4930 #define UNMARK_string(ptr) do { \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4931 Lisp_String *p = (ptr); \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4932 Bytecount size = p->size_; \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4933 UNMARK_RECORD_HEADER (&(p->u.lheader)); \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4934 num_bytes += size; \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4935 if (!BIG_STRING_SIZE_P (size)) \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4936 { \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4937 num_small_bytes += size; \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4938 num_small_used++; \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4939 } \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4940 if (debug) \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4941 debug_string_purity_print (wrap_string (p)); \
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
4942 } while (0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
4943 #define ADDITIONAL_FREE_string(ptr) do { \
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4944 Bytecount size = ptr->size_; \
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
4945 if (BIG_STRING_SIZE_P (size)) \
1726
a8d8f419b459 [xemacs-hg @ 2003-09-30 15:26:34 by james]
james
parents: 1676
diff changeset
4946 xfree (ptr->data_, Ibyte *); \
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
4947 } while (0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
4948
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4949 SWEEP_FIXED_TYPE_BLOCK_1 (string, Lisp_String, u.lheader);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4950
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4951 gc_count_num_short_string_in_use = num_small_used;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4952 gc_count_string_total_size = num_bytes;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4953 gc_count_short_string_total_size = num_small_bytes;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4954 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4955 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4956
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4957 /* I hate duplicating all this crap! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4958 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4959 marked_p (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4960 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4961 /* Checks we used to perform. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4962 /* if (EQ (obj, Qnull_pointer)) return 1; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4963 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4964 /* if (PURIFIED (XPNTR (obj))) return 1; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4965
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4966 if (XTYPE (obj) == Lisp_Type_Record)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4967 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4968 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4969
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4970 GC_CHECK_LHEADER_INVARIANTS (lheader);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4971
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4972 return MARKED_RECORD_HEADER_P (lheader);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4973 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4974 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4975 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4976
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4977 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4978 gc_sweep (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4979 {
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4980 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4981 compact_string_chars ();
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4982 mc_finalize ();
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4983 mc_sweep ();
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
4984 #else /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4985 /* Free all unmarked records. Do this at the very beginning,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4986 before anything else, so that the finalize methods can safely
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4987 examine items in the objects. sweep_lcrecords_1() makes
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4988 sure to call all the finalize methods *before* freeing anything,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4989 to complete the safety. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4990 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4991 int ignored;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4992 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4993 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4994
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4995 compact_string_chars ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4996
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4997 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4998 macros) must be *extremely* careful to make sure they're not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4999 referencing freed objects. The only two existing finalize
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5000 methods (for strings and markers) pass muster -- the string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5001 finalizer doesn't look at anything but its own specially-
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5002 created block, and the marker finalizer only looks at live
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5003 buffers (which will never be freed) and at the markers before
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5004 and after it in the chain (which, by induction, will never be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5005 freed because if so, they would have already removed themselves
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5006 from the chain). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5007
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5008 /* Put all unmarked strings on free list, free'ing the string chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5009 of large unmarked strings */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5010 sweep_strings ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5011
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5012 /* Put all unmarked conses on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5013 sweep_conses ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5014
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5015 /* Free all unmarked compiled-function objects */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5016 sweep_compiled_functions ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5017
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5018 /* Put all unmarked floats on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5019 sweep_floats ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5020
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5021 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5022 /* Put all unmarked bignums on free list */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5023 sweep_bignums ();
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5024 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5025
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5026 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5027 /* Put all unmarked ratios on free list */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5028 sweep_ratios ();
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5029 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5030
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5031 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5032 /* Put all unmarked bigfloats on free list */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5033 sweep_bigfloats ();
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5034 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5035
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5036 /* Put all unmarked symbols on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5037 sweep_symbols ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5038
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5039 /* Put all unmarked extents on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5040 sweep_extents ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5041
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5042 /* Put all unmarked markers on free list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5043 Dechain each one first from the buffer into which it points. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5044 sweep_markers ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5045
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5046 sweep_events ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5047
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5048 #ifdef EVENT_DATA_AS_OBJECTS
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5049 sweep_key_data ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5050 sweep_button_data ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5051 sweep_motion_data ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5052 sweep_process_data ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5053 sweep_timeout_data ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5054 sweep_magic_data ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5055 sweep_magic_eval_data ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5056 sweep_eval_data ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
5057 sweep_misc_user_data ();
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5058 #endif /* EVENT_DATA_AS_OBJECTS */
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5059 #endif /* not MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5060
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5061 #ifndef MC_ALLOC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5062 #ifdef PDUMP
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5063 pdump_objects_unmark ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5064 #endif
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5065 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5066 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5067
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5068 /* Clearing for disksave. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5069
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5070 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5071 disksave_object_finalization (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5072 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5073 /* It's important that certain information from the environment not get
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5074 dumped with the executable (pathnames, environment variables, etc.).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5075 To make it easier to tell when this has happened with strings(1) we
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5076 clear some known-to-be-garbage blocks of memory, so that leftover
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5077 results of old evaluation don't look like potential problems.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5078 But first we set some notable variables to nil and do one more GC,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5079 to turn those strings into garbage.
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
5080 */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5081
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5082 /* Yeah, this list is pretty ad-hoc... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5083 Vprocess_environment = Qnil;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5084 env_initted = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5085 Vexec_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5086 Vdata_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5087 Vsite_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5088 Vdoc_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5089 Vexec_path = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5090 Vload_path = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5091 /* Vdump_load_path = Qnil; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5092 /* Release hash tables for locate_file */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5093 Flocate_file_clear_hashing (Qt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5094 uncache_home_directory ();
776
79940b592197 [xemacs-hg @ 2002-03-15 07:43:14 by ben]
ben
parents: 771
diff changeset
5095 zero_out_command_line_status_vars ();
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
5096 clear_default_devices ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5097
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5098 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5099 defined(LOADHIST_BUILTIN))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5100 Vload_history = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5101 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5102 Vshell_file_name = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5103
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5104 garbage_collect_1 ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5105
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5106 /* Run the disksave finalization methods of all live objects. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5107 disksave_object_finalization_1 ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5108
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5109 /* Zero out the uninitialized (really, unused) part of the containers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5110 for the live strings. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5111 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5112 struct string_chars_block *scb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5113 for (scb = first_string_chars_block; scb; scb = scb->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5114 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5115 int count = sizeof (scb->string_chars) - scb->pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5116
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5117 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
5118 if (count != 0)
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
5119 {
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
5120 /* from the block's fill ptr to the end */
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
5121 memset ((scb->string_chars + scb->pos), 0, count);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
5122 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5123 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5124 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5125
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5126 /* There, that ought to be enough... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5127
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5128 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5129
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5130
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5131 int
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5132 begin_gc_forbidden (void)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5133 {
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
5134 return internal_bind_int (&gc_currently_forbidden, 1);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5135 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5136
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5137 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5138 end_gc_forbidden (int count)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5139 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5140 unbind_to (count);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5141 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5142
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5143 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5144 static int gc_hooks_inhibited;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5145
611
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5146 struct post_gc_action
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5147 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5148 void (*fun) (void *);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5149 void *arg;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5150 };
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5151
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5152 typedef struct post_gc_action post_gc_action;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5153
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5154 typedef struct
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5155 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5156 Dynarr_declare (post_gc_action);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5157 } post_gc_action_dynarr;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5158
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5159 static post_gc_action_dynarr *post_gc_actions;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5160
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5161 /* Register an action to be called at the end of GC.
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5162 gc_in_progress is 0 when this is called.
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5163 This is used when it is discovered that an action needs to be taken,
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5164 but it's during GC, so it's not safe. (e.g. in a finalize method.)
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5165
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5166 As a general rule, do not use Lisp objects here.
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5167 And NEVER signal an error.
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5168 */
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5169
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5170 void
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5171 register_post_gc_action (void (*fun) (void *), void *arg)
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5172 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5173 post_gc_action action;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5174
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5175 if (!post_gc_actions)
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5176 post_gc_actions = Dynarr_new (post_gc_action);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5177
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5178 action.fun = fun;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5179 action.arg = arg;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5180
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5181 Dynarr_add (post_gc_actions, action);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5182 }
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5183
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5184 static void
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5185 run_post_gc_actions (void)
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5186 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5187 int i;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5188
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5189 if (post_gc_actions)
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5190 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5191 for (i = 0; i < Dynarr_length (post_gc_actions); i++)
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5192 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5193 post_gc_action action = Dynarr_at (post_gc_actions, i);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5194 (action.fun) (action.arg);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5195 }
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5196
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5197 Dynarr_reset (post_gc_actions);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5198 }
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5199 }
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5200
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5201
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5202 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5203 garbage_collect_1 (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5204 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5205 #if MAX_SAVE_STACK > 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5206 char stack_top_variable;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5207 extern char *stack_bottom;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5208 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5209 struct frame *f;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5210 int speccount;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5211 int cursor_changed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5212 Lisp_Object pre_gc_cursor;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5213 struct gcpro gcpro1;
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
5214 PROFILE_DECLARE ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5215
1123
37bdd24225ef [xemacs-hg @ 2002-11-27 07:15:02 by ben]
ben
parents: 1104
diff changeset
5216 assert (!in_display || gc_currently_forbidden);
37bdd24225ef [xemacs-hg @ 2002-11-27 07:15:02 by ben]
ben
parents: 1104
diff changeset
5217
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5218 if (gc_in_progress
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5219 || gc_currently_forbidden
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5220 || in_display
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5221 || preparing_for_armageddon)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5222 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5223
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
5224 PROFILE_RECORD_ENTERING_SECTION (QSin_garbage_collection);
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
5225
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5226 /* We used to call selected_frame() here.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5227
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5228 The following functions cannot be called inside GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5229 so we move to after the above tests. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5230 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5231 Lisp_Object frame;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5232 Lisp_Object device = Fselected_device (Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5233 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5234 return;
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
5235 frame = Fselected_frame (device);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5236 if (NILP (frame))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 551
diff changeset
5237 invalid_state ("No frames exist on device", device);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5238 f = XFRAME (frame);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5239 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5240
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5241 pre_gc_cursor = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5242 cursor_changed = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5243
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5244 GCPRO1 (pre_gc_cursor);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5245
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5246 /* Very important to prevent GC during any of the following
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5247 stuff that might run Lisp code; otherwise, we'll likely
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5248 have infinite GC recursion. */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5249 speccount = begin_gc_forbidden ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5250
887
ccc3177ef10b [xemacs-hg @ 2002-06-28 14:21:41 by michaels]
michaels
parents: 872
diff changeset
5251 need_to_signal_post_gc = 0;
1318
b531bf8658e9 [xemacs-hg @ 2003-02-21 06:56:46 by ben]
ben
parents: 1315
diff changeset
5252 recompute_funcall_allocation_flag ();
887
ccc3177ef10b [xemacs-hg @ 2002-06-28 14:21:41 by michaels]
michaels
parents: 872
diff changeset
5253
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5254 if (!gc_hooks_inhibited)
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
5255 run_hook_trapping_problems
1333
1b0339b048ce [xemacs-hg @ 2003-03-02 09:38:37 by ben]
ben
parents: 1318
diff changeset
5256 (Qgarbage_collecting, Qpre_gc_hook,
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
5257 INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5258
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5259 /* Now show the GC cursor/message. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5260 if (!noninteractive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5261 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5262 if (FRAME_WIN_P (f))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5263 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5264 Lisp_Object frame = wrap_frame (f);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5265 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5266 FRAME_SELECTED_WINDOW (f),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5267 ERROR_ME_NOT, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5268 pre_gc_cursor = f->pointer;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5269 if (POINTER_IMAGE_INSTANCEP (cursor)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5270 /* don't change if we don't know how to change back. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5271 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5272 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5273 cursor_changed = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5274 Fset_frame_pointer (frame, cursor);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5275 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5276 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5277
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5278 /* Don't print messages to the stream device. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5279 if (!cursor_changed && !FRAME_STREAM_P (f))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5280 {
1154
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5281 if (garbage_collection_messages)
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5282 {
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5283 Lisp_Object args[2], whole_msg;
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5284 args[0] = (STRINGP (Vgc_message) ? Vgc_message :
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5285 build_msg_string (gc_default_message));
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5286 args[1] = build_string ("...");
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5287 whole_msg = Fconcat (2, args);
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5288 echo_area_message (f, (Ibyte *) 0, whole_msg, 0, -1,
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5289 Qgarbage_collecting);
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5290 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5291 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5292 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5293
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5294 /***** Now we actually start the garbage collection. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5295
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5296 gc_in_progress = 1;
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
5297 inhibit_non_essential_conversion_operations = 1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5298
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5299 gc_generation_number[0]++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5300
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5301 #if MAX_SAVE_STACK > 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5302
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5303 /* Save a copy of the contents of the stack, for debugging. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5304 if (!purify_flag)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5305 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5306 /* Static buffer in which we save a copy of the C stack at each GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5307 static char *stack_copy;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
5308 static Bytecount stack_copy_size;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5309
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5310 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
5311 Bytecount stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5312 if (stack_size < MAX_SAVE_STACK)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5313 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5314 if (stack_copy_size < stack_size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5315 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5316 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5317 stack_copy_size = stack_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5318 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5319
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5320 memcpy (stack_copy,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5321 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5322 stack_size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5323 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5324 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5325 #endif /* MAX_SAVE_STACK > 0 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5326
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5327 /* Do some totally ad-hoc resource clearing. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5328 /* #### generalize this? */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5329 clear_event_resource ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5330 cleanup_specifiers ();
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5331 cleanup_buffer_undo_lists ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5332
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5333 /* Mark all the special slots that serve as the roots of accessibility. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5334
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
5335 #ifdef USE_KKCC
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
5336 /* initialize kkcc stack */
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
5337 kkcc_gc_stack_init();
2645
e6854ec89f8e [xemacs-hg @ 2005-03-10 09:12:36 by crestani]
crestani
parents: 2551
diff changeset
5338 #define mark_object(obj) kkcc_gc_stack_push_lisp_object (obj, 0, -1)
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
5339 #endif /* USE_KKCC */
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
5340
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5341 { /* staticpro() */
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
5342 Lisp_Object **p = Dynarr_begin (staticpros);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
5343 Elemcount count;
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
5344 for (count = Dynarr_length (staticpros); count; count--)
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
5345 mark_object (**p++);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
5346 }
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
5347
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
5348 { /* staticpro_nodump() */
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
5349 Lisp_Object **p = Dynarr_begin (staticpros_nodump);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
5350 Elemcount count;
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
5351 for (count = Dynarr_length (staticpros_nodump); count; count--)
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
5352 mark_object (**p++);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5353 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5354
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5355 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5356 { /* mcpro () */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5357 Lisp_Object *p = Dynarr_begin (mcpros);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5358 Elemcount count;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5359 for (count = Dynarr_length (mcpros); count; count--)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5360 mark_object (*p++);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5361 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5362 #endif /* MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5363
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5364 { /* GCPRO() */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5365 struct gcpro *tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5366 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5367 for (tail = gcprolist; tail; tail = tail->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5368 for (i = 0; i < tail->nvars; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5369 mark_object (tail->var[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5370 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5371
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5372 { /* specbind() */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5373 struct specbinding *bind;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5374 for (bind = specpdl; bind != specpdl_ptr; bind++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5375 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5376 mark_object (bind->symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5377 mark_object (bind->old_value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5378 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5379 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5380
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5381 {
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5382 struct catchtag *c;
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5383 for (c = catchlist; c; c = c->next)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5384 {
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5385 mark_object (c->tag);
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5386 mark_object (c->val);
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5387 mark_object (c->actual_tag);
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5388 mark_object (c->backtrace);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5389 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5390 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5391
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5392 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5393 struct backtrace *backlist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5394 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5395 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5396 int nargs = backlist->nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5397 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5398
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5399 mark_object (*backlist->function);
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
5400 if (nargs < 0 /* nargs == UNEVALLED || nargs == MANY */
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
5401 /* might be fake (internal profiling entry) */
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
5402 && backlist->args)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5403 mark_object (backlist->args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5404 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5405 for (i = 0; i < nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5406 mark_object (backlist->args[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5407 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5408 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5409
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5410 mark_profiling_info ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5411
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5412 /* OK, now do the after-mark stuff. This is for things that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5413 are only marked when something else is marked (e.g. weak hash tables).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5414 There may be complex dependencies between such objects -- e.g.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5415 a weak hash table might be unmarked, but after processing a later
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5416 weak hash table, the former one might get marked. So we have to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5417 iterate until nothing more gets marked. */
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
5418 #ifdef USE_KKCC
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
5419 kkcc_marking ();
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
5420 #endif /* USE_KKCC */
1590
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1550
diff changeset
5421 init_marking_ephemerons ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5422 while (finish_marking_weak_hash_tables () > 0 ||
887
ccc3177ef10b [xemacs-hg @ 2002-06-28 14:21:41 by michaels]
michaels
parents: 872
diff changeset
5423 finish_marking_weak_lists () > 0 ||
1590
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1550
diff changeset
5424 continue_marking_ephemerons () > 0)
1773
aa0db78e67c4 [xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents: 1739
diff changeset
5425 #ifdef USE_KKCC
aa0db78e67c4 [xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents: 1739
diff changeset
5426 {
aa0db78e67c4 [xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents: 1739
diff changeset
5427 kkcc_marking ();
aa0db78e67c4 [xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents: 1739
diff changeset
5428 }
aa0db78e67c4 [xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents: 1739
diff changeset
5429 #else /* NOT USE_KKCC */
1590
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1550
diff changeset
5430 ;
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
5431 #endif /* USE_KKCC */
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
5432
1590
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1550
diff changeset
5433 /* At this point, we know which objects need to be finalized: we
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1550
diff changeset
5434 still need to resurrect them */
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1550
diff changeset
5435
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1550
diff changeset
5436 while (finish_marking_ephemerons () > 0 ||
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1550
diff changeset
5437 finish_marking_weak_lists () > 0 ||
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1550
diff changeset
5438 finish_marking_weak_hash_tables () > 0)
1643
763f577d57b0 [xemacs-hg @ 2003-08-25 20:53:58 by crestani]
crestani
parents: 1634
diff changeset
5439 #ifdef USE_KKCC
1773
aa0db78e67c4 [xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents: 1739
diff changeset
5440 {
aa0db78e67c4 [xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents: 1739
diff changeset
5441 kkcc_marking ();
aa0db78e67c4 [xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents: 1739
diff changeset
5442 }
1643
763f577d57b0 [xemacs-hg @ 2003-08-25 20:53:58 by crestani]
crestani
parents: 1634
diff changeset
5443 kkcc_gc_stack_free ();
1676
a72f7bf813c9 [xemacs-hg @ 2003-09-11 09:11:07 by crestani]
crestani
parents: 1643
diff changeset
5444 #undef mark_object
1773
aa0db78e67c4 [xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents: 1739
diff changeset
5445 #else /* NOT USE_KKCC */
aa0db78e67c4 [xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents: 1739
diff changeset
5446 ;
1643
763f577d57b0 [xemacs-hg @ 2003-08-25 20:53:58 by crestani]
crestani
parents: 1634
diff changeset
5447 #endif /* USE_KKCC */
763f577d57b0 [xemacs-hg @ 2003-08-25 20:53:58 by crestani]
crestani
parents: 1634
diff changeset
5448
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5449 /* And prune (this needs to be called after everything else has been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5450 marked and before we do any sweeping). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5451 /* #### this is somewhat ad-hoc and should probably be an object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5452 method */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5453 prune_weak_hash_tables ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5454 prune_weak_lists ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5455 prune_specifiers ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5456 prune_syntax_tables ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5457
887
ccc3177ef10b [xemacs-hg @ 2002-06-28 14:21:41 by michaels]
michaels
parents: 872
diff changeset
5458 prune_ephemerons ();
858
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 853
diff changeset
5459 prune_weak_boxes ();
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 853
diff changeset
5460
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5461 gc_sweep ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5462
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5463 consing_since_gc = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5464 #ifndef DEBUG_XEMACS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5465 /* Allow you to set it really fucking low if you really want ... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5466 if (gc_cons_threshold < 10000)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5467 gc_cons_threshold = 10000;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5468 #endif
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
5469 recompute_need_to_garbage_collect ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5470
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
5471 inhibit_non_essential_conversion_operations = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5472 gc_in_progress = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5473
611
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5474 run_post_gc_actions ();
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
5475
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5476 /******* End of garbage collection ********/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5477
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5478 /* Now remove the GC cursor/message */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5479 if (!noninteractive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5480 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5481 if (cursor_changed)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5482 Fset_frame_pointer (wrap_frame (f), pre_gc_cursor);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5483 else if (!FRAME_STREAM_P (f))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5484 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5485 /* Show "...done" only if the echo area would otherwise be empty. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5486 if (NILP (clear_echo_area (selected_frame (),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5487 Qgarbage_collecting, 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5488 {
1154
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5489 if (garbage_collection_messages)
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5490 {
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5491 Lisp_Object args[2], whole_msg;
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5492 args[0] = (STRINGP (Vgc_message) ? Vgc_message :
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5493 build_msg_string (gc_default_message));
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5494 args[1] = build_msg_string ("... done");
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5495 whole_msg = Fconcat (2, args);
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5496 echo_area_message (selected_frame (), (Ibyte *) 0,
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5497 whole_msg, 0, -1,
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5498 Qgarbage_collecting);
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
5499 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5500 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5501 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5502 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5503
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5504 /* now stop inhibiting GC */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5505 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5506
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5507 #ifndef MC_ALLOC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5508 if (!breathing_space)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5509 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5510 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5511 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5512 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5513
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5514 UNGCPRO;
887
ccc3177ef10b [xemacs-hg @ 2002-06-28 14:21:41 by michaels]
michaels
parents: 872
diff changeset
5515
ccc3177ef10b [xemacs-hg @ 2002-06-28 14:21:41 by michaels]
michaels
parents: 872
diff changeset
5516 need_to_signal_post_gc = 1;
ccc3177ef10b [xemacs-hg @ 2002-06-28 14:21:41 by michaels]
michaels
parents: 872
diff changeset
5517 funcall_allocation_flag = 1;
ccc3177ef10b [xemacs-hg @ 2002-06-28 14:21:41 by michaels]
michaels
parents: 872
diff changeset
5518
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
5519 PROFILE_RECORD_EXITING_SECTION (QSin_garbage_collection);
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
5520
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5521 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5522 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5523
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5524 #ifdef ALLOC_TYPE_STATS
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5525
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5526 static Lisp_Object
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5527 gc_plist_hack (const Ascbyte *name, EMACS_INT value, Lisp_Object tail)
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5528 {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5529 /* C doesn't have local functions (or closures, or GC, or readable syntax,
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5530 or portable numeric datatypes, or bit-vectors, or characters, or
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5531 arrays, or exceptions, or ...) */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5532 return cons3 (intern (name), make_int (value), tail);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5533 }
2775
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
5534
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5535 static Lisp_Object
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5536 object_memory_usage_stats (int set_total_gc_usage)
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5537 {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5538 Lisp_Object pl = Qnil;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5539 int i;
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5540 EMACS_INT tgu_val = 0;
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5541
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5542 #ifdef MC_ALLOC
2775
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
5543
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5544 for (i = 0; i < (countof (lrecord_implementations_table)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5545 + MODULE_DEFINABLE_TYPE_COUNT); i++)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5546 {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5547 if (lrecord_stats[i].instances_in_use != 0)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5548 {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5549 char buf [255];
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5550 const char *name = lrecord_implementations_table[i]->name;
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5551 int len = strlen (name);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5552
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5553 if (lrecord_stats[i].bytes_in_use_including_overhead !=
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5554 lrecord_stats[i].bytes_in_use)
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5555 {
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5556 sprintf (buf, "%s-storage-including-overhead", name);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5557 pl = gc_plist_hack (buf,
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5558 lrecord_stats[i]
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5559 .bytes_in_use_including_overhead,
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5560 pl);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5561 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5562
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5563 sprintf (buf, "%s-storage", name);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5564 pl = gc_plist_hack (buf,
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5565 lrecord_stats[i].bytes_in_use,
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5566 pl);
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5567 tgu_val += lrecord_stats[i].bytes_in_use_including_overhead;
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5568
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5569 if (name[len-1] == 's')
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5570 sprintf (buf, "%ses-used", name);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5571 else
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5572 sprintf (buf, "%ss-used", name);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5573 pl = gc_plist_hack (buf, lrecord_stats[i].instances_in_use, pl);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5574 }
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5575 }
2775
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
5576 pl = gc_plist_hack ("string-data-storage-including-overhead",
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
5577 lrecord_string_data_bytes_in_use_including_overhead, pl);
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
5578 pl = gc_plist_hack ("string-data-storage-additional",
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
5579 lrecord_string_data_bytes_in_use, pl);
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
5580 pl = gc_plist_hack ("string-data-used",
05d62157e048 [xemacs-hg @ 2005-05-15 16:37:52 by crestani]
crestani
parents: 2720
diff changeset
5581 lrecord_string_data_instances_in_use, pl);
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5582 tgu_val += lrecord_string_data_bytes_in_use_including_overhead;
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5583
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5584 #else /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5585
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5586 #define HACK_O_MATIC(type, name, pl) do { \
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5587 EMACS_INT s = 0; \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5588 struct type##_block *x = current_##type##_block; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5589 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5590 tgu_val += s; \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5591 (pl) = gc_plist_hack ((name), s, (pl)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5592 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5593
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5594 for (i = 0; i < lrecord_type_count; i++)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5595 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5596 if (lcrecord_stats[i].bytes_in_use != 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5597 || lcrecord_stats[i].bytes_freed != 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5598 || lcrecord_stats[i].instances_on_free_list != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5599 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5600 char buf [255];
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5601 const char *name = lrecord_implementations_table[i]->name;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5602 int len = strlen (name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5603
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5604 sprintf (buf, "%s-storage", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5605 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5606 tgu_val += lcrecord_stats[i].bytes_in_use;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5607 /* Okay, simple pluralization check for `symbol-value-varalias' */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5608 if (name[len-1] == 's')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5609 sprintf (buf, "%ses-freed", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5610 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5611 sprintf (buf, "%ss-freed", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5612 if (lcrecord_stats[i].instances_freed != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5613 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5614 if (name[len-1] == 's')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5615 sprintf (buf, "%ses-on-free-list", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5616 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5617 sprintf (buf, "%ss-on-free-list", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5618 if (lcrecord_stats[i].instances_on_free_list != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5619 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5620 pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5621 if (name[len-1] == 's')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5622 sprintf (buf, "%ses-used", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5623 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5624 sprintf (buf, "%ss-used", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5625 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5626 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5627 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5628
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5629 HACK_O_MATIC (extent, "extent-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5630 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5631 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5632 HACK_O_MATIC (event, "event-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5633 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5634 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5635 HACK_O_MATIC (marker, "marker-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5636 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5637 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5638 HACK_O_MATIC (float, "float-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5639 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5640 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5641 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5642 HACK_O_MATIC (bignum, "bignum-storage", pl);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5643 pl = gc_plist_hack ("bignums-free", gc_count_num_bignum_freelist, pl);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5644 pl = gc_plist_hack ("bignums-used", gc_count_num_bignum_in_use, pl);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5645 #endif /* HAVE_BIGNUM */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5646 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5647 HACK_O_MATIC (ratio, "ratio-storage", pl);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5648 pl = gc_plist_hack ("ratios-free", gc_count_num_ratio_freelist, pl);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5649 pl = gc_plist_hack ("ratios-used", gc_count_num_ratio_in_use, pl);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5650 #endif /* HAVE_RATIO */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5651 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5652 HACK_O_MATIC (bigfloat, "bigfloat-storage", pl);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5653 pl = gc_plist_hack ("bigfloats-free", gc_count_num_bigfloat_freelist, pl);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5654 pl = gc_plist_hack ("bigfloats-used", gc_count_num_bigfloat_in_use, pl);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
5655 #endif /* HAVE_BIGFLOAT */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5656 HACK_O_MATIC (string, "string-header-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5657 pl = gc_plist_hack ("long-strings-total-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5658 gc_count_string_total_size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5659 - gc_count_short_string_total_size, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5660 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5661 pl = gc_plist_hack ("short-strings-total-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5662 gc_count_short_string_total_size, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5663 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5664 pl = gc_plist_hack ("long-strings-used",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5665 gc_count_num_string_in_use
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5666 - gc_count_num_short_string_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5667 pl = gc_plist_hack ("short-strings-used",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5668 gc_count_num_short_string_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5669
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5670 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5671 pl = gc_plist_hack ("compiled-functions-free",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5672 gc_count_num_compiled_function_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5673 pl = gc_plist_hack ("compiled-functions-used",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5674 gc_count_num_compiled_function_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5675
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5676 HACK_O_MATIC (symbol, "symbol-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5677 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5678 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5679
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5680 HACK_O_MATIC (cons, "cons-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5681 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5682 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5683
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5684 #undef HACK_O_MATIC
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5685
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5686 #endif /* MC_ALLOC */
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5687
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5688 if (set_total_gc_usage)
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5689 {
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5690 total_gc_usage = tgu_val;
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5691 total_gc_usage_set = 1;
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5692 }
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5693
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5694 return pl;
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5695 }
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5696
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5697 DEFUN("object-memory-usage-stats", Fobject_memory_usage_stats, 0, 0 ,"", /*
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5698 Return statistics about memory usage of Lisp objects.
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5699 */
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5700 ())
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5701 {
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5702 return object_memory_usage_stats (0);
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5703 }
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5704
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5705 #endif /* ALLOC_TYPE_STATS */
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5706
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5707 /* Debugging aids. */
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5708
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5709 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5710 Reclaim storage for Lisp objects no longer needed.
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5711 Return info on amount of space in use:
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5712 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5713 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5714 PLIST)
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5715 where `PLIST' is a list of alternating keyword/value pairs providing
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5716 more detailed information.
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5717 Garbage collection happens automatically if you cons more than
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5718 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5719 */
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5720 ())
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5721 {
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5722 /* Record total usage for purposes of determining next GC */
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5723 garbage_collect_1 ();
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5724
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5725 /* This will get set to 1, and total_gc_usage computed, as part of the
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5726 call to object_memory_usage_stats() -- if ALLOC_TYPE_STATS is enabled. */
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5727 total_gc_usage_set = 0;
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5728 #ifdef ALLOC_TYPE_STATS
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5729 /* The things we do for backwards-compatibility */
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5730 #ifdef MC_ALLOC
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5731 return
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5732 list6
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5733 (Fcons (make_int (lrecord_stats[lrecord_type_cons].instances_in_use),
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5734 make_int (lrecord_stats[lrecord_type_cons]
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5735 .bytes_in_use_including_overhead)),
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5736 Fcons (make_int (lrecord_stats[lrecord_type_symbol].instances_in_use),
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5737 make_int (lrecord_stats[lrecord_type_symbol]
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5738 .bytes_in_use_including_overhead)),
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5739 Fcons (make_int (lrecord_stats[lrecord_type_marker].instances_in_use),
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5740 make_int (lrecord_stats[lrecord_type_marker]
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5741 .bytes_in_use_including_overhead)),
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5742 make_int (lrecord_stats[lrecord_type_string]
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5743 .bytes_in_use_including_overhead),
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5744 make_int (lrecord_stats[lrecord_type_vector]
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5745 .bytes_in_use_including_overhead),
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5746 object_memory_usage_stats (1));
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5747 #else /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5748 return
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5749 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5750 make_int (gc_count_num_cons_freelist)),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5751 Fcons (make_int (gc_count_num_symbol_in_use),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5752 make_int (gc_count_num_symbol_freelist)),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5753 Fcons (make_int (gc_count_num_marker_in_use),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5754 make_int (gc_count_num_marker_freelist)),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5755 make_int (gc_count_string_total_size),
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5756 make_int (lcrecord_stats[lrecord_type_vector].bytes_in_use +
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5757 lcrecord_stats[lrecord_type_vector].bytes_freed),
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5758 object_memory_usage_stats (1));
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5759 #endif /* not MC_ALLOC */
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5760 #else /* not ALLOC_TYPE_STATS */
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5761 return Qnil;
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5762 #endif /* ALLOC_TYPE_STATS */
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5763 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5764
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5765 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5766 Return the number of bytes consed since the last garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5767 \"Consed\" is a misnomer in that this actually counts allocation
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5768 of all different kinds of objects, not just conses.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5769
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5770 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5771 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5772 ())
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5773 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5774 return make_int (consing_since_gc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5775 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5776
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
5777 #if 0
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
5778 DEFUN ("memory-limit", Fmemory_limit, 0, 0, 0, /*
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5779 Return the address of the last byte XEmacs has allocated, divided by 1024.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5780 This may be helpful in debugging XEmacs's memory usage.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5781 The value is divided by 1024 to make sure it will fit in a lisp integer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5782 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5783 ())
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5784 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5785 return make_int ((EMACS_INT) sbrk (0) / 1024);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5786 }
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
5787 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5788
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5789 DEFUN ("total-memory-usage", Ftotal_memory_usage, 0, 0, 0, /*
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5790 Return the total number of bytes used by the data segment in XEmacs.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5791 This may be helpful in debugging XEmacs's memory usage.
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5792 NOTE: This may or may not be accurate! It is hard to determine this
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5793 value in a system-independent fashion. On Windows, for example, the
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5794 returned number tends to be much greater than reality.
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5795 */
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5796 ())
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5797 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5798 return make_int (total_data_usage ());
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5799 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5800
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5801 #ifdef ALLOC_TYPE_STATS
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5802 DEFUN ("object-memory-usage", Fobject_memory_usage, 0, 0, 0, /*
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5803 Return total number of bytes used for object storage in XEmacs.
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5804 This may be helpful in debugging XEmacs's memory usage.
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5805 See also `consing-since-gc' and `object-memory-usage-stats'.
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5806 */
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5807 ())
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5808 {
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5809 return make_int (total_gc_usage + consing_since_gc);
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5810 }
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5811 #endif /* ALLOC_TYPE_STATS */
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5812
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
5813 void
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
5814 recompute_funcall_allocation_flag (void)
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
5815 {
887
ccc3177ef10b [xemacs-hg @ 2002-06-28 14:21:41 by michaels]
michaels
parents: 872
diff changeset
5816 funcall_allocation_flag =
ccc3177ef10b [xemacs-hg @ 2002-06-28 14:21:41 by michaels]
michaels
parents: 872
diff changeset
5817 need_to_garbage_collect ||
ccc3177ef10b [xemacs-hg @ 2002-06-28 14:21:41 by michaels]
michaels
parents: 872
diff changeset
5818 need_to_check_c_alloca ||
ccc3177ef10b [xemacs-hg @ 2002-06-28 14:21:41 by michaels]
michaels
parents: 872
diff changeset
5819 need_to_signal_post_gc;
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
5820 }
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
5821
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5822 /* True if it's time to garbage collect now. */
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
5823 static void
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
5824 recompute_need_to_garbage_collect (void)
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5825 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5826 if (always_gc)
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
5827 need_to_garbage_collect = 1;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
5828 else
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
5829 need_to_garbage_collect =
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
5830 (consing_since_gc > gc_cons_threshold
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5831 &&
2971
fb22a4eb2694 [xemacs-hg @ 2005-10-04 16:47:10 by stephent]
stephent
parents: 2970
diff changeset
5832 #if 0 /* #### implement this better */
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
5833 (100 * consing_since_gc) / total_data_usage () >=
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
5834 gc_cons_percentage
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5835 #else
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5836 (!total_gc_usage_set ||
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5837 (100 * consing_since_gc) / total_gc_usage >=
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5838 gc_cons_percentage)
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
5839 #endif
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
5840 );
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
5841 recompute_funcall_allocation_flag ();
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5842 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
5843
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5844
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5845 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5846 object_dead_p (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5847 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5848 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5849 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5850 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5851 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5852 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5853 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5854 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5855 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5856
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5857 #ifdef MEMORY_USAGE_STATS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5858
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5859 /* Attempt to determine the actual amount of space that is used for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5860 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5861
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5862 It seems that the following holds:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5863
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5864 1. When using the old allocator (malloc.c):
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5865
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5866 -- blocks are always allocated in chunks of powers of two. For
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5867 each block, there is an overhead of 8 bytes if rcheck is not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5868 defined, 20 bytes if it is defined. In other words, a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5869 one-byte allocation needs 8 bytes of overhead for a total of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5870 9 bytes, and needs to have 16 bytes of memory chunked out for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5871 it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5872
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5873 2. When using the new allocator (gmalloc.c):
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5874
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5875 -- blocks are always allocated in chunks of powers of two up
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5876 to 4096 bytes. Larger blocks are allocated in chunks of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5877 an integral multiple of 4096 bytes. The minimum block
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5878 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5879 is defined. There is no per-block overhead, but there
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5880 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5881 allocated.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5882
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5883 3. When using the system malloc, anything goes, but they are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5884 generally slower and more space-efficient than the GNU
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5885 allocators. One possibly reasonable assumption to make
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5886 for want of better data is that sizeof (void *), or maybe
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5887 2 * sizeof (void *), is required as overhead and that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5888 blocks are allocated in the minimum required size except
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5889 that some minimum block size is imposed (e.g. 16 bytes). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5890
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
5891 Bytecount
2286
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2260
diff changeset
5892 malloced_storage_size (void *UNUSED (ptr), Bytecount claimed_size,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5893 struct overhead_stats *stats)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5894 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
5895 Bytecount orig_claimed_size = claimed_size;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5896
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5897 #ifdef GNU_MALLOC
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
5898 if (claimed_size < (Bytecount) (2 * sizeof (void *)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5899 claimed_size = 2 * sizeof (void *);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5900 # ifdef SUNOS_LOCALTIME_BUG
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5901 if (claimed_size < 16)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5902 claimed_size = 16;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5903 # endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5904 if (claimed_size < 4096)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5905 {
2260
f913c1545598 [xemacs-hg @ 2004-09-10 18:46:58 by james]
james
parents: 1983
diff changeset
5906 /* fxg: rename log->log2 to supress gcc3 shadow warning */
f913c1545598 [xemacs-hg @ 2004-09-10 18:46:58 by james]
james
parents: 1983
diff changeset
5907 int log2 = 1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5908
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5909 /* compute the log base two, more or less, then use it to compute
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5910 the block size needed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5911 claimed_size--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5912 /* It's big, it's heavy, it's wood! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5913 while ((claimed_size /= 2) != 0)
2260
f913c1545598 [xemacs-hg @ 2004-09-10 18:46:58 by james]
james
parents: 1983
diff changeset
5914 ++log2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5915 claimed_size = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5916 /* It's better than bad, it's good! */
2260
f913c1545598 [xemacs-hg @ 2004-09-10 18:46:58 by james]
james
parents: 1983
diff changeset
5917 while (log2 > 0)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5918 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5919 claimed_size *= 2;
2260
f913c1545598 [xemacs-hg @ 2004-09-10 18:46:58 by james]
james
parents: 1983
diff changeset
5920 log2--;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5921 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5922 /* We have to come up with some average about the amount of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5923 blocks used. */
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
5924 if ((Bytecount) (rand () & 4095) < claimed_size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5925 claimed_size += 3 * sizeof (void *);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5926 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5927 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5928 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5929 claimed_size += 4095;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5930 claimed_size &= ~4095;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5931 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5932 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5933
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5934 #elif defined (SYSTEM_MALLOC)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5935
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5936 if (claimed_size < 16)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5937 claimed_size = 16;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5938 claimed_size += 2 * sizeof (void *);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5939
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5940 #else /* old GNU allocator */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5941
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5942 # ifdef rcheck /* #### may not be defined here */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5943 claimed_size += 20;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5944 # else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5945 claimed_size += 8;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5946 # endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5947 {
2260
f913c1545598 [xemacs-hg @ 2004-09-10 18:46:58 by james]
james
parents: 1983
diff changeset
5948 /* fxg: rename log->log2 to supress gcc3 shadow warning */
f913c1545598 [xemacs-hg @ 2004-09-10 18:46:58 by james]
james
parents: 1983
diff changeset
5949 int log2 = 1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5950
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5951 /* compute the log base two, more or less, then use it to compute
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5952 the block size needed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5953 claimed_size--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5954 /* It's big, it's heavy, it's wood! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5955 while ((claimed_size /= 2) != 0)
2260
f913c1545598 [xemacs-hg @ 2004-09-10 18:46:58 by james]
james
parents: 1983
diff changeset
5956 ++log2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5957 claimed_size = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5958 /* It's better than bad, it's good! */
2260
f913c1545598 [xemacs-hg @ 2004-09-10 18:46:58 by james]
james
parents: 1983
diff changeset
5959 while (log2 > 0)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5960 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5961 claimed_size *= 2;
2260
f913c1545598 [xemacs-hg @ 2004-09-10 18:46:58 by james]
james
parents: 1983
diff changeset
5962 log2--;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5963 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5964 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5965
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5966 #endif /* old GNU allocator */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5967
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5968 if (stats)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5969 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5970 stats->was_requested += orig_claimed_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5971 stats->malloc_overhead += claimed_size - orig_claimed_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5972 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5973 return claimed_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5974 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5975
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5976 #ifndef MC_ALLOC
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
5977 Bytecount
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
5978 fixed_type_block_overhead (Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5979 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
5980 Bytecount per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
5981 Bytecount overhead = 0;
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
5982 Bytecount storage_size = malloced_storage_size (0, per_block, 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5983 while (size >= per_block)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5984 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5985 size -= per_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5986 overhead += sizeof (void *) + per_block - storage_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5987 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5988 if (rand () % per_block < size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5989 overhead += sizeof (void *) + per_block - storage_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5990 return overhead;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5991 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
5992 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5993 #endif /* MEMORY_USAGE_STATS */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5994
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5995
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5996 /* Initialization */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
5997 static void
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
5998 common_init_alloc_early (void)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5999 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6000 #ifndef Qzero
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6001 Qzero = make_int (0); /* Only used if Lisp_Object is a union type */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6002 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6003
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6004 #ifndef Qnull_pointer
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6005 /* C guarantees that Qnull_pointer will be initialized to all 0 bits,
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6006 so the following is actually a no-op. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
6007 Qnull_pointer = wrap_pointer_1 (0);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6008 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6009
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6010 gc_generation_number[0] = 0;
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6011 #ifndef MC_ALLOC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6012 breathing_space = 0;
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6013 #endif /* not MC_ALLOC */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6014 Vgc_message = Qzero;
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6015 #ifndef MC_ALLOC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6016 all_lcrecords = 0;
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6017 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6018 ignore_malloc_warnings = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6019 #ifdef DOUG_LEA_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6020 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6021 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6022 #if 0 /* Moved to emacs.c */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6023 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6024 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6025 #endif
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6026 init_string_chars_alloc ();
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6027 #ifndef MC_ALLOC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6028 init_string_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6029 init_string_chars_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6030 init_cons_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6031 init_symbol_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6032 init_compiled_function_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6033 init_float_alloc ();
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
6034 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
6035 init_bignum_alloc ();
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
6036 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
6037 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
6038 init_ratio_alloc ();
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
6039 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
6040 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
6041 init_bigfloat_alloc ();
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1957
diff changeset
6042 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6043 init_marker_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6044 init_extent_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6045 init_event_alloc ();
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6046 #ifdef EVENT_DATA_AS_OBJECTS
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
6047 init_key_data_alloc ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
6048 init_button_data_alloc ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
6049 init_motion_data_alloc ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
6050 init_process_data_alloc ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
6051 init_timeout_data_alloc ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
6052 init_magic_data_alloc ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
6053 init_magic_eval_data_alloc ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
6054 init_eval_data_alloc ();
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 887
diff changeset
6055 init_misc_user_data_alloc ();
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6056 #endif /* EVENT_DATA_AS_OBJECTS */
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6057 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6058
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6059 ignore_malloc_warnings = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6060
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
6061 if (staticpros_nodump)
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
6062 Dynarr_free (staticpros_nodump);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
6063 staticpros_nodump = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
6064 Dynarr_resize (staticpros_nodump, 100); /* merely a small optimization */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6065 #ifdef DEBUG_XEMACS
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6066 if (staticpro_nodump_names)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6067 Dynarr_free (staticpro_nodump_names);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6068 staticpro_nodump_names = Dynarr_new2 (char_ptr_dynarr, char *);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6069 Dynarr_resize (staticpro_nodump_names, 100); /* ditto */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6070 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6071
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6072 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6073 mcpros = Dynarr_new2 (Lisp_Object_dynarr, Lisp_Object);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6074 Dynarr_resize (mcpros, 1410); /* merely a small optimization */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6075 dump_add_root_block_ptr (&mcpros, &mcpros_description);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6076 #ifdef DEBUG_XEMACS
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6077 mcpro_names = Dynarr_new2 (char_ptr_dynarr, char *);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6078 Dynarr_resize (mcpro_names, 1410); /* merely a small optimization */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6079 dump_add_root_block_ptr (&mcpro_names, &mcpro_names_description);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6080 #endif
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6081 #endif /* MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6082
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6083 consing_since_gc = 0;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
6084 need_to_garbage_collect = always_gc;
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
6085 need_to_check_c_alloca = 0;
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
6086 funcall_allocation_flag = 0;
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
6087 funcall_alloca_count = 0;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
6088
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6089 #if 1
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
6090 gc_cons_threshold = 2000000; /* XEmacs change */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6091 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6092 gc_cons_threshold = 15000; /* debugging */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6093 #endif
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
6094 gc_cons_percentage = 40; /* #### what is optimal? */
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
6095 total_gc_usage_set = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6096 lrecord_uid_counter = 259;
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6097 #ifndef MC_ALLOC
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6098 debug_string_purity = 0;
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6099 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6100
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6101 gc_currently_forbidden = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6102 gc_hooks_inhibited = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6103
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
6104 #ifdef ERROR_CHECK_TYPES
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6105 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6106 666;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6107 ERROR_ME_NOT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6108 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6109 ERROR_ME_WARN.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6110 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6111 3333632;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
6112 ERROR_ME_DEBUG_WARN.
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
6113 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
6114 8675309;
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
6115 #endif /* ERROR_CHECK_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6116 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6117
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6118 #ifndef MC_ALLOC
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6119 static void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6120 init_lcrecord_lists (void)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6121 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6122 int i;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6123
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6124 for (i = 0; i < countof (lrecord_implementations_table); i++)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6125 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6126 all_lcrecord_lists[i] = Qzero; /* Qnil not yet set */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6127 staticpro_nodump (&all_lcrecord_lists[i]);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6128 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6129 }
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6130 #endif /* not MC_ALLOC */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6131
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6132 void
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6133 init_alloc_early (void)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6134 {
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6135 #if defined (__cplusplus) && defined (ERROR_CHECK_GC)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6136 static struct gcpro initial_gcpro;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6137
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6138 initial_gcpro.next = 0;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6139 initial_gcpro.var = &Qnil;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6140 initial_gcpro.nvars = 1;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6141 gcprolist = &initial_gcpro;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6142 #else
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6143 gcprolist = 0;
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6144 #endif /* defined (__cplusplus) && defined (ERROR_CHECK_GC) */
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6145 }
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6146
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6147 void
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6148 reinit_alloc_early (void)
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6149 {
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6150 common_init_alloc_early ();
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6151 #ifndef MC_ALLOC
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6152 init_lcrecord_lists ();
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6153 #endif /* not MC_ALLOC */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6154 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6155
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6156 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6157 init_alloc_once_early (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6158 {
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6159 common_init_alloc_early ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6160
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6161 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6162 int i;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6163 for (i = 0; i < countof (lrecord_implementations_table); i++)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6164 lrecord_implementations_table[i] = 0;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6165 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6166
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6167 INIT_LRECORD_IMPLEMENTATION (cons);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6168 INIT_LRECORD_IMPLEMENTATION (vector);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6169 INIT_LRECORD_IMPLEMENTATION (string);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6170 #ifndef MC_ALLOC
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6171 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1154
diff changeset
6172 INIT_LRECORD_IMPLEMENTATION (free);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6173 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6174
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
6175 staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
6176 Dynarr_resize (staticpros, 1410); /* merely a small optimization */
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
6177 dump_add_root_block_ptr (&staticpros, &staticpros_description);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6178 #ifdef DEBUG_XEMACS
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6179 staticpro_names = Dynarr_new2 (char_ptr_dynarr, char *);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6180 Dynarr_resize (staticpro_names, 1410); /* merely a small optimization */
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
6181 dump_add_root_block_ptr (&staticpro_names, &staticpro_names_description);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6182 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6183
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6184 #ifdef MC_ALLOC
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6185 mcpros = Dynarr_new2 (Lisp_Object_dynarr, Lisp_Object);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6186 Dynarr_resize (mcpros, 1410); /* merely a small optimization */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6187 dump_add_root_block_ptr (&mcpros, &mcpros_description);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6188 #ifdef DEBUG_XEMACS
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6189 mcpro_names = Dynarr_new2 (char_ptr_dynarr, char *);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6190 Dynarr_resize (mcpro_names, 1410); /* merely a small optimization */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6191 dump_add_root_block_ptr (&mcpro_names, &mcpro_names_description);
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6192 #endif
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6193 #endif /* MC_ALLOC */
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6194
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6195 #ifndef MC_ALLOC
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
6196 init_lcrecord_lists ();
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2666
diff changeset
6197 #endif /* not MC_ALLOC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6198 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6199
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6200 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6201 syms_of_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6202 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6203 DEFSYMBOL (Qpre_gc_hook);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6204 DEFSYMBOL (Qpost_gc_hook);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6205 DEFSYMBOL (Qgarbage_collecting);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6206
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6207 DEFSUBR (Fcons);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6208 DEFSUBR (Flist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6209 DEFSUBR (Fvector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6210 DEFSUBR (Fbit_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6211 DEFSUBR (Fmake_byte_code);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6212 DEFSUBR (Fmake_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6213 DEFSUBR (Fmake_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6214 DEFSUBR (Fmake_bit_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6215 DEFSUBR (Fmake_string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6216 DEFSUBR (Fstring);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6217 DEFSUBR (Fmake_symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6218 DEFSUBR (Fmake_marker);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6219 DEFSUBR (Fpurecopy);
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
6220 #ifdef ALLOC_TYPE_STATS
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
6221 DEFSUBR (Fobject_memory_usage_stats);
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
6222 DEFSUBR (Fobject_memory_usage);
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
6223 #endif /* ALLOC_TYPE_STATS */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6224 DEFSUBR (Fgarbage_collect);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
6225 #if 0
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6226 DEFSUBR (Fmemory_limit);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
6227 #endif
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
6228 DEFSUBR (Ftotal_memory_usage);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6229 DEFSUBR (Fconsing_since_gc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6230 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6231
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6232 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6233 vars_of_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6234 {
1292
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
6235 QSin_garbage_collection = build_msg_string ("(in garbage collection)");
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
6236 staticpro (&QSin_garbage_collection);
f3437b56874d [xemacs-hg @ 2003-02-13 09:57:04 by ben]
ben
parents: 1276
diff changeset
6237
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6238 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6239 *Number of bytes of consing between garbage collections.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6240 \"Consing\" is a misnomer in that this actually counts allocation
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6241 of all different kinds of objects, not just conses.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6242 Garbage collection can happen automatically once this many bytes have been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6243 allocated since the last garbage collection. All data types count.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6244
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6245 Garbage collection happens automatically when `eval' or `funcall' are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6246 called. (Note that `funcall' is called implicitly as part of evaluation.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6247 By binding this temporarily to a large number, you can effectively
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6248 prevent garbage collection during a part of the program.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6249
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
6250 Normally, you cannot set this value less than 10,000 (if you do, it is
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
6251 automatically reset during the next garbage collection). However, if
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
6252 XEmacs was compiled with DEBUG_XEMACS, this does not happen, allowing
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
6253 you to set this value very low to track down problems with insufficient
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
6254 GCPRO'ing. If you set this to a negative number, garbage collection will
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
6255 happen at *EVERY* call to `eval' or `funcall'. This is an extremely
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
6256 effective way to check GCPRO problems, but be warned that your XEmacs
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
6257 will be unusable! You almost certainly won't have the patience to wait
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
6258 long enough to be able to set it back.
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
6259
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
6260 See also `consing-since-gc' and `gc-cons-percentage'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6261 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6262
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
6263 DEFVAR_INT ("gc-cons-percentage", &gc_cons_percentage /*
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
6264 *Percentage of memory allocated between garbage collections.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
6265
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
6266 Garbage collection will happen if this percentage of the total amount of
2994
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
6267 memory used for data (see `lisp-object-memory-usage') has been allocated
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
6268 since the last garbage collection. However, it will not happen if less
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
6269 than `gc-cons-threshold' bytes have been allocated -- this sets an absolute
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
6270 minimum in case very little data has been allocated or the percentage is
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
6271 set very low. Set this to 0 to have garbage collection always happen after
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
6272 `gc-cons-threshold' bytes have been allocated, regardless of current memory
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
6273 usage.
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
6274
ec5f23ea6d2e [xemacs-hg @ 2005-10-14 01:21:57 by ben]
ben
parents: 2971
diff changeset
6275 See also `consing-since-gc' and `gc-cons-threshold'.
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
6276 */ );
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
6277
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6278 #ifdef DEBUG_XEMACS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6279 DEFVAR_INT ("debug-allocation", &debug_allocation /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6280 If non-zero, print out information to stderr about all objects allocated.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6281 See also `debug-allocation-backtrace-length'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6282 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6283 debug_allocation = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6284
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6285 DEFVAR_INT ("debug-allocation-backtrace-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6286 &debug_allocation_backtrace_length /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6287 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6288 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6289 debug_allocation_backtrace_length = 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6290 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6291
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6292 DEFVAR_BOOL ("purify-flag", &purify_flag /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6293 Non-nil means loading Lisp code in order to dump an executable.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6294 This means that certain objects should be allocated in readonly space.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6295 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6296
1154
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
6297 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages /*
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
6298 Non-nil means display messages at start and end of garbage collection.
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
6299 */ );
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
6300 garbage_collection_messages = 0;
3136b3c99ceb [xemacs-hg @ 2002-12-12 03:20:35 by stephent]
stephent
parents: 1123
diff changeset
6301
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6302 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6303 Function or functions to be run just before each garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6304 Interrupts, garbage collection, and errors are inhibited while this hook
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6305 runs, so be extremely careful in what you add here. In particular, avoid
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6306 consing, and do not interact with the user.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6307 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6308 Vpre_gc_hook = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6309
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6310 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6311 Function or functions to be run just after each garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6312 Interrupts, garbage collection, and errors are inhibited while this hook
887
ccc3177ef10b [xemacs-hg @ 2002-06-28 14:21:41 by michaels]
michaels
parents: 872
diff changeset
6313 runs. Each hook is called with one argument which is an alist with
ccc3177ef10b [xemacs-hg @ 2002-06-28 14:21:41 by michaels]
michaels
parents: 872
diff changeset
6314 finalization data.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6315 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6316 Vpost_gc_hook = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6317
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6318 DEFVAR_LISP ("gc-message", &Vgc_message /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6319 String to print to indicate that a garbage collection is in progress.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6320 This is printed in the echo area. If the selected frame is on a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6321 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6322 image instance) in the domain of the selected frame, the mouse pointer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6323 will change instead of this message being printed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6324 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6325 Vgc_message = build_string (gc_default_message);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6326
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6327 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6328 Pointer glyph used to indicate that a garbage collection is in progress.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6329 If the selected window is on a window system and this glyph specifies a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6330 value (i.e. a pointer image instance) in the domain of the selected
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6331 window, the pointer will be changed as specified during garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6332 Otherwise, a message will be printed in the echo area, as controlled
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6333 by `gc-message'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6334 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6335 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6336
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6337 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6338 complex_vars_of_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6339 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6340 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6341 }