annotate src/alloc.c @ 844:047d37eb70d7

[xemacs-hg @ 2002-05-16 13:30:23 by ben] ui fixes for things that were bothering me bytecode.c, editfns.c, lisp.h, lread.c: Fix save-restriction to use markers rather than pseudo-markers (integers representing the amount of text on either side of the region). That way, all inserts are handled correctly, not just those inside old restriction. Add buffer argument to save_restriction_save(). process.c: Clean up very dirty and kludgy code that outputs into a buffer -- use proper unwind protects, etc. font-lock.c: Do save-restriction/widen around the function -- otherwise, incorrect results will ensue when a buffer has been narrowed before a call to e.g. `buffer-syntactic-context' -- something that happens quite often. fileio.c: Look for a handler for make-temp-name. window.c, winslots.h: Try to solve this annoying problem: have two frames displaying the buffer, in different places; in one, temporarily switch away to another buffer and then back -- and you've lost your position; it's reset to the other one in the other frame. My current solution involves window-level caches of buffers and points (also a cache for window-start); when set-window-buffer is called, it looks to see if the buffer was previously visited in the window, and if so, uses the most recent point at that time. (It's a marker, so it handles changes.) #### Note: It could be argued that doing it on the frame level would be better -- e.g. if you visit a buffer temporarily through a grep, and then go back to that buffer, you presumably want the grep's position rather than some previous position provided everything was in the same frame, even though the grep was in another window in the frame. However, doing it on the frame level fails when you have two windows on the same frame. Perhaps we keep both a window and a frame cache, and use the frame cache if there are no other windows on the frame showing the buffer, else the window's cache? This is probably something to be configurable using a specifier. Suggestions please please please? window.c: Clean up a bit code that deals with the annoyance of window-point vs. point. dialog.el: Function to ask a multiple-choice question, automatically choosing a dialog box or minibuffer representation as necessary. Generalized version of yes-or-no-p, y-or-n-p. files.el: Use get-user-response to ask "yes/no/diff" question when recovering. "diff" means that a diff is displayed between the current file and the autosave. (Converts/deconverts escape-quoted as necessary. No more complaints from you, Mr. Turnbull!) One known problem: when a dialog is used, it's modal, so you can't scroll the diff. Will fix soon. lisp-mode.el: If we're filling a string, don't treat semicolon as a comment, which would give very unfriendly results. Uses `buffer-syntactic-context'. simple.el: all changes back to the beginning. (Useful if you've saved the file in the middle of the changes.) simple.el: Add option kill-word-into-kill-ring, which controls whether words deleted with kill-word, backward-kill-word, etc. are "cut" into the kill ring, or "cleared" into nothingness. (My preference is the latter, by far. I'd almost go so far as suggesting we make it the default, as you can always select a word and then cut it if you want it cut.) menubar-items.el: Add option corresponding to kill-word-into-kill-ring.
author ben
date Thu, 16 May 2002 13:30:58 +0000
parents 6728e641994e
children e7ee5f8bde58
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.
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4 Copyright (C) 1995, 1996, 2001, 2002 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"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
52 #include "extents.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
53 #include "frame.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
54 #include "glyphs.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
55 #include "opaque.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
56 #include "redisplay.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
57 #include "specifier.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58 #include "sysfile.h"
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
59 #include "sysdep.h"
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60 #include "window.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61 #include "console-stream.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63 #ifdef DOUG_LEA_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
64 #include <malloc.h>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65 #endif
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 PDUMP
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
68 #include "dumper.h"
428
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;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
96 int need_to_garbage_collect;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
97
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
98 /* 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
99 Ffuncall() faster */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
100 #define INCREMENT_CONS_COUNTER_1(size) \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
101 do \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
102 { \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
103 consing_since_gc += (size); \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
104 recompute_need_to_garbage_collect (); \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
105 } while (0)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
106
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
107 #define debug_allocation_backtrace() \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
108 do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
109 if (debug_allocation_backtrace_length > 0) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110 debug_short_backtrace (debug_allocation_backtrace_length); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
111 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
112
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
113 #ifdef DEBUG_XEMACS
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
114 #define INCREMENT_CONS_COUNTER(foosize, type) \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
115 do { \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
116 if (debug_allocation) \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
117 { \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
118 stderr_out ("allocating %s (size %ld)\n", type, \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
119 (long) foosize); \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
120 debug_allocation_backtrace (); \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
121 } \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
122 INCREMENT_CONS_COUNTER_1 (foosize); \
428
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 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
125 do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
126 if (debug_allocation > 1) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
127 { \
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
128 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
129 (long) foosize); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 debug_allocation_backtrace (); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
132 INCREMENT_CONS_COUNTER_1 (foosize); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
133 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
134 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
135 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
136 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137 INCREMENT_CONS_COUNTER_1 (size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
140 #define DECREMENT_CONS_COUNTER(size) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
141 consing_since_gc -= (size); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
142 if (consing_since_gc < 0) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143 consing_since_gc = 0; \
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
144 recompute_need_to_garbage_collect (); \
428
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147 /* 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
148 static EMACS_INT gc_cons_threshold;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
149
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
150 /* 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
151 static EMACS_INT gc_cons_percentage;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
152
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
153 #ifdef ERROR_CHECK_GC
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
154 int always_gc; /* Debugging hack */
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
155 #else
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
156 #define always_gc 0
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
157 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
158
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
159 /* Nonzero during gc */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160 int gc_in_progress;
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 times GC has happened at this level or below.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163 * Level 0 is most volatile, contrary to usual convention.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164 * (Of course, there's only one level at present) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
165 EMACS_INT gc_generation_number[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
166
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
167 /* This is just for use by the printer, to allow things to print uniquely */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
168 static int lrecord_uid_counter;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
169
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
170 /* Nonzero when calling certain hooks or doing other things where
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
171 a GC would be bad */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
172 int gc_currently_forbidden;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
173
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
174 /* Hooks. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
175 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
177
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178 /* "Garbage collecting" */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179 Lisp_Object Vgc_message;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
180 Lisp_Object Vgc_pointer_glyph;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
181 static const Char_ASCII gc_default_message[] = "Garbage collecting";
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182 Lisp_Object Qgarbage_collecting;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
183
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
184 /* Non-zero means we're in the process of doing the dump */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
185 int purify_flag;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
186
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
187 #ifdef ERROR_CHECK_TYPES
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
188
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
189 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
190
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
192
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
193 /* 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
194 data. #### Need better (system-dependent) ways. */
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
195 void *minimum_address_seen;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
196 void *maximum_address_seen;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
197
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
198 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
199 c_readonly (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
200 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
201 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
202 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
203
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
204 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205 lisp_readonly (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
206 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
207 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
209
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
210
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
211 /* Maximum amount of C stack to save when a GC happens. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
212
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
213 #ifndef MAX_SAVE_STACK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
214 #define MAX_SAVE_STACK 0 /* 16000 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
215 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
216
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
217 /* Non-zero means ignore malloc warnings. Set during initialization. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
218 int ignore_malloc_warnings;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
219
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
220
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
221 static void *breathing_space;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
222
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
223 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
224 release_breathing_space (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
225 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
226 if (breathing_space)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
227 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
228 void *tmp = breathing_space;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229 breathing_space = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230 xfree (tmp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
231 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
234 /* malloc calls this if it finds we are near exhausting storage */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
235 void
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
236 malloc_warning (const char *str)
428
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 if (ignore_malloc_warnings)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
239 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
240
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
241 warn_when_safe
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
242 (Qmemory, Qemergency,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
243 "%s\n"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
244 "Killing some buffers may delay running out of memory.\n"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245 "However, certainly by the time you receive the 95%% warning,\n"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
246 "you should clean up, kill this Emacs, and start a new one.",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
247 str);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
250 /* Called if malloc returns zero */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
251 DOESNT_RETURN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252 memory_full (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254 /* Force a GC next time eval is called.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
255 It's better to loop garbage-collecting (we might reclaim enough
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
256 to win) than to loop beeping and barfing "Memory exhausted"
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 consing_since_gc = gc_cons_threshold + 1;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
259 recompute_need_to_garbage_collect ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
260 release_breathing_space ();
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 /* Flush some histories which might conceivably contain garbalogical
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
263 inhibitors. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
264 if (!NILP (Fboundp (Qvalues)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
265 Fset (Qvalues, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
266 Vcommand_history = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
267
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 551
diff changeset
268 out_of_memory ("Memory exhausted", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
269 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
270
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
271 static void
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
272 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
273 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
274 if (!val)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
275 return;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
276 if ((char *) val + size > (char *) maximum_address_seen)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
277 maximum_address_seen = (char *) val + size;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
278 if (!minimum_address_seen)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
279 minimum_address_seen =
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
280 #if SIZEOF_VOID_P == 8
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
281 (void *) 0xFFFFFFFFFFFFFFFF;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
282 #else
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
283 (void *) 0xFFFFFFFF;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
284 #endif
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
285 if ((char *) val < (char *) minimum_address_seen)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
286 minimum_address_seen = (char *) val;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
287 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
288
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
289 /* like malloc and realloc but check for no memory left. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
290
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
291 #undef xmalloc
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
292 void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
293 xmalloc (Bytecount size)
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 void *val = malloc (size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
296 if (!val && (size != 0)) memory_full ();
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
297 set_alloc_mins_and_maxes (val, size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
298 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
299 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
300
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
301 #undef xcalloc
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
302 static void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
303 xcalloc (Elemcount nelem, Bytecount elsize)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
304 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
305 void *val = calloc (nelem, elsize);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
306
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
307 if (!val && (nelem != 0)) memory_full ();
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
308 set_alloc_mins_and_maxes (val, nelem * elsize);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
309 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
310 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
311
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
312 void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
313 xmalloc_and_zero (Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
314 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
315 return xcalloc (size, sizeof (char));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
316 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
317
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
318 #undef xrealloc
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
319 void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
320 xrealloc (void *block, Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
321 {
551
e9a3f8b4de53 [xemacs-hg @ 2001-05-21 05:26:06 by martinb]
martinb
parents: 460
diff changeset
322 block = realloc (block, size);
e9a3f8b4de53 [xemacs-hg @ 2001-05-21 05:26:06 by martinb]
martinb
parents: 460
diff changeset
323
e9a3f8b4de53 [xemacs-hg @ 2001-05-21 05:26:06 by martinb]
martinb
parents: 460
diff changeset
324 if (!block && (size != 0)) memory_full ();
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
325 set_alloc_mins_and_maxes (block, size);
551
e9a3f8b4de53 [xemacs-hg @ 2001-05-21 05:26:06 by martinb]
martinb
parents: 460
diff changeset
326 return block;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
327 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
328
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
329 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
330 #ifdef ERROR_CHECK_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
331 xfree_1 (void *block)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
332 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
333 xfree (void *block)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
334 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
335 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
336 #ifdef ERROR_CHECK_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
337 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
338 error until much later on for many system mallocs, such as
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
339 the one that comes with Solaris 2.3. FMH!! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
340 assert (block != (void *) 0xDEADBEEF);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
341 assert (block);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
342 #endif /* ERROR_CHECK_MALLOC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
343 free (block);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
344 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
345
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
346 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
347
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
348 static void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
349 deadbeef_memory (void *ptr, Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
350 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
351 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
352 Bytecount beefs = size >> 2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
353
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
354 /* In practice, size will always be a multiple of four. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
355 while (beefs--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
356 (*ptr4++) = 0xDEADBEEF;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
357 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
358
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
359 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
360
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
361
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
362 #define deadbeef_memory(ptr, size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
363
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
364 #endif /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
365
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
366 #undef xstrdup
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
367 char *
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
368 xstrdup (const char *str)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
369 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
370 int len = strlen (str) + 1; /* for stupid terminating 0 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
371 void *val = xmalloc (len);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
372
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373 if (val == 0) return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374 return (char *) memcpy (val, str, len);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
375 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
376
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
377 #ifdef NEED_STRDUP
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
378 char *
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
379 strdup (const char *s)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381 return xstrdup (s);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
382 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383 #endif /* NEED_STRDUP */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
384
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
385
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
386 static void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
387 allocate_lisp_storage (Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
388 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
389 void *val = xmalloc (size);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
390 /* 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
391 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
392 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
393 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
394 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
395 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
396 get freed?) */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
397
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
398 /* 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
399 good thing, as it will guarantee we won't get any intermittent bugs
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
400 coming from an uninitiated field. The speed loss if unnoticeable,
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
401 esp. as the object are not large -- large stuff like buffer text and
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
402 redisplay structures and allocated separately. */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
403 memset (val, 0, size);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
404 return val;
428
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
408 /* lcrecords are chained together through their "next" field.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
409 After doing the mark phase, GC will walk this linked list
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
410 and free any lcrecord which hasn't been marked. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 static struct lcrecord_header *all_lcrecords;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
412
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
413 void *
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
414 alloc_lcrecord (Bytecount size,
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
415 const struct lrecord_implementation *implementation)
428
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 struct lcrecord_header *lcheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
418
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
419 type_checking_assert
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
420 ((implementation->static_size == 0 ?
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
421 implementation->size_in_bytes_method != NULL :
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
422 implementation->static_size == size)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
423 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
424 (! implementation->basic_p)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
425 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
426 (! (implementation->hash == NULL && implementation->equal != NULL)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
428 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
429 set_lheader_implementation (&lcheader->lheader, implementation);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
430 lcheader->next = all_lcrecords;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
431 #if 1 /* mly prefers to see small ID numbers */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
432 lcheader->uid = lrecord_uid_counter++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
433 #else /* jwz prefers to see real addrs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
434 lcheader->uid = (int) &lcheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
435 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
436 lcheader->free = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
437 all_lcrecords = lcheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
438 INCREMENT_CONS_COUNTER (size, implementation->name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
439 return lcheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
440 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
441
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
442 #if 0 /* Presently unused */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
443 /* Very, very poor man's EGC?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
444 * This may be slow and thrash pages all over the place.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
445 * Only call it if you really feel you must (and if the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
446 * lrecord was fairly recently allocated).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
447 * 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
448 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
449 void
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
450 very_old_free_lcrecord (struct lcrecord_header *lcrecord)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
451 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
452 if (all_lcrecords == lcrecord)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
453 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
454 all_lcrecords = lcrecord->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
455 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
456 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
457 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
458 struct lrecord_header *header = all_lcrecords;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
459 for (;;)
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 struct lrecord_header *next = header->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
462 if (next == lcrecord)
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 header->next = lrecord->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
465 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
466 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
467 else if (next == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
468 abort ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
469 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
470 header = next;
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
473 if (lrecord->implementation->finalizer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
474 lrecord->implementation->finalizer (lrecord, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
475 xfree (lrecord);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
476 return;
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 #endif /* Unused */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
479
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
480
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
481 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
482 disksave_object_finalization_1 (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
483 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
484 struct lcrecord_header *header;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
485
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
486 for (header = all_lcrecords; header; header = header->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
487 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
488 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
489 !header->free)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
490 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
491 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
492 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
493
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
494
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
495 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
496 /* Debugger support */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
497 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
498 /* Give gdb/dbx enough information to decode Lisp Objects. We make
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
499 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
500 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
501 to see how this is used. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
502
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
503 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
504 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
505
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
506 #ifdef USE_UNION_TYPE
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
507 unsigned char dbg_USE_UNION_TYPE = 1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
508 #else
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
509 unsigned char dbg_USE_UNION_TYPE = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
510 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
511
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
512 unsigned char dbg_valbits = VALBITS;
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
513 unsigned char dbg_gctypebits = GCTYPEBITS;
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
514
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
515 /* On some systems, the above definitions will be optimized away by
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
516 the compiler or linker unless they are referenced in some function. */
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
517 long dbg_inhibit_dbg_symbol_deletion (void);
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
518 long
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
519 dbg_inhibit_dbg_symbol_deletion (void)
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
520 {
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
521 return
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
522 (dbg_valmask +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
523 dbg_typemask +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
524 dbg_USE_UNION_TYPE +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
525 dbg_valbits +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
526 dbg_gctypebits);
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
527 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
528
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
529 /* Macros turned into functions for ease of debugging.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
530 Debuggers don't know about macros! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
531 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
532 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
533 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
534 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
535 return EQ (obj1, obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
536 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
537
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
538
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
539 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
540 /* Fixed-size type macros */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
541 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
542
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
543 /* For fixed-size types that are commonly used, we malloc() large blocks
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
544 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
545 size for an object of that type. This is more efficient than
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
546 malloc()ing each object separately because we save on malloc() time
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
547 and overhead due to the fewer number of malloc()ed blocks, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
548 also because we don't need any extra pointers within each object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
549 to keep them threaded together for GC purposes. For less common
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
550 (and frequently large-size) types, we use lcrecords, which are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
551 malloc()ed individually and chained together through a pointer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
552 in the lcrecord header. lcrecords do not need to be fixed-size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
553 (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
554 however, the size of a particular object cannot vary dynamically).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
555 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
556 additional code needs to be added to alloc.c. Finally, lcrecords
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
557 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
558
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
559 The types that are stored in these large blocks (or "frob blocks")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
560 are cons, float, compiled-function, symbol, marker, extent, event,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
561 and string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
562
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
563 Note that strings are special in that they are actually stored in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
564 two parts: a structure containing information about the string, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
565 the actual data associated with the string. The former structure
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
566 (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
567 same way as all the other such types. This structure contains a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
568 pointer to the actual string data, which is stored in structures of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
569 type struct string_chars_block. Each string_chars_block consists
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
570 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
571 string, followed by another pointer to a Lisp_String, followed by
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
572 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
573 blocks is compacted by searching sequentially through all the
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
574 blocks and compressing out any holes created by unmarked strings.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
575 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
576 a string_chars_block, although something like half as big might
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
577 make more sense) are malloc()ed separately and not stored in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
578 string_chars_blocks. Furthermore, no one string stretches across
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
579 two string_chars_blocks.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
580
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
581 Vectors are each malloc()ed separately, similar to lcrecords.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
582
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
583 In the following discussion, we use conses, but it applies equally
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
584 well to the other fixed-size types.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
585
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
586 We store cons cells inside of cons_blocks, allocating a new
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
587 cons_block with malloc() whenever necessary. Cons cells reclaimed
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
588 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
589 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
590 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
591 the versions in malloc.c and gmalloc.c) really allocates in units
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
592 of powers of two and uses 4 bytes for its own overhead.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
593
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
594 What GC actually does is to search through all the cons_blocks,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
595 from the most recently allocated to the oldest, and put all
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
596 cons cells that are not marked (whether or not they're already
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
597 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
598 so the cons cells in the oldest-allocated cons_block end up
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
599 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
600 If any cons_block is entirely free, it is freed with free()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
601 and its cons cells removed from the cons_free_list. Because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
602 the cons_free_list ends up basically in memory order, we have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
603 a high locality of reference (assuming a reasonable turnover
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
604 of allocating and freeing) and have a reasonable probability
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
605 of entirely freeing up cons_blocks that have been more recently
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
606 allocated. This stage is called the "sweep stage" of GC, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
607 is executed after the "mark stage", which involves starting
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
608 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
609 (e.g. the obarray, where are all symbols are stored; the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
610 current catches and condition-cases; the backtrace list of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
611 currently executing functions; the gcpro list; etc.) and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
612 recursively marking all objects that are accessible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
613
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
614 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
615 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
616 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
617 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
618 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
619 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
620 macro. This uses a special lrecord type `lrecord_type_free',
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
621 which is never associated with any valid object.
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
622
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
623 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
624 in the conses themselves. Because the cons is still in a
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
625 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
626 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
627 indicator and the chaining pointer. So this pointer is stored
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
628 after the lrecord header (actually where C places a pointer after
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
629 the lrecord header; they are not necessarily contiguous). This
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
630 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
631 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
632 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
633 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
634 ensure adequate space for the free list chain pointer.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
635
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
636 Some types of objects need additional "finalization" done
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
637 when an object is converted from in use to not in use;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
638 this is the purpose of the ADDITIONAL_FREE_type macro.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
639 For example, markers need to be removed from the chain
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
640 of markers that is kept in each buffer. This is because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
641 markers in a buffer automatically disappear if the marker
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
642 is no longer referenced anywhere (the same does not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
643 apply to extents, however).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
644
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
645 WARNING: Things are in an extremely bizarre state when
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
646 the ADDITIONAL_FREE_type macros are called, so beware!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
647
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
648 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
649 maximize our chances of catching places where there is insufficient
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
650 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
651 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
652 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
653 something seemingly unrelated getting trashed, and is extremely
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
654 difficult to track down. If the object gets freed but not
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
655 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
656 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
657 to the invalid type `lrecord_type_free', however, and a pointer
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
658 used to chain freed objects together is stored after the lrecord
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
659 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
660 bogus, so crashes are more likely to occur right away.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
661
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
662 We want freed objects to stay free as long as possible,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
663 so instead of doing what we do above, we maintain the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
664 free objects in a first-in first-out queue. We also
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
665 don't recompute the free list each GC, unlike above;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
666 this ensures that the queue ordering is preserved.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
667 [This means that we are likely to have worse locality
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
668 of reference, and that we can never free a frob block
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
669 once it's allocated. (Even if we know that all cells
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
670 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
671 cells from the free list because the objects on the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
672 free list are unlikely to be in memory order.)]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
673 Furthermore, we never take objects off the free list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
674 unless there's a large number (usually 1000, but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
675 varies depending on type) of them already on the list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
676 This way, we ensure that an object that gets freed will
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
677 remain free for the next 1000 (or whatever) times that
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
678 an object of that type is allocated. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
679
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
680 #ifndef MALLOC_OVERHEAD
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
681 #ifdef GNU_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
682 #define MALLOC_OVERHEAD 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
683 #elif defined (rcheck)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
684 #define MALLOC_OVERHEAD 20
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
685 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
686 #define MALLOC_OVERHEAD 8
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
687 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
688 #endif /* MALLOC_OVERHEAD */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
689
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
690 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
691 /* If we released our reserve (due to running out of memory),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
692 and we have a fair amount free once again,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
693 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
694
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
695 This is called when a relocatable block is freed in ralloc.c. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
696 void refill_memory_reserve (void);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
697 void
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
698 refill_memory_reserve (void)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
699 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
700 if (breathing_space == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
701 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
702 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
703 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
704
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
705 #ifdef ALLOC_NO_POOLS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
706 # define TYPE_ALLOC_SIZE(type, structtype) 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
707 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
708 # define TYPE_ALLOC_SIZE(type, structtype) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
709 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
710 / sizeof (structtype))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
711 #endif /* ALLOC_NO_POOLS */
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 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
714 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
715 struct type##_block \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
716 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
717 struct type##_block *prev; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
718 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
719 }; \
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 static struct type##_block *current_##type##_block; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
722 static int current_##type##_block_index; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
723 \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
724 static Lisp_Free *type##_free_list; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
725 static Lisp_Free *type##_free_list_tail; \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
726 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
727 static void \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
728 init_##type##_alloc (void) \
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 current_##type##_block = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
731 current_##type##_block_index = \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
732 countof (current_##type##_block->block); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
733 type##_free_list = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
734 type##_free_list_tail = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
735 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
736 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
737 static int gc_count_num_##type##_in_use; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
738 static int gc_count_num_##type##_freelist
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
739
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
740 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
741 if (current_##type##_block_index \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
742 == countof (current_##type##_block->block)) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
743 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
744 struct type##_block *AFTFB_new = (struct type##_block *) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
745 allocate_lisp_storage (sizeof (struct type##_block)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
746 AFTFB_new->prev = current_##type##_block; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
747 current_##type##_block = AFTFB_new; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
748 current_##type##_block_index = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
749 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
750 (result) = \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
751 &(current_##type##_block->block[current_##type##_block_index++]); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
752 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
753
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
754 /* Allocate an instance of a type that is stored in blocks.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
755 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
756 structure type. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
757
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
758 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
759
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
760 /* Note: if you get crashes in this function, suspect incorrect calls
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
761 to free_cons() and friends. This happened once because the cons
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
762 cell was not GC-protected and was getting collected before
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
763 free_cons() was called. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
764
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
765 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
766 if (gc_count_num_##type##_freelist > \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
767 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
768 { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
769 result = (structtype *) type##_free_list; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
770 /* Before actually using the chain pointer, \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
771 we complement all its bits; see FREE_FIXED_TYPE(). */ \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
772 type##_free_list = (Lisp_Free *) \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
773 (~ (EMACS_UINT) (type##_free_list->chain)); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
774 gc_count_num_##type##_freelist--; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
775 } \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
776 else \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
777 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
778 MARK_LRECORD_AS_NOT_FREE (result); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
779 } while (0)
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 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
782
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
783 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
784 if (type##_free_list) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
785 { \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
786 result = (structtype *) type##_free_list; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
787 type##_free_list = type##_free_list->chain; \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
788 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
789 else \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
790 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
791 MARK_LRECORD_AS_NOT_FREE (result); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
792 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
793
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
794 #endif /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
795
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
796
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
797 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
798 do \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
799 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
800 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
801 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
802 } while (0)
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 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
805 do \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
806 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
807 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
808 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
809 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
810
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
811
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
812 /* 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
813 block of any lisp object type. */
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
814 typedef struct Lisp_Free
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
815 {
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
816 struct lrecord_header lheader;
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
817 struct Lisp_Free *chain;
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
818 } Lisp_Free;
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
819
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
820 #define LRECORD_FREE_P(ptr) \
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
821 (((struct lrecord_header *) ptr)->type == lrecord_type_free)
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
822
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
823 #define MARK_LRECORD_AS_FREE(ptr) \
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
824 ((void) (((struct lrecord_header *) ptr)->type = lrecord_type_free))
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
825
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
826 #ifdef ERROR_CHECK_GC
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
827 #define MARK_LRECORD_AS_NOT_FREE(ptr) \
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
828 ((void) (((struct lrecord_header *) ptr)->type = lrecord_type_undefined))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
829 #else
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
830 #define MARK_LRECORD_AS_NOT_FREE(ptr) DO_NOTHING
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
831 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
832
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
833 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
834
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
835 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
836 if (type##_free_list_tail) \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
837 { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
838 /* When we store the chain pointer, we complement all \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
839 its bits; this should significantly increase its \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
840 bogosity in case someone tries to use the value, and \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
841 should make us crash faster if someone overwrites the \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
842 pointer because when it gets un-complemented in \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
843 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
844 extremely bogus. */ \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
845 type##_free_list_tail->chain = \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
846 (Lisp_Free *) ~ (EMACS_UINT) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
847 } \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
848 else \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
849 type##_free_list = (Lisp_Free *) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
850 type##_free_list_tail = (Lisp_Free *) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
851 } while (0)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
852
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
853 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
854
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
855 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
856 ((Lisp_Free *) (ptr))->chain = type##_free_list; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
857 type##_free_list = (Lisp_Free *) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
858 } while (0) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
859
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
860 #endif /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
861
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
862 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
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 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
865 structtype *FFT_ptr = (ptr); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
866 ADDITIONAL_FREE_##type (FFT_ptr); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
867 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
868 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
869 MARK_LRECORD_AS_FREE (FFT_ptr); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
870 } while (0)
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 /* Like FREE_FIXED_TYPE() but used when we are explicitly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
873 freeing a structure through free_cons(), free_marker(), etc.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
874 rather than through the normal process of sweeping.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
875 We attempt to undo the changes made to the allocation counters
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
876 as a result of this structure being allocated. This is not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
877 completely necessary but helps keep things saner: e.g. this way,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
878 repeatedly allocating and freeing a cons will not result in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
879 the consing-since-gc counter advancing, which would cause a GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
880 and somewhat defeat the purpose of explicitly freeing. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
881
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
882 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
883 do { FREE_FIXED_TYPE (type, structtype, ptr); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
884 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
885 gc_count_num_##type##_freelist++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
886 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
887
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
888
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
889
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
890 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
891 /* Cons allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
892 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
893
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
894 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
895 /* 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
896 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
897 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
898
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
899 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
900 mark_cons (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
901 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
902 if (NILP (XCDR (obj)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
903 return XCAR (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
904
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
905 mark_object (XCAR (obj));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
906 return XCDR (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
907 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
908
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
909 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
910 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
911 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
912 depth++;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
913 while (internal_equal (XCAR (ob1), XCAR (ob2), depth))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
914 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
915 ob1 = XCDR (ob1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
916 ob2 = XCDR (ob2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
917 if (! CONSP (ob1) || ! CONSP (ob2))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
918 return internal_equal (ob1, ob2, depth);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
919 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
920 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
921 }
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 static const struct lrecord_description cons_description[] = {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
924 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car) },
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
925 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr) },
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
926 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
927 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
928
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
929 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
930 mark_cons, print_cons, 0,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
931 cons_equal,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
932 /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
933 * No `hash' method needed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
934 * internal_hash knows how to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
935 * handle conses.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
936 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
937 0,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
938 cons_description,
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
939 Lisp_Cons);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
940
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
941 DEFUN ("cons", Fcons, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
942 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
943 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
944 (car, cdr))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
945 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
946 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
947 Lisp_Object val;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
948 Lisp_Cons *c;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
949
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
950 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
951 set_lheader_implementation (&c->lheader, &lrecord_cons);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
952 val = wrap_cons (c);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
953 c->car = car;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
954 c->cdr = cdr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
955 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
956 }
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 /* 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
959 going to free later, and is useful when trying to track down
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
960 "real" consing. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
961 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
962 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
963 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
964 Lisp_Object val;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
965 Lisp_Cons *c;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
966
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
967 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
968 set_lheader_implementation (&c->lheader, &lrecord_cons);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
969 val = wrap_cons (c);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
970 XCAR (val) = car;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
971 XCDR (val) = cdr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
972 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
973 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
974
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
975 DEFUN ("list", Flist, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
976 Return a newly created list with specified arguments as elements.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
977 Any number of arguments, even zero arguments, are allowed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
978 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
979 (int nargs, Lisp_Object *args))
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 Lisp_Object val = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
982 Lisp_Object *argp = args + nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
983
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
984 while (argp > args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
985 val = Fcons (*--argp, val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
986 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
987 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
988
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
989 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
990 list1 (Lisp_Object obj0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
991 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
992 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
993 return Fcons (obj0, Qnil);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
996 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
997 list2 (Lisp_Object obj0, Lisp_Object obj1)
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 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1000 return Fcons (obj0, Fcons (obj1, Qnil));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1001 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1002
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1003 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1004 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1005 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1006 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1007 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1008 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1009
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1010 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1011 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1012 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1013 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1014 return Fcons (obj0, Fcons (obj1, obj2));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1015 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1016
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1017 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1018 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1019 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1020 return Fcons (Fcons (key, value), alist);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1023 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1024 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
1025 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1026 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1027 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1028 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1029
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1030 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1031 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
1032 Lisp_Object obj4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1033 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1034 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1035 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1036 }
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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1039 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
1040 Lisp_Object obj4, Lisp_Object obj5)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1041 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1042 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1043 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
1044 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1045
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1046 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1047 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
1048 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1049 (length, object))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1050 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1051 CHECK_NATNUM (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1052
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1053 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1054 Lisp_Object val = Qnil;
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
1055 EMACS_INT size = XINT (length);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1056
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1057 while (size--)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1058 val = Fcons (object, val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1059 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1060 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1061 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1062
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1063
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1064 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1065 /* Float allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1066 /************************************************************************/
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 #ifdef LISP_FLOAT_TYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1069
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1070 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1071 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1074 make_float (double float_value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1075 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1076 Lisp_Float *f;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1077
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1078 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1079
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1080 /* Avoid dump-time `uninitialized memory read' purify warnings. */
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1081 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1082 xzero (*f);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1083
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1084 set_lheader_implementation (&f->lheader, &lrecord_float);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1085 float_data (f) = float_value;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1086 return wrap_float (f);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1087 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1088
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1089 #endif /* LISP_FLOAT_TYPE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1090
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1091
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1092 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1093 /* Vector allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1094 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1095
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1096 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1097 mark_vector (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1098 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1099 Lisp_Vector *ptr = XVECTOR (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1100 int len = vector_length (ptr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1101 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1102
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1103 for (i = 0; i < len - 1; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1104 mark_object (ptr->contents[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1105 return (len > 0) ? ptr->contents[len - 1] : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1106 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1107
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1108 static Bytecount
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1109 size_vector (const void *lheader)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1110 {
456
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 454
diff changeset
1111 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, contents,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1112 ((Lisp_Vector *) lheader)->size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1113 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1114
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1115 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1116 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1117 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1118 int len = XVECTOR_LENGTH (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1119 if (len != XVECTOR_LENGTH (obj2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1120 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1121
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1122 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1123 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1124 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1125 while (len--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1126 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1127 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1128 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1129 return 1;
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
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1132 static Hashcode
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1133 vector_hash (Lisp_Object obj, int depth)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1134 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1135 return HASH2 (XVECTOR_LENGTH (obj),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1136 internal_array_hash (XVECTOR_DATA (obj),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1137 XVECTOR_LENGTH (obj),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1138 depth + 1));
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1139 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1140
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1141 static const struct lrecord_description vector_description[] = {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1142 { XD_LONG, offsetof (Lisp_Vector, size) },
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1143 { 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
1144 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1145 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1146
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1147 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1148 mark_vector, print_vector, 0,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1149 vector_equal,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1150 vector_hash,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1151 vector_description,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1152 size_vector, Lisp_Vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1153
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1154 /* #### should allocate `small' vectors from a frob-block */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1155 static Lisp_Vector *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1156 make_vector_internal (Elemcount sizei)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1157 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1158 /* no vector_next */
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1159 Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object,
456
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 454
diff changeset
1160 contents, sizei);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1161 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1162
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1163 p->size = sizei;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1164 return p;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1165 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1166
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1167 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1168 make_vector (Elemcount length, Lisp_Object object)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1169 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1170 Lisp_Vector *vecp = make_vector_internal (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1171 Lisp_Object *p = vector_data (vecp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1172
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1173 while (length--)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1174 *p++ = object;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1175
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1176 return wrap_vector (vecp);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1177 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1178
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1179 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1180 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
1181 See also the function `vector'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1182 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1183 (length, object))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1184 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1185 CONCHECK_NATNUM (length);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1186 return make_vector (XINT (length), object);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1187 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1188
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1189 DEFUN ("vector", Fvector, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1190 Return a newly created vector with specified arguments as elements.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1191 Any number of arguments, even zero arguments, are allowed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1192 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1193 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1194 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1195 Lisp_Vector *vecp = make_vector_internal (nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1196 Lisp_Object *p = vector_data (vecp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1197
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1198 while (nargs--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1199 *p++ = *args++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1200
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1201 return wrap_vector (vecp);
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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1205 vector1 (Lisp_Object obj0)
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 return Fvector (1, &obj0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1208 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1209
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1210 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1211 vector2 (Lisp_Object obj0, Lisp_Object obj1)
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 Lisp_Object args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1214 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1215 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1216 return Fvector (2, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1217 }
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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1220 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
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 Lisp_Object args[3];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1223 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1224 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1225 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1226 return Fvector (3, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1227 }
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 #if 0 /* currently unused */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1230
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1231 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1232 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1233 Lisp_Object obj3)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1234 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1235 Lisp_Object args[4];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1236 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1237 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1238 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1239 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1240 return Fvector (4, args);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1243 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1244 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1245 Lisp_Object obj3, Lisp_Object obj4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1246 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1247 Lisp_Object args[5];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1248 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1249 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1250 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1251 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1252 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1253 return Fvector (5, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1254 }
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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1257 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1258 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1259 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1260 Lisp_Object args[6];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1261 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1262 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1263 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1264 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1265 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1266 args[5] = obj5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1267 return Fvector (6, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1268 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1269
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1270 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1271 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1272 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1273 Lisp_Object obj6)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1274 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1275 Lisp_Object args[7];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1276 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1277 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1278 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1279 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1280 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1281 args[5] = obj5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1282 args[6] = obj6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1283 return Fvector (7, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1284 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1285
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1286 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1287 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1288 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1289 Lisp_Object obj6, Lisp_Object obj7)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1290 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1291 Lisp_Object args[8];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1292 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1293 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1294 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1295 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1296 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1297 args[5] = obj5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1298 args[6] = obj6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1299 args[7] = obj7;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1300 return Fvector (8, args);
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 #endif /* unused */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1303
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 /* Bit Vector allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1306 /************************************************************************/
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 static Lisp_Object all_bit_vectors;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1309
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1310 /* #### should allocate `small' bit vectors from a frob-block */
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1311 static Lisp_Bit_Vector *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1312 make_bit_vector_internal (Elemcount sizei)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1313 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1314 Elemcount num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1315 Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector,
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
1316 unsigned long,
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
1317 bits, num_longs);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1318 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1319 set_lheader_implementation (&p->lheader, &lrecord_bit_vector);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1320
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1321 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
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 bit_vector_length (p) = sizei;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1324 bit_vector_next (p) = all_bit_vectors;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1325 /* make sure the extra bits in the last long are 0; the calling
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1326 functions might not set them. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1327 p->bits[num_longs - 1] = 0;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1328 all_bit_vectors = wrap_bit_vector (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1329 return p;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1330 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1331
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1332 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1333 make_bit_vector (Elemcount length, Lisp_Object bit)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1334 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1335 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
1336 Elemcount num_longs = BIT_VECTOR_LONG_STORAGE (length);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1337
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1338 CHECK_BIT (bit);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1339
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1340 if (ZEROP (bit))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1341 memset (p->bits, 0, num_longs * sizeof (long));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1342 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1343 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1344 Elemcount bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1345 memset (p->bits, ~0, num_longs * sizeof (long));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1346 /* But we have to make sure that the unused bits in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1347 last long are 0, so that equal/hash is easy. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1348 if (bits_in_last)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1349 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
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
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1352 return wrap_bit_vector (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1353 }
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 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1356 make_bit_vector_from_byte_vector (unsigned char *bytevec, Elemcount length)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1357 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1358 Elemcount i;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1359 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1360
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1361 for (i = 0; i < length; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1362 set_bit_vector_bit (p, i, bytevec[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1363
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1364 return wrap_bit_vector (p);
428
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 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1368 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
1369 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
1370 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1371 (length, bit))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1372 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1373 CONCHECK_NATNUM (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1374
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1375 return make_bit_vector (XINT (length), bit);
428
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 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1379 Return a newly created bit vector with specified arguments as elements.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1380 Any number of arguments, even zero arguments, are allowed.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1381 Each argument must be one of the integers 0 or 1.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1382 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1383 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1384 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1385 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1386 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1387
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1388 for (i = 0; i < nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1389 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1390 CHECK_BIT (args[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1391 set_bit_vector_bit (p, i, !ZEROP (args[i]));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1392 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1393
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1394 return wrap_bit_vector (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1395 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1396
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1397
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1398 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1399 /* Compiled-function allocation */
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 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1403 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1404
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1405 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1406 make_compiled_function (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1407 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1408 Lisp_Compiled_Function *f;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1409
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1410 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1411 set_lheader_implementation (&f->lheader, &lrecord_compiled_function);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1412
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1413 f->stack_depth = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1414 f->specpdl_depth = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1415 f->flags.documentationp = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1416 f->flags.interactivep = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1417 f->flags.domainp = 0; /* I18N3 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1418 f->instructions = Qzero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1419 f->constants = Qzero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1420 f->arglist = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1421 f->doc_and_interactive = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1422 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1423 f->annotated = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1424 #endif
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1425 return wrap_compiled_function (f);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1426 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1427
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1428 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1429 Return a new compiled-function object.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1430 Usage: (arglist instructions constants stack-depth
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1431 &optional doc-string interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1432 Note that, unlike all other emacs-lisp functions, calling this with five
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1433 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
1434 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
1435 that this function was defined with `(interactive)'. If the arg is not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1436 specified, then that means the function is not interactive.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1437 This is terrible behavior which is retained for compatibility with old
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1438 `.elc' files which expect these semantics.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1439 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1440 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1441 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1442 /* In a non-insane world this function would have this arglist...
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1443 (arglist instructions constants stack_depth &optional doc_string interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1444 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1445 Lisp_Object fun = make_compiled_function ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1446 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1447
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1448 Lisp_Object arglist = args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1449 Lisp_Object instructions = args[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1450 Lisp_Object constants = args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1451 Lisp_Object stack_depth = args[3];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1452 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1453 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1454
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1455 if (nargs < 4 || nargs > 6)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1456 return Fsignal (Qwrong_number_of_arguments,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1457 list2 (intern ("make-byte-code"), make_int (nargs)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1458
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1459 /* Check for valid formal parameter list now, to allow us to use
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1460 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1461 {
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1462 EXTERNAL_LIST_LOOP_2 (symbol, arglist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1463 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1464 CHECK_SYMBOL (symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1465 if (EQ (symbol, Qt) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1466 EQ (symbol, Qnil) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1467 SYMBOL_IS_KEYWORD (symbol))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 551
diff changeset
1468 invalid_constant_2
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1469 ("Invalid constant symbol in formal parameter list",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1470 symbol, arglist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1471 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1472 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1473 f->arglist = arglist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1474
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1475 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1476 int minargs = 0, maxargs = 0, totalargs = 0;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1477 int optional_p = 0, rest_p = 0, i = 0;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1478 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1479 LIST_LOOP_2 (arg, arglist)
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1480 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1481 if (EQ (arg, Qand_optional))
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1482 optional_p = 1;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1483 else if (EQ (arg, Qand_rest))
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1484 rest_p = 1;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1485 else
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1486 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1487 if (rest_p)
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1488 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1489 maxargs = MANY;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1490 totalargs++;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1491 break;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1492 }
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1493 if (!optional_p)
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1494 minargs++;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1495 maxargs++;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1496 totalargs++;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1497 }
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1498 }
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1499 }
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1500
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1501 f->args = xnew_array (Lisp_Object, totalargs);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1502
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1503 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1504 LIST_LOOP_2 (arg, arglist)
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1505 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1506 if (!EQ (arg, Qand_optional) && !EQ (arg, Qand_rest))
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1507 f->args[i++] = arg;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1508 }
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1509 }
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1510
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1511 f->max_args = maxargs;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1512 f->min_args = minargs;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1513 f->args_in_array = totalargs;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1514 }
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1515
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1516 /* `instructions' is a string or a cons (string . int) for a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1517 lazy-loaded function. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1518 if (CONSP (instructions))
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 CHECK_STRING (XCAR (instructions));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1521 CHECK_INT (XCDR (instructions));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1522 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1523 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1524 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1525 CHECK_STRING (instructions);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1526 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1527 f->instructions = instructions;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1528
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1529 if (!NILP (constants))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1530 CHECK_VECTOR (constants);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1531 f->constants = constants;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1532
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1533 CHECK_NATNUM (stack_depth);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1534 f->stack_depth = (unsigned short) XINT (stack_depth);
428
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 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1537 if (!NILP (Vcurrent_compiled_function_annotation))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1538 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1539 else if (!NILP (Vload_file_name_internal_the_purecopy))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1540 f->annotated = Vload_file_name_internal_the_purecopy;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1541 else if (!NILP (Vload_file_name_internal))
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 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1544 GCPRO1 (fun); /* don't let fun get reaped */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1545 Vload_file_name_internal_the_purecopy =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1546 Ffile_name_nondirectory (Vload_file_name_internal);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1547 f->annotated = Vload_file_name_internal_the_purecopy;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1548 UNGCPRO;
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 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
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 /* doc_string may be nil, string, int, or a cons (string . int).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1553 interactive may be list or string (or unbound). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1554 f->doc_and_interactive = Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1555 #ifdef I18N3
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1556 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1557 f->doc_and_interactive = Vfile_domain;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1558 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1559 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1560 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1561 f->doc_and_interactive
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1562 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1563 Fcons (interactive, f->doc_and_interactive));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1564 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1565 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
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 f->doc_and_interactive
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1568 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1569 Fcons (doc_string, f->doc_and_interactive));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1570 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1571 if (UNBOUNDP (f->doc_and_interactive))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1572 f->doc_and_interactive = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1573
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1574 return fun;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1575 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1576
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1577
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1578 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1579 /* Symbol allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1580 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1581
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1582 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1583 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
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 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1586 Return a newly allocated uninterned symbol whose name is NAME.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1587 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
1588 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1589 (name))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1590 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1591 Lisp_Symbol *p;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1592
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1593 CHECK_STRING (name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1594
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1595 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1596 set_lheader_implementation (&p->lheader, &lrecord_symbol);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1597 p->name = name;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1598 p->plist = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1599 p->value = Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1600 p->function = Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1601 symbol_next (p) = 0;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1602 return wrap_symbol (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1603 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1604
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1605
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 /* Extent allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1608 /************************************************************************/
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 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1611 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1612
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1613 struct extent *
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1614 allocate_extent (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1615 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1616 struct extent *e;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1617
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1618 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1619 set_lheader_implementation (&e->lheader, &lrecord_extent);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1620 extent_object (e) = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1621 set_extent_start (e, -1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1622 set_extent_end (e, -1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1623 e->plist = Qnil;
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 xzero (e->flags);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1626
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1627 extent_face (e) = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1628 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
1629 e->flags.detachable = 1;
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 return e;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1632 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1633
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 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1636 /* Event allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1637 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1638
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1639 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1640 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1641
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1642 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1643 allocate_event (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1644 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1645 Lisp_Event *e;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1646
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1647 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1648 set_lheader_implementation (&e->lheader, &lrecord_event);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1649
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1650 return wrap_event (e);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1651 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1654 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1655 /* Marker allocation */
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
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1658 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1659 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1660
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1661 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1662 Return a new marker which does not point at any place.
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 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1666 Lisp_Marker *p;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1667
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1668 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1669 set_lheader_implementation (&p->lheader, &lrecord_marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1670 p->buffer = 0;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1671 p->membpos = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1672 marker_next (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1673 marker_prev (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1674 p->insertion_type = 0;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1675 return wrap_marker (p);
428
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 noseeum_make_marker (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1680 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1681 Lisp_Marker *p;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1682
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1683 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1684 set_lheader_implementation (&p->lheader, &lrecord_marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1685 p->buffer = 0;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1686 p->membpos = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1687 marker_next (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1688 marker_prev (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1689 p->insertion_type = 0;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1690 return wrap_marker (p);
428
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1693
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1694 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1695 /* String allocation */
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1698 /* The data for "short" strings generally resides inside of structs of type
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1699 string_chars_block. The Lisp_String structure is allocated just like any
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1700 other Lisp object (except for vectors), and these are freelisted when
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1701 they get garbage collected. The data for short strings get compacted,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1702 but the data for large strings do not.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1703
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1704 Previously Lisp_String structures were relocated, but this caused a lot
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1705 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
1706 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
1707 that the reference would get relocated).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1708
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1709 This new method makes things somewhat bigger, but it is MUCH safer. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1710
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1711 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1712 /* strings are used and freed quite often */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1713 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1714 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1715
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1716 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1717 mark_string (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1718 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1719 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
1720 flush_cached_extent_info (XCAR (XSTRING_PLIST (obj)));
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1721 return XSTRING_PLIST (obj);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1722 }
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 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1725 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
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 Bytecount len;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1728 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1729 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1730 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1731
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1732 static const struct lrecord_description string_description[] = {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1733 { XD_BYTECOUNT, offsetof (Lisp_String, size_) },
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1734 { 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
1735 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1736 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1737 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1738
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1739 /* 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
1740 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
1741 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
1742 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
1743 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
1744 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
1745 extent info.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1746
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1747 #### 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
1748
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1749 static Lisp_Object *
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1750 string_plist_ptr (Lisp_Object string)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1751 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1752 Lisp_Object *ptr = &XSTRING_PLIST (string);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1753
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1754 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1755 ptr = &XCDR (*ptr);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1756 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1757 ptr = &XCDR (*ptr);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1758 return ptr;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1759 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1760
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1761 static Lisp_Object
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1762 string_getprop (Lisp_Object string, Lisp_Object property)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1763 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1764 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
1765 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1766
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1767 static int
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1768 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1769 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1770 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
1771 return 1;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1772 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1773
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1774 static int
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1775 string_remprop (Lisp_Object string, Lisp_Object property)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1776 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1777 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1778 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1779
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1780 static Lisp_Object
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1781 string_plist (Lisp_Object string)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1782 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1783 return *string_plist_ptr (string);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1784 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1785
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1786 /* No `finalize', or `hash' methods.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1787 internal_hash() already knows how to hash strings and finalization
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1788 is done with the ADDITIONAL_FREE_string macro, which is the
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1789 standard way to do finalization when using
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1790 SWEEP_FIXED_TYPE_BLOCK(). */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1791 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1792 mark_string, print_string,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1793 0, string_equal, 0,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1794 string_description,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1795 string_getprop,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1796 string_putprop,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1797 string_remprop,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1798 string_plist,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1799 Lisp_String);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1800
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1801 /* String blocks contain this many useful bytes. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1802 #define STRING_CHARS_BLOCK_SIZE \
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1803 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1804 ((2 * sizeof (struct string_chars_block *)) \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1805 + sizeof (EMACS_INT))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1806 /* Block header for small strings. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1807 struct string_chars_block
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1808 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1809 EMACS_INT pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1810 struct string_chars_block *next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1811 struct string_chars_block *prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1812 /* Contents of string_chars_block->string_chars are interleaved
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1813 string_chars structures (see below) and the actual string data */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1814 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1817 static struct string_chars_block *first_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1818 static struct string_chars_block *current_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1819
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1820 /* 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
1821 * the string occupies in string_chars_block->string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1822 * (including alignment padding).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1823 */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1824 #define STRING_FULLSIZE(size) \
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
1825 ALIGN_FOR_TYPE (((size) + 1 + sizeof (Lisp_String *)), Lisp_String *)
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 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1828 #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
1829
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1830 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL)
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1831 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL))
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1832
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1833 struct string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1834 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1835 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1836 unsigned char chars[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1837 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1838
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1839 struct unused_string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1840 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1841 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1842 EMACS_INT fullsize;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1845 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1846 init_string_chars_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1847 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1848 first_string_chars_block = xnew (struct string_chars_block);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1849 first_string_chars_block->prev = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1850 first_string_chars_block->next = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1851 first_string_chars_block->pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1852 current_string_chars_block = first_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1853 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1854
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1855 static struct string_chars *
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1856 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
1857 Bytecount fullsize)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1858 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1859 struct string_chars *s_chars;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1860
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1861 if (fullsize <=
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1862 (countof (current_string_chars_block->string_chars)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1863 - current_string_chars_block->pos))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1864 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1865 /* This string can fit in the current string chars block */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1866 s_chars = (struct string_chars *)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1867 (current_string_chars_block->string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1868 + current_string_chars_block->pos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1869 current_string_chars_block->pos += fullsize;
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 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1872 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1873 /* Make a new current string chars block */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1874 struct string_chars_block *new_scb = xnew (struct string_chars_block);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1875
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1876 current_string_chars_block->next = new_scb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1877 new_scb->prev = current_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1878 new_scb->next = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1879 current_string_chars_block = new_scb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1880 new_scb->pos = fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1881 s_chars = (struct string_chars *)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1882 current_string_chars_block->string_chars;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1883 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1884
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1885 s_chars->string = XSTRING (string_it_goes_with);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1886
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1887 INCREMENT_CONS_COUNTER (fullsize, "string chars");
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 return s_chars;
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
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1892 #ifdef SLEDGEHAMMER_CHECK_ASCII_BEGIN
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1893 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1894 sledgehammer_check_ascii_begin (Lisp_Object str)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1895 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1896 Bytecount i;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1897
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1898 for (i = 0; i < XSTRING_LENGTH (str); i++)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1899 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
1900 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
1901 break;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1902 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1903
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1904 assert (i == (Bytecount) XSTRING_ASCII_BEGIN (str) ||
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1905 (i > MAX_STRING_ASCII_BEGIN &&
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1906 (Bytecount) XSTRING_ASCII_BEGIN (str) ==
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1907 (Bytecount) MAX_STRING_ASCII_BEGIN));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1908 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1909 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1910
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1911 /* You do NOT want to be calling this! (And if you do, you must call
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1912 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
1913 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
1914
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1915 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1916 make_uninit_string (Bytecount length)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1917 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1918 Lisp_String *s;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1919 Bytecount fullsize = STRING_FULLSIZE (length);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1920
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1921 assert (length >= 0 && fullsize > 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1922
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1923 /* Allocate the string header */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1924 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1925 xzero (*s);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1926 set_lheader_implementation (&s->u.lheader, &lrecord_string);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1927
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
1928 set_lispstringp_data (s, BIG_STRING_FULLSIZE_P (fullsize)
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1929 ? xnew_array (Intbyte, length + 1)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1930 : allocate_string_chars_struct (wrap_string (s),
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1931 fullsize)->chars);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1932
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
1933 set_lispstringp_length (s, length);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1934 s->plist = Qnil;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1935 set_string_byte (wrap_string (s), length, 0);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1936
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1937 return wrap_string (s);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1938 }
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 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1941 static void verify_string_chars_integrity (void);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1942 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1943
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1944 /* Resize the string S so that DELTA bytes can be inserted starting
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1945 at POS. If DELTA < 0, it means deletion starting at POS. If
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1946 POS < 0, resize the string but don't copy any characters. Use
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1947 this if you're planning on completely overwriting the string.
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1950 void
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1951 resize_string (Lisp_Object s, Bytecount pos, Bytecount delta)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1952 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1953 Bytecount oldfullsize, newfullsize;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1954 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1955 verify_string_chars_integrity ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1956 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1957
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
1958 #ifdef ERROR_CHECK_TEXT
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1959 if (pos >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1960 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1961 assert (pos <= XSTRING_LENGTH (s));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1962 if (delta < 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1963 assert (pos + (-delta) <= XSTRING_LENGTH (s));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1964 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1965 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1966 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1967 if (delta < 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1968 assert ((-delta) <= XSTRING_LENGTH (s));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1969 }
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
1970 #endif /* ERROR_CHECK_TEXT */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1971
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1972 if (delta == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1973 /* simplest case: no size change. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1974 return;
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1975
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1976 if (pos >= 0 && delta < 0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1977 /* If DELTA < 0, the functions below will delete the characters
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1978 before POS. We want to delete characters *after* POS, however,
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1979 so convert this to the appropriate form. */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1980 pos += -delta;
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1981
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1982 oldfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s));
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1983 newfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s) + delta);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1984
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1985 if (BIG_STRING_FULLSIZE_P (oldfullsize))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1986 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1987 if (BIG_STRING_FULLSIZE_P (newfullsize))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1988 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1989 /* Both strings are big. We can just realloc().
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1990 But careful! If the string is shrinking, we have to
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1991 memmove() _before_ realloc(), and if growing, we have to
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1992 memmove() _after_ realloc() - otherwise the access is
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1993 illegal, and we might crash. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1994 Bytecount len = XSTRING_LENGTH (s) + 1 - pos;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1995
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1996 if (delta < 0 && pos >= 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1997 memmove (XSTRING_DATA (s) + pos + delta,
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1998 XSTRING_DATA (s) + pos, len);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1999 XSET_STRING_DATA
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2000 (s, (Intbyte *) xrealloc (XSTRING_DATA (s),
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2001 XSTRING_LENGTH (s) + delta + 1));
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2002 if (delta > 0 && pos >= 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2003 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
2004 len);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2005 }
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2006 else /* String has been demoted from BIG_STRING. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2007 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2008 Intbyte *new_data =
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2009 allocate_string_chars_struct (s, newfullsize)->chars;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2010 Intbyte *old_data = XSTRING_DATA (s);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2011
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2012 if (pos >= 0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2013 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2014 memcpy (new_data, old_data, pos);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2015 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
2016 XSTRING_LENGTH (s) + 1 - pos);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2017 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2018 XSET_STRING_DATA (s, new_data);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2019 xfree (old_data);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2020 }
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2021 }
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2022 else /* old string is small */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2023 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2024 if (oldfullsize == newfullsize)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2025 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2026 /* special case; size change but the necessary
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2027 allocation size won't change (up or down; code
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2028 somewhere depends on there not being any unused
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2029 allocation space, modulo any alignment
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2030 constraints). */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2031 if (pos >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2032 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2033 Intbyte *addroff = pos + XSTRING_DATA (s);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2034
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2035 memmove (addroff + delta, addroff,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2036 /* +1 due to zero-termination. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2037 XSTRING_LENGTH (s) + 1 - pos);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2038 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2039 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2040 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2041 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2042 Intbyte *old_data = XSTRING_DATA (s);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2043 Intbyte *new_data =
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2044 BIG_STRING_FULLSIZE_P (newfullsize)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2045 ? xnew_array (Intbyte, XSTRING_LENGTH (s) + delta + 1)
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2046 : allocate_string_chars_struct (s, newfullsize)->chars;
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2047
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2048 if (pos >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2049 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2050 memcpy (new_data, old_data, pos);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2051 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
2052 XSTRING_LENGTH (s) + 1 - pos);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2053 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2054 XSET_STRING_DATA (s, new_data);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2055
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2056 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2057 /* We need to mark this chunk of the string_chars_block
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2058 as unused so that compact_string_chars() doesn't
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2059 freak. */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2060 struct string_chars *old_s_chars = (struct string_chars *)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2061 ((char *) old_data - offsetof (struct string_chars, chars));
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2062 /* Sanity check to make sure we aren't hosed by strange
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2063 alignment/padding. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2064 assert (old_s_chars->string == XSTRING (s));
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2065 MARK_STRING_CHARS_AS_FREE (old_s_chars);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2066 ((struct unused_string_chars *) old_s_chars)->fullsize =
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2067 oldfullsize;
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2068 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2069 }
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2070 }
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2071
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2072 XSET_STRING_LENGTH (s, XSTRING_LENGTH (s) + delta);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2073 /* If pos < 0, the string won't be zero-terminated.
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2074 Terminate now just to make sure. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2075 XSTRING_DATA (s)[XSTRING_LENGTH (s)] = '\0';
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2076
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2077 if (pos >= 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2078 /* 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
2079 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
2080 adjust_extents() is exclusive of the starting position
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2081 passed to it. */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2082 adjust_extents (s, pos - 1, XSTRING_LENGTH (s), delta);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2083
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2084 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2085 verify_string_chars_integrity ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2086 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2087 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2088
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2089 #ifdef MULE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2090
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2091 /* 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
2092 CHECK_LISP_WRITEABLE() before and bump_string_modiff() afterwards. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2093 void
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2094 set_string_char (Lisp_Object s, Charcount i, Emchar c)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2095 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2096 Intbyte newstr[MAX_EMCHAR_LEN];
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2097 Bytecount bytoff = string_index_char_to_byte (s, i);
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2098 Bytecount oldlen = charptr_emchar_len (XSTRING_DATA (s) + bytoff);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2099 Bytecount newlen = set_charptr_emchar (newstr, c);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2100
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2101 sledgehammer_check_ascii_begin (s);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2102 if (oldlen != newlen)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2103 resize_string (s, bytoff, newlen - oldlen);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2104 /* 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
2105 memcpy (XSTRING_DATA (s) + bytoff, newstr, newlen);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2106 if (oldlen != newlen)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2107 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2108 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
2109 /* 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
2110 ascii_begin */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2111 XSET_STRING_ASCII_BEGIN (s, i);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2112 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
2113 /* 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
2114 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2115 Bytecount j;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2116 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
2117 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2118 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
2119 break;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2120 }
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2121 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
2122 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2123 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2124 sledgehammer_check_ascii_begin (s);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2125 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2126
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2127 #endif /* MULE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2128
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2129 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2130 Return a new string consisting of LENGTH copies of CHARACTER.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2131 LENGTH must be a non-negative integer.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2132 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2133 (length, character))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2134 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2135 CHECK_NATNUM (length);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2136 CHECK_CHAR_COERCE_INT (character);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2137 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2138 Intbyte init_str[MAX_EMCHAR_LEN];
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2139 int len = set_charptr_emchar (init_str, XCHAR (character));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2140 Lisp_Object val = make_uninit_string (len * XINT (length));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2141
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2142 if (len == 1)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2143 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2144 /* Optimize the single-byte case */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2145 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
2146 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
2147 len * XINT (length)));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2148 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2149 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2150 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
2151 EMACS_INT i;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2152 Intbyte *ptr = XSTRING_DATA (val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2153
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2154 for (i = XINT (length); i; i--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2155 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2156 Intbyte *init_ptr = init_str;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2157 switch (len)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2158 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2159 case 4: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2160 case 3: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2161 case 2: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2162 case 1: *ptr++ = *init_ptr++;
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2165 }
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2166 sledgehammer_check_ascii_begin (val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2167 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2168 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2171 DEFUN ("string", Fstring, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2172 Concatenate all the argument characters and make the result a string.
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 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2175 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2176 Intbyte *storage = alloca_array (Intbyte, nargs * MAX_EMCHAR_LEN);
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2177 Intbyte *p = storage;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2178
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2179 for (; nargs; nargs--, args++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2180 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2181 Lisp_Object lisp_char = *args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2182 CHECK_CHAR_COERCE_INT (lisp_char);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2183 p += set_charptr_emchar (p, XCHAR (lisp_char));
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 return make_string (storage, p - storage);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2186 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2187
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2188 /* 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
2189
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2190 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2191 init_string_ascii_begin (Lisp_Object string)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2192 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2193 #ifdef MULE
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2194 int i;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2195 Bytecount length = XSTRING_LENGTH (string);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2196 Intbyte *contents = XSTRING_DATA (string);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2197
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2198 for (i = 0; i < length; i++)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2199 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2200 if (!byte_ascii_p (contents[i]))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2201 break;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2202 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2203 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
2204 #else
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2205 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
2206 MAX_STRING_ASCII_BEGIN));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2207 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2208 sledgehammer_check_ascii_begin (string);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2209 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2210
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2211 /* Take some raw memory, which MUST already be in internal format,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2212 and package it up into a Lisp string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2213 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2214 make_string (const Intbyte *contents, Bytecount length)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2215 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2216 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2217
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2218 /* 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
2219 #if defined (ERROR_CHECK_TEXT) && defined (MULE)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2220 bytecount_to_charcount (contents, length); /* Just for the assertions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2221 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2222
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2223 val = make_uninit_string (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2224 memcpy (XSTRING_DATA (val), contents, length);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2225 init_string_ascii_begin (val);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2226 sledgehammer_check_ascii_begin (val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2227 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2228 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2229
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2230 /* Take some raw memory, encoded in some external data format,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2231 and convert it into a Lisp string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2232 Lisp_Object
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2233 make_ext_string (const Extbyte *contents, EMACS_INT length,
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2234 Lisp_Object coding_system)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2235 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2236 Lisp_Object string;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2237 TO_INTERNAL_FORMAT (DATA, (contents, length),
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2238 LISP_STRING, string,
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2239 coding_system);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2240 return string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2241 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2242
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2243 Lisp_Object
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2244 build_intstring (const Intbyte *str)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2245 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2246 /* 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
2247 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
2248 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2249
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2250 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2251 build_string (const CIntbyte *str)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2252 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2253 /* Some strlen's crash and burn if passed null. */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2254 return make_string ((const Intbyte *) str, (str ? strlen (str) : 0));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2255 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2256
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2257 Lisp_Object
593
5fd7ba8b56e7 [xemacs-hg @ 2001-05-31 12:45:27 by ben]
ben
parents: 578
diff changeset
2258 build_ext_string (const Extbyte *str, Lisp_Object coding_system)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2259 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2260 /* Some strlen's crash and burn if passed null. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2261 return make_ext_string ((const Extbyte *) str, (str ? strlen(str) : 0),
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2262 coding_system);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2263 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2264
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2265 Lisp_Object
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2266 build_msg_intstring (const Intbyte *str)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2267 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2268 return build_intstring (GETTEXT (str));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2269 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2270
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2271 Lisp_Object
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2272 build_msg_string (const CIntbyte *str)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2273 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2274 return build_string (CGETTEXT (str));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2275 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2276
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2277 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2278 make_string_nocopy (const Intbyte *contents, Bytecount length)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2279 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2280 Lisp_String *s;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2281 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2282
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2283 /* 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
2284 #if defined (ERROR_CHECK_TEXT) && defined (MULE)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2285 bytecount_to_charcount (contents, length); /* Just for the assertions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2286 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2287
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2288 /* Allocate the string header */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2289 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2290 set_lheader_implementation (&s->u.lheader, &lrecord_string);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2291 SET_C_READONLY_RECORD_HEADER (&s->u.lheader);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2292 s->plist = Qnil;
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2293 set_lispstringp_data (s, (Intbyte *) contents);
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2294 set_lispstringp_length (s, length);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2295 val = wrap_string (s);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2296 init_string_ascii_begin (val);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2297 sledgehammer_check_ascii_begin (val);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2298
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2299 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2300 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2301
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2302
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2303 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2304 /* lcrecord lists */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2305 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2306
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2307 /* Lcrecord lists are used to manage the allocation of particular
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2308 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2309 malloc() and garbage-collection junk) as much as possible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2310 It is similar to the Blocktype class.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2311
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2312 It works like this:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2313
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2314 1) Create an lcrecord-list object using make_lcrecord_list().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2315 This is often done at initialization. Remember to staticpro_nodump
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2316 this object! The arguments to make_lcrecord_list() are the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2317 same as would be passed to alloc_lcrecord().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2318 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2319 and pass the lcrecord-list earlier created.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2320 3) When done with the lcrecord, call free_managed_lcrecord().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2321 The standard freeing caveats apply: ** make sure there are no
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2322 pointers to the object anywhere! **
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2323 4) Calling free_managed_lcrecord() is just like kissing the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2324 lcrecord goodbye as if it were garbage-collected. This means:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2325 -- the contents of the freed lcrecord are undefined, and the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2326 contents of something produced by allocate_managed_lcrecord()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2327 are undefined, just like for alloc_lcrecord().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2328 -- the mark method for the lcrecord's type will *NEVER* be called
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2329 on freed lcrecords.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2330 -- the finalize method for the lcrecord's type will be called
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2331 at the time that free_managed_lcrecord() is called.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2332
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2333 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2334
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2335 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2336 mark_lcrecord_list (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2337 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2338 struct lcrecord_list *list = XLCRECORD_LIST (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2339 Lisp_Object chain = list->free;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2340
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2341 while (!NILP (chain))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2342 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2343 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2344 struct free_lcrecord_header *free_header =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2345 (struct free_lcrecord_header *) lheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2346
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2347 gc_checking_assert
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2348 (/* There should be no other pointers to the free list. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2349 ! MARKED_RECORD_HEADER_P (lheader)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2350 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2351 /* Only lcrecords should be here. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2352 ! LHEADER_IMPLEMENTATION (lheader)->basic_p
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2353 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2354 /* Only free lcrecords should be here. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2355 free_header->lcheader.free
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2356 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2357 /* The type of the lcrecord must be right. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2358 LHEADER_IMPLEMENTATION (lheader) == list->implementation
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2359 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2360 /* So must the size. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2361 (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2362 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2363 );
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2364
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2365 MARK_RECORD_HEADER (lheader);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2366 chain = free_header->chain;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2367 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2368
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2369 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2370 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2371
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2372 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2373 mark_lcrecord_list, internal_object_printer,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2374 0, 0, 0, 0, struct lcrecord_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2375 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2376 make_lcrecord_list (Elemcount size,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2377 const struct lrecord_implementation *implementation)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2378 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2379 struct lcrecord_list *p =
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2380 /* Avoid infinite recursion allocating this */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2381 alloc_unmanaged_lcrecord_type (struct lcrecord_list,
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2382 &lrecord_lcrecord_list);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2383
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2384 p->implementation = implementation;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2385 p->size = size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2386 p->free = Qnil;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2387 return wrap_lcrecord_list (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2388 }
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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2391 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2392 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2393 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2394 if (!NILP (list->free))
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 Lisp_Object val = list->free;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2397 struct free_lcrecord_header *free_header =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2398 (struct free_lcrecord_header *) XPNTR (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2399
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2400 #ifdef ERROR_CHECK_GC
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2401 struct lrecord_header *lheader = &free_header->lcheader.lheader;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2402
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2403 /* There should be no other pointers to the free list. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2404 assert (! MARKED_RECORD_HEADER_P (lheader));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2405 /* Only lcrecords should be here. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2406 assert (! LHEADER_IMPLEMENTATION (lheader)->basic_p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2407 /* Only free lcrecords should be here. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2408 assert (free_header->lcheader.free);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2409 /* The type of the lcrecord must be right. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2410 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2411 /* So must the size. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2412 assert (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2413 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2414 #endif /* ERROR_CHECK_GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2415
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2416 list->free = free_header->chain;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2417 free_header->lcheader.free = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2418 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2419 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2420 else
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2421 return wrap_pointer_1 (alloc_lcrecord (list->size, list->implementation));
428
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
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2424 /* "Free" a Lisp object LCRECORD by placing it on its associated free list
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2425 LCRECORD_LIST; next time allocate_managed_lcrecord() is called with the
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2426 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
2427 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
2428 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
2429 used!
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2430
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2431 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
2432 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
2433
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2434 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2435 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
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 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2438 struct free_lcrecord_header *free_header =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2439 (struct free_lcrecord_header *) XPNTR (lcrecord);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2440 struct lrecord_header *lheader = &free_header->lcheader.lheader;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2441 const struct lrecord_implementation *implementation
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2442 = LHEADER_IMPLEMENTATION (lheader);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2443
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2444 /* 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
2445 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
2446 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
2447 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
2448 (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
2449 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
2450 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
2451 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
2452 problems. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2453 gc_checking_assert (!gc_in_progress);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2454
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2455 /* Make sure the size is correct. This will catch, for example,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2456 putting a window configuration on the wrong free list. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2457 gc_checking_assert ((implementation->size_in_bytes_method ?
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2458 implementation->size_in_bytes_method (lheader) :
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2459 implementation->static_size)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2460 == list->size);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2461 /* Make sure the object isn't already freed. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2462 gc_checking_assert (!free_header->lcheader.free);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2463
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2464 if (implementation->finalizer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2465 implementation->finalizer (lheader, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2466 free_header->chain = list->free;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2467 free_header->lcheader.free = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2468 list->free = lcrecord;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2469 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2470
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2471 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
2472
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2473 void *
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2474 alloc_automanaged_lcrecord (Bytecount size,
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2475 const struct lrecord_implementation *imp)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2476 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2477 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
2478 all_lcrecord_lists[imp->lrecord_type_index] =
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2479 make_lcrecord_list (size, imp);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2480
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2481 return XPNTR (allocate_managed_lcrecord
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2482 (all_lcrecord_lists[imp->lrecord_type_index]));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2483 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2484
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2485 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2486 free_lcrecord (Lisp_Object rec)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2487 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2488 int type = XRECORD_LHEADER (rec)->type;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2489
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2490 assert (!EQ (all_lcrecord_lists[type], Qzero));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2491
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2492 free_managed_lcrecord (all_lcrecord_lists[type], rec);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2493 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2494
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2495
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2496 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2497 Kept for compatibility, returns its argument.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2498 Old:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2499 Make a copy of OBJECT in pure storage.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2500 Recursively copies contents of vectors and cons cells.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2501 Does not copy symbols.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2502 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2503 (object))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2504 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2505 return object;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2506 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2507
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2508
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 /* Garbage Collection */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2511 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2512
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2513 /* 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
2514 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
2515 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
2516 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
2517 int lrecord_type_count = lrecord_type_last_built_in_type;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2518 /* Object marker functions are in the lrecord_implementation structure.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2519 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
2520 This hack speeds up (garbage-collect) by about 5%. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2521 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2522
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2523 struct gcpro *gcprolist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2524
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2525 /* 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
2526 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
2527 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
2528 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
2529 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
2530 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
2531 "root pointer"; this happens in the call to staticpro(). */
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2532 static const struct lrecord_description staticpro_description_1[] = {
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2533 { XD_END }
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2534 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2535
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2536 static const struct struct_description staticpro_description = {
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2537 sizeof (Lisp_Object *),
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2538 staticpro_description_1
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2539 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2540
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2541 static const struct lrecord_description staticpros_description_1[] = {
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2542 XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description),
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2543 { XD_END }
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2544 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2545
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2546 static const struct struct_description staticpros_description = {
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2547 sizeof (Lisp_Object_ptr_dynarr),
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2548 staticpros_description_1
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2549 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2550
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2551 #ifdef DEBUG_XEMACS
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2552
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2553 static const struct lrecord_description staticpro_one_name_description_1[] = {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2554 { XD_C_STRING, 0 },
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2555 { XD_END }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2556 };
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2557
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2558 static const struct struct_description staticpro_one_name_description = {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2559 sizeof (char *),
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2560 staticpro_one_name_description_1
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2561 };
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2562
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2563 static const struct lrecord_description staticpro_names_description_1[] = {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2564 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
2565 { XD_END }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2566 };
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2567
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2568 static const struct struct_description staticpro_names_description = {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2569 sizeof (char_ptr_dynarr),
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2570 staticpro_names_description_1
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2571 };
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2572
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2573 /* 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
2574
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2575 Lisp_Object_ptr_dynarr *staticpros;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2576 char_ptr_dynarr *staticpro_names;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2577
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2578 /* 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
2579 garbage collection, and for dumping. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2580 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2581 staticpro_1 (Lisp_Object *varaddress, char *varname)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2582 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2583 Dynarr_add (staticpros, varaddress);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2584 Dynarr_add (staticpro_names, varname);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2585 dump_add_root_object (varaddress);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2586 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2587
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2588
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2589 Lisp_Object_ptr_dynarr *staticpros_nodump;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2590 char_ptr_dynarr *staticpro_nodump_names;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2591
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2592 /* 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
2593 garbage collection, but not for dumping. (See below.) */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2594 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2595 staticpro_nodump_1 (Lisp_Object *varaddress, char *varname)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2596 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2597 Dynarr_add (staticpros_nodump, varaddress);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2598 Dynarr_add (staticpro_nodump_names, varname);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2599 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2600
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2601 #else /* not DEBUG_XEMACS */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2602
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2603 Lisp_Object_ptr_dynarr *staticpros;
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2604
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2605 /* 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
2606 garbage collection, and for dumping. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2607 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2608 staticpro (Lisp_Object *varaddress)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2609 {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2610 Dynarr_add (staticpros, varaddress);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2611 dump_add_root_object (varaddress);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2612 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2613
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2614
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2615 Lisp_Object_ptr_dynarr *staticpros_nodump;
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2616
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2617 /* 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
2618 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
2619 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
2620 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
2621 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
2622 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
2623 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
2624 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
2625 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
2626 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
2627 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
2628 reloaded at a different address.)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2629
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2630 #### 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
2631 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
2632 loads the data in. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2633
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2634 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2635 staticpro_nodump (Lisp_Object *varaddress)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2636 {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2637 Dynarr_add (staticpros_nodump, varaddress);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2638 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2639
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2640 #endif /* not DEBUG_XEMACS */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2641
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2642 #ifdef ERROR_CHECK_GC
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2643 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2644 struct lrecord_header * GCLI_lh = (lheader); \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2645 assert (GCLI_lh != 0); \
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
2646 assert (GCLI_lh->type < (unsigned int) lrecord_type_count); \
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2647 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2648 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2649 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2650 } while (0)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2651 #else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2652 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2653 #endif
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2654
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2655
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2656 /* 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
2657 seen yet, recursively mark all the references contained in it. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2658
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2659 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2660 mark_object (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2661 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2662 tail_recurse:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2663
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2664 /* Checks we used to perform */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2665 /* if (EQ (obj, Qnull_pointer)) return; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2666 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2667 /* if (PURIFIED (XPNTR (obj))) return; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2668
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2669 if (XTYPE (obj) == Lisp_Type_Record)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2670 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2671 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2672
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2673 GC_CHECK_LHEADER_INVARIANTS (lheader);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2674
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2675 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2676 ! ((struct lcrecord_header *) lheader)->free);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2677
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2678 /* All c_readonly objects have their mark bit set,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2679 so that we only need to check the mark bit here. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2680 if (! MARKED_RECORD_HEADER_P (lheader))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2681 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2682 MARK_RECORD_HEADER (lheader);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2683
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2684 if (RECORD_MARKER (lheader))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2685 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2686 obj = RECORD_MARKER (lheader) (obj);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2687 if (!NILP (obj)) goto tail_recurse;
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 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2693 /* mark all of the conses in a list and mark the final cdr; but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2694 DO NOT mark the cars.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2695
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2696 Use only for internal lists! There should never be other pointers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2697 to the cons cells, because if so, the cars will remain unmarked
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2698 even when they maybe should be marked. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2699 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2700 mark_conses_in_list (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2701 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2702 Lisp_Object rest;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2703
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2704 for (rest = obj; CONSP (rest); rest = XCDR (rest))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2705 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2706 if (CONS_MARKED_P (XCONS (rest)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2707 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2708 MARK_CONS (XCONS (rest));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2709 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2710
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2711 mark_object (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2712 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2713
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2714
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2715 /* Find all structures not marked, and free them. */
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 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2718 static int gc_count_bit_vector_storage;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2719 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
2720 static Bytecount gc_count_string_total_size;
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
2721 static Bytecount gc_count_short_string_total_size;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2722
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2723 /* static int gc_count_total_records_used, gc_count_records_total_size; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2724
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2725
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2726 /* stats on lcrecords in use - kinda kludgy */
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 static struct
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2729 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2730 int instances_in_use;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2731 int bytes_in_use;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2732 int instances_freed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2733 int bytes_freed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2734 int instances_on_free_list;
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 665
diff changeset
2735 } lcrecord_stats [countof (lrecord_implementations_table)
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 665
diff changeset
2736 + MODULE_DEFINABLE_TYPE_COUNT];
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2737
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2738 static void
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2739 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2740 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
2741 int type_index = h->type;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2742
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2743 if (((struct lcrecord_header *) h)->free)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2744 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2745 gc_checking_assert (!free_p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2746 lcrecord_stats[type_index].instances_on_free_list++;
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 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2749 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2750 const struct lrecord_implementation *implementation =
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2751 LHEADER_IMPLEMENTATION (h);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2752
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2753 Bytecount sz = (implementation->size_in_bytes_method ?
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2754 implementation->size_in_bytes_method (h) :
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2755 implementation->static_size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2756 if (free_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2757 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2758 lcrecord_stats[type_index].instances_freed++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2759 lcrecord_stats[type_index].bytes_freed += sz;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2760 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2761 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2762 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2763 lcrecord_stats[type_index].instances_in_use++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2764 lcrecord_stats[type_index].bytes_in_use += sz;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2765 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2766 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2767 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2768
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2769
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2770 /* Free all unmarked records */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2771 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2772 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
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 struct lcrecord_header *header;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2775 int num_used = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2776 /* int total_size = 0; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2777
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2778 xzero (lcrecord_stats); /* Reset all statistics to 0. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2779
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2780 /* First go through and call all the finalize methods.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2781 Then go through and free the objects. There used to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2782 be only one loop here, with the call to the finalizer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2783 occurring directly before the xfree() below. That
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2784 is marginally faster but much less safe -- if the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2785 finalize method for an object needs to reference any
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2786 other objects contained within it (and many do),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2787 we could easily be screwed by having already freed that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2788 other object. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2789
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2790 for (header = *prev; header; header = header->next)
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 struct lrecord_header *h = &(header->lheader);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2793
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2794 GC_CHECK_LHEADER_INVARIANTS (h);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2795
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2796 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2797 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2798 if (LHEADER_IMPLEMENTATION (h)->finalizer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2799 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2800 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2801 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2802
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2803 for (header = *prev; header; )
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 struct lrecord_header *h = &(header->lheader);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2806 if (MARKED_RECORD_HEADER_P (h))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2807 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2808 if (! C_READONLY_RECORD_HEADER_P (h))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2809 UNMARK_RECORD_HEADER (h);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2810 num_used++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2811 /* total_size += n->implementation->size_in_bytes (h);*/
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2812 /* #### May modify header->next on a C_READONLY lcrecord */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2813 prev = &(header->next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2814 header = *prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2815 tick_lcrecord_stats (h, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2816 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2817 else
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 struct lcrecord_header *next = header->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2820 *prev = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2821 tick_lcrecord_stats (h, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2822 /* used to call finalizer right here. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2823 xfree (header);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2824 header = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2825 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2826 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2827 *used = num_used;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2828 /* *total = total_size; */
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2831
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2832 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2833 sweep_bit_vectors_1 (Lisp_Object *prev,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2834 int *used, int *total, int *storage)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2835 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2836 Lisp_Object bit_vector;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2837 int num_used = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2838 int total_size = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2839 int total_storage = 0;
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 /* BIT_VECTORP fails because the objects are marked, which changes
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2842 their implementation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2843 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2844 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2845 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2846 int len = v->size;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2847 if (MARKED_RECORD_P (bit_vector))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2848 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2849 if (! C_READONLY_RECORD_HEADER_P(&(v->lheader)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2850 UNMARK_RECORD_HEADER (&(v->lheader));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2851 total_size += len;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2852 total_storage +=
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2853 MALLOC_OVERHEAD +
456
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 454
diff changeset
2854 FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long,
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 454
diff changeset
2855 bits, BIT_VECTOR_LONG_STORAGE (len));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2856 num_used++;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2857 /* #### May modify next on a C_READONLY bitvector */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2858 prev = &(bit_vector_next (v));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2859 bit_vector = *prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2860 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2861 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2862 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2863 Lisp_Object next = bit_vector_next (v);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2864 *prev = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2865 xfree (v);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2866 bit_vector = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2867 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2868 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2869 *used = num_used;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2870 *total = total_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2871 *storage = total_storage;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2872 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2873
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2874 /* And the Lord said: Thou shalt use the `c-backslash-region' command
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2875 to make macros prettier. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2876
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2877 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2878
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2879 #define SWEEP_FIXED_TYPE_BLOCK_1(typename, obj_type, lheader) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2880 do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2881 struct typename##_block *SFTB_current; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2882 int SFTB_limit; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2883 int num_free = 0, num_used = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2884 \
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2885 for (SFTB_current = current_##typename##_block, \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2886 SFTB_limit = current_##typename##_block_index; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2887 SFTB_current; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2888 ) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2889 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2890 int SFTB_iii; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2891 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2892 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2893 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2894 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2895 \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2896 if (LRECORD_FREE_P (SFTB_victim)) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2897 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2898 num_free++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2899 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2900 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2901 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2902 num_used++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2903 } \
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2904 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2905 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2906 num_free++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2907 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2908 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2909 else \
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 num_used++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2912 UNMARK_##typename (SFTB_victim); \
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 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2915 SFTB_current = SFTB_current->prev; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2916 SFTB_limit = countof (current_##typename##_block->block); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2917 } \
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 gc_count_num_##typename##_in_use = num_used; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2920 gc_count_num_##typename##_freelist = num_free; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2921 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2922
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2923 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2924
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2925 #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
2926 do { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2927 struct typename##_block *SFTB_current; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2928 struct typename##_block **SFTB_prev; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2929 int SFTB_limit; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2930 int num_free = 0, num_used = 0; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2931 \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2932 typename##_free_list = 0; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2933 \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2934 for (SFTB_prev = &current_##typename##_block, \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2935 SFTB_current = current_##typename##_block, \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2936 SFTB_limit = current_##typename##_block_index; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2937 SFTB_current; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2938 ) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2939 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2940 int SFTB_iii; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2941 int SFTB_empty = 1; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2942 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
2943 \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2944 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
2945 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2946 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
2947 \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2948 if (LRECORD_FREE_P (SFTB_victim)) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2949 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2950 num_free++; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2951 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
2952 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2953 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
2954 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2955 SFTB_empty = 0; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2956 num_used++; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2957 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2958 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
2959 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2960 num_free++; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2961 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2962 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2963 else \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2964 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2965 SFTB_empty = 0; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2966 num_used++; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2967 UNMARK_##typename (SFTB_victim); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2968 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2969 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2970 if (!SFTB_empty) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2971 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2972 SFTB_prev = &(SFTB_current->prev); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2973 SFTB_current = SFTB_current->prev; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2974 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2975 else if (SFTB_current == current_##typename##_block \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2976 && !SFTB_current->prev) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2977 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2978 /* No real point in freeing sole allocation block */ \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2979 break; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2980 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2981 else \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2982 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2983 struct typename##_block *SFTB_victim_block = SFTB_current; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2984 if (SFTB_victim_block == current_##typename##_block) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2985 current_##typename##_block_index \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2986 = countof (current_##typename##_block->block); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2987 SFTB_current = SFTB_current->prev; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2988 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2989 *SFTB_prev = SFTB_current; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2990 xfree (SFTB_victim_block); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2991 /* 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
2992 typename##_free_list = SFTB_old_free_list; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2993 num_free -= SFTB_limit; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2994 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2995 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2996 SFTB_limit = countof (current_##typename##_block->block); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2997 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2998 \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2999 gc_count_num_##typename##_in_use = num_used; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3000 gc_count_num_##typename##_freelist = num_free; \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3001 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3002
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3003 #endif /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3004
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3005 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3006 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
3007
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3008
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3009
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 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3012 sweep_conses (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3013 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3014 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3015 #define ADDITIONAL_FREE_cons(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3016
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3017 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3018 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3019
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3020 /* Explicitly free a cons cell. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3021 void
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3022 free_cons (Lisp_Cons *ptr)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3023 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3024 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3025 /* 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
3026 always be four-byte aligned. If this cons cell has already been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3027 placed on the free list, however, its car will probably contain
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3028 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
3029 had all its 0's and 1's inverted. This allows for a quick
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3030 check to make sure we're not freeing something already freed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3031 if (POINTER_TYPE_P (XTYPE (ptr->car)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3032 ASSERT_VALID_POINTER (XPNTR (ptr->car));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3033 #endif /* ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3034
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3035 #ifndef ALLOC_NO_POOLS
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3036 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3037 #endif /* ALLOC_NO_POOLS */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3038 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3039
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3040 /* explicitly free a list. You **must make sure** that you have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3041 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
3042 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
3043 are, you will lose. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3044
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3045 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3046 free_list (Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3047 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3048 Lisp_Object rest, next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3049
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3050 for (rest = list; !NILP (rest); rest = next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3051 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3052 next = XCDR (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3053 free_cons (XCONS (rest));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3054 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3055 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3056
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3057 /* explicitly free an alist. You **must make sure** that you have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3058 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
3059 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
3060 are, you will lose. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3061
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3062 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3063 free_alist (Lisp_Object alist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3064 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3065 Lisp_Object rest, next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3066
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3067 for (rest = alist; !NILP (rest); rest = next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3068 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3069 next = XCDR (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3070 free_cons (XCONS (XCAR (rest)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3071 free_cons (XCONS (rest));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3072 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3073 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3074
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3075 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3076 sweep_compiled_functions (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3077 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3078 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3079 #define ADDITIONAL_FREE_compiled_function(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3080
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3081 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3082 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3083
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3084
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3085 #ifdef LISP_FLOAT_TYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3086 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3087 sweep_floats (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3088 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3089 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3090 #define ADDITIONAL_FREE_float(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3091
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3092 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3093 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3094 #endif /* LISP_FLOAT_TYPE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3095
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3096 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3097 sweep_symbols (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3098 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3099 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3100 #define ADDITIONAL_FREE_symbol(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3101
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3102 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
428
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 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3106 sweep_extents (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3107 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3108 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3109 #define ADDITIONAL_FREE_extent(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3110
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3111 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3112 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3113
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3114 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3115 sweep_events (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3116 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3117 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3118 #define ADDITIONAL_FREE_event(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3119
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3120 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3121 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3122
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3123 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3124 sweep_markers (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3125 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3126 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3127 #define ADDITIONAL_FREE_marker(ptr) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3128 do { Lisp_Object tem; \
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3129 tem = wrap_marker (ptr); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3130 unchain_marker (tem); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3131 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3132
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3133 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3134 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3135
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3136 /* Explicitly free a marker. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3137 void
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3138 free_marker (Lisp_Marker *ptr)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3139 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3140 /* Perhaps this will catch freeing an already-freed marker. */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3141 gc_checking_assert (ptr->lheader.type == lrecord_type_marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3142
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3143 #ifndef ALLOC_NO_POOLS
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3144 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3145 #endif /* ALLOC_NO_POOLS */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3146 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3147
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3148
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3149 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3150
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3151 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3152 verify_string_chars_integrity (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3153 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3154 struct string_chars_block *sb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3155
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3156 /* Scan each existing string block sequentially, string by string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3157 for (sb = first_string_chars_block; sb; sb = sb->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3158 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3159 int pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3160 /* POS is the index of the next string in the block. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3161 while (pos < sb->pos)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3162 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3163 struct string_chars *s_chars =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3164 (struct string_chars *) &(sb->string_chars[pos]);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3165 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3166 int size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3167 int fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3168
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3169 /* 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
3170 STRING pointer is NULL) then this is an unused chunk of
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3171 string storage. (See below.) */
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3172
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3173 if (STRING_CHARS_FREE_P (s_chars))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3174 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3175 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3176 pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3177 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3178 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3179
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3180 string = s_chars->string;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3181 /* Must be 32-bit aligned. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3182 assert ((((int) string) & 3) == 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3183
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3184 size = string->size_;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3185 fullsize = STRING_FULLSIZE (size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3186
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3187 assert (!BIG_STRING_FULLSIZE_P (fullsize));
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3188 assert (string->data_ == s_chars->chars);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3189 pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3190 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3191 assert (pos == sb->pos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3192 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3193 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3194
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3195 #endif /* MULE && ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3196
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3197 /* Compactify string chars, relocating the reference to each --
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3198 free any empty string_chars_block we see. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3199 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3200 compact_string_chars (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3201 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3202 struct string_chars_block *to_sb = first_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3203 int to_pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3204 struct string_chars_block *from_sb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3205
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3206 /* Scan each existing string block sequentially, string by string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3207 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
3208 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3209 int from_pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3210 /* FROM_POS is the index of the next string in the block. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3211 while (from_pos < from_sb->pos)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3212 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3213 struct string_chars *from_s_chars =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3214 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3215 struct string_chars *to_s_chars;
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3216 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3217 int size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3218 int fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3219
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3220 /* 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
3221 STRING pointer is NULL) then this is an unused chunk of
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3222 string storage. This happens under Mule when a string's
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3223 size changes in such a way that its fullsize changes.
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3224 (Strings can change size because a different-length
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3225 character can be substituted for another character.)
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3226 In this case, after the bogus string pointer is the
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3227 "fullsize" of this entry, i.e. how many bytes to skip. */
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3228
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3229 if (STRING_CHARS_FREE_P (from_s_chars))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3230 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3231 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3232 from_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3233 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3234 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3235
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3236 string = from_s_chars->string;
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3237 assert (!(LRECORD_FREE_P (string)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3238
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3239 size = string->size_;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3240 fullsize = STRING_FULLSIZE (size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3241
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3242 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3243
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3244 /* 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
3245 if (! MARKED_RECORD_HEADER_P (&(string->u.lheader)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3246 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3247 from_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3248 continue;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3251 /* 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
3252 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
3253 cannot advance past FROM_SB here since FROM_SB is large enough
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3254 to currently contain this string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3255 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3256 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3257 to_sb->pos = to_pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3258 to_sb = to_sb->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3259 to_pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3260 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3261
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3262 /* Compute new address of this string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3263 and update TO_POS for the space being used. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3264 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3265
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3266 /* Copy the string_chars to the new place. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3267 if (from_s_chars != to_s_chars)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3268 memmove (to_s_chars, from_s_chars, fullsize);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3269
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3270 /* Relocate FROM_S_CHARS's reference */
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
3271 set_lispstringp_data (string, &(to_s_chars->chars[0]));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3272
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3273 from_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3274 to_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3275 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3276 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3277
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3278 /* Set current to the last string chars block still used and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3279 free any that follow. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3280 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3281 struct string_chars_block *victim;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3282
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3283 for (victim = to_sb->next; victim; )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3284 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3285 struct string_chars_block *next = victim->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3286 xfree (victim);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3287 victim = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3288 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3289
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3290 current_string_chars_block = to_sb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3291 current_string_chars_block->pos = to_pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3292 current_string_chars_block->next = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3293 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3294 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3295
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3296 #if 1 /* Hack to debug missing purecopy's */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3297 static int debug_string_purity;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3298
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3299 static void
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3300 debug_string_purity_print (Lisp_Object p)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3301 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3302 Charcount i;
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
3303 Charcount s = string_char_length (p);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3304 stderr_out ("\"");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3305 for (i = 0; i < s; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3306 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
3307 Emchar ch = string_emchar (p, i);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3308 if (ch < 32 || ch >= 126)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3309 stderr_out ("\\%03o", ch);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3310 else if (ch == '\\' || ch == '\"')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3311 stderr_out ("\\%c", ch);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3312 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3313 stderr_out ("%c", ch);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3314 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3315 stderr_out ("\"\n");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3316 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3317 #endif /* 1 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3318
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3319
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3320 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3321 sweep_strings (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3322 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
3323 int num_small_used = 0;
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
3324 Bytecount num_small_bytes = 0, num_bytes = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3325 int debug = debug_string_purity;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3326
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3327 #define UNMARK_string(ptr) do { \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3328 Lisp_String *p = (ptr); \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3329 Bytecount size = p->size_; \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3330 UNMARK_RECORD_HEADER (&(p->u.lheader)); \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3331 num_bytes += size; \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3332 if (!BIG_STRING_SIZE_P (size)) \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3333 { \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3334 num_small_bytes += size; \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3335 num_small_used++; \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3336 } \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3337 if (debug) \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3338 debug_string_purity_print (wrap_string (p)); \
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3339 } while (0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3340 #define ADDITIONAL_FREE_string(ptr) do { \
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3341 Bytecount size = ptr->size_; \
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3342 if (BIG_STRING_SIZE_P (size)) \
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3343 xfree (ptr->data_); \
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3344 } while (0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3345
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3346 SWEEP_FIXED_TYPE_BLOCK_1 (string, Lisp_String, u.lheader);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3347
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3348 gc_count_num_short_string_in_use = num_small_used;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3349 gc_count_string_total_size = num_bytes;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3350 gc_count_short_string_total_size = num_small_bytes;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3351 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3352
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3353
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3354 /* I hate duplicating all this crap! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3355 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3356 marked_p (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3357 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3358 /* Checks we used to perform. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3359 /* if (EQ (obj, Qnull_pointer)) return 1; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3360 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3361 /* if (PURIFIED (XPNTR (obj))) return 1; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3362
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3363 if (XTYPE (obj) == Lisp_Type_Record)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3364 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3365 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3366
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3367 GC_CHECK_LHEADER_INVARIANTS (lheader);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3368
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3369 return MARKED_RECORD_HEADER_P (lheader);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3370 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3371 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3372 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3373
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3374 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3375 gc_sweep (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3376 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3377 /* Free all unmarked records. Do this at the very beginning,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3378 before anything else, so that the finalize methods can safely
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3379 examine items in the objects. sweep_lcrecords_1() makes
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3380 sure to call all the finalize methods *before* freeing anything,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3381 to complete the safety. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3382 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3383 int ignored;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3384 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3385 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3386
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3387 compact_string_chars ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3388
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3389 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3390 macros) must be *extremely* careful to make sure they're not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3391 referencing freed objects. The only two existing finalize
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3392 methods (for strings and markers) pass muster -- the string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3393 finalizer doesn't look at anything but its own specially-
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3394 created block, and the marker finalizer only looks at live
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3395 buffers (which will never be freed) and at the markers before
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3396 and after it in the chain (which, by induction, will never be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3397 freed because if so, they would have already removed themselves
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3398 from the chain). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3399
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3400 /* Put all unmarked strings on free list, free'ing the string chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3401 of large unmarked strings */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3402 sweep_strings ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3403
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3404 /* Put all unmarked conses on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3405 sweep_conses ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3406
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3407 /* Free all unmarked bit vectors */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3408 sweep_bit_vectors_1 (&all_bit_vectors,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3409 &gc_count_num_bit_vector_used,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3410 &gc_count_bit_vector_total_size,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3411 &gc_count_bit_vector_storage);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3412
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3413 /* Free all unmarked compiled-function objects */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3414 sweep_compiled_functions ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3415
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3416 #ifdef LISP_FLOAT_TYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3417 /* Put all unmarked floats on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3418 sweep_floats ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3419 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3420
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3421 /* Put all unmarked symbols on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3422 sweep_symbols ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3423
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3424 /* Put all unmarked extents on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3425 sweep_extents ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3426
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3427 /* Put all unmarked markers on free list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3428 Dechain each one first from the buffer into which it points. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3429 sweep_markers ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3430
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3431 sweep_events ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3432
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3433 #ifdef PDUMP
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3434 pdump_objects_unmark ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3435 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3436 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3437
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3438 /* Clearing for disksave. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3439
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3440 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3441 disksave_object_finalization (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3442 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3443 /* It's important that certain information from the environment not get
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3444 dumped with the executable (pathnames, environment variables, etc.).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3445 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
3446 clear some known-to-be-garbage blocks of memory, so that leftover
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3447 results of old evaluation don't look like potential problems.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3448 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
3449 to turn those strings into garbage.
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3450 */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3451
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3452 /* Yeah, this list is pretty ad-hoc... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3453 Vprocess_environment = Qnil;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3454 env_initted = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3455 Vexec_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3456 Vdata_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3457 Vsite_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3458 Vdoc_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3459 Vconfigure_info_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3460 Vexec_path = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3461 Vload_path = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3462 /* Vdump_load_path = Qnil; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3463 /* Release hash tables for locate_file */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3464 Flocate_file_clear_hashing (Qt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3465 uncache_home_directory ();
776
79940b592197 [xemacs-hg @ 2002-03-15 07:43:14 by ben]
ben
parents: 771
diff changeset
3466 zero_out_command_line_status_vars ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3467
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3468 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3469 defined(LOADHIST_BUILTIN))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3470 Vload_history = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3471 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3472 Vshell_file_name = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3473
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3474 garbage_collect_1 ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3475
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3476 /* Run the disksave finalization methods of all live objects. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3477 disksave_object_finalization_1 ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3478
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3479 /* Zero out the uninitialized (really, unused) part of the containers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3480 for the live strings. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3481 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3482 struct string_chars_block *scb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3483 for (scb = first_string_chars_block; scb; scb = scb->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3484 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3485 int count = sizeof (scb->string_chars) - scb->pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3486
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3487 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3488 if (count != 0)
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3489 {
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3490 /* from the block's fill ptr to the end */
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3491 memset ((scb->string_chars + scb->pos), 0, count);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3492 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3493 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3494 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3495
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3496 /* There, that ought to be enough... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3497
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3498 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3499
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3500
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3501 static Lisp_Object
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3502 restore_gc_inhibit (Lisp_Object val)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3503 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3504 gc_currently_forbidden = XINT (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3505 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3506 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3507
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3508 int
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3509 begin_gc_forbidden (void)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3510 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3511 int speccount = record_unwind_protect (restore_gc_inhibit,
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3512 make_int (gc_currently_forbidden));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3513 gc_currently_forbidden = 1;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3514 return speccount;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3515 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3516
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3517 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3518 end_gc_forbidden (int count)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3519 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3520 unbind_to (count);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3521 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3522
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3523 /* 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
3524 static int gc_hooks_inhibited;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3525
611
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3526 struct post_gc_action
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3527 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3528 void (*fun) (void *);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3529 void *arg;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3530 };
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3531
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3532 typedef struct post_gc_action post_gc_action;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3533
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3534 typedef struct
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3535 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3536 Dynarr_declare (post_gc_action);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3537 } post_gc_action_dynarr;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3538
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3539 static post_gc_action_dynarr *post_gc_actions;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3540
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3541 /* 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
3542 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
3543 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
3544 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
3545
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3546 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
3547 And NEVER signal an error.
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3548 */
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3549
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3550 void
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3551 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
3552 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3553 post_gc_action action;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3554
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3555 if (!post_gc_actions)
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3556 post_gc_actions = Dynarr_new (post_gc_action);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3557
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3558 action.fun = fun;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3559 action.arg = arg;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3560
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3561 Dynarr_add (post_gc_actions, action);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3562 }
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3563
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3564 static void
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3565 run_post_gc_actions (void)
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3566 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3567 int i;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3568
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3569 if (post_gc_actions)
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3570 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3571 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
3572 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3573 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
3574 (action.fun) (action.arg);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3575 }
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3576
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3577 Dynarr_reset (post_gc_actions);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3578 }
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3579 }
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3580
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3581
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3582 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3583 garbage_collect_1 (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3584 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3585 #if MAX_SAVE_STACK > 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3586 char stack_top_variable;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3587 extern char *stack_bottom;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3588 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3589 struct frame *f;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3590 int speccount;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3591 int cursor_changed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3592 Lisp_Object pre_gc_cursor;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3593 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3594
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3595 if (gc_in_progress
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3596 || gc_currently_forbidden
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3597 || in_display
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3598 || preparing_for_armageddon)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3599 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3600
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3601 /* We used to call selected_frame() here.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3602
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3603 The following functions cannot be called inside GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3604 so we move to after the above tests. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3605 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3606 Lisp_Object frame;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3607 Lisp_Object device = Fselected_device (Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3608 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3609 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3610 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3611 if (NILP (frame))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 551
diff changeset
3612 invalid_state ("No frames exist on device", device);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3613 f = XFRAME (frame);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3614 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3615
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3616 pre_gc_cursor = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3617 cursor_changed = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3618
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3619 GCPRO1 (pre_gc_cursor);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3620
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3621 /* Very important to prevent GC during any of the following
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3622 stuff that might run Lisp code; otherwise, we'll likely
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3623 have infinite GC recursion. */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3624 speccount = begin_gc_forbidden ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3625
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3626 if (!gc_hooks_inhibited)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3627 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3628
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3629 /* Now show the GC cursor/message. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3630 if (!noninteractive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3631 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3632 if (FRAME_WIN_P (f))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3633 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3634 Lisp_Object frame = wrap_frame (f);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3635 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3636 FRAME_SELECTED_WINDOW (f),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3637 ERROR_ME_NOT, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3638 pre_gc_cursor = f->pointer;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3639 if (POINTER_IMAGE_INSTANCEP (cursor)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3640 /* don't change if we don't know how to change back. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3641 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3642 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3643 cursor_changed = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3644 Fset_frame_pointer (frame, cursor);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3645 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3646 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3647
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3648 /* Don't print messages to the stream device. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3649 if (!cursor_changed && !FRAME_STREAM_P (f))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3650 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3651 Lisp_Object args[2], whole_msg;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3652 args[0] = (STRINGP (Vgc_message) ? Vgc_message :
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3653 build_msg_string (gc_default_message));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3654 args[1] = build_string ("...");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3655 whole_msg = Fconcat (2, args);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3656 echo_area_message (f, (Intbyte *) 0, whole_msg, 0, -1,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3657 Qgarbage_collecting);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3658 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3659 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3660
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3661 /***** Now we actually start the garbage collection. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3662
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3663 gc_in_progress = 1;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3664 inhibit_non_essential_printing_operations = 1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3665
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3666 gc_generation_number[0]++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3667
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3668 #if MAX_SAVE_STACK > 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3669
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3670 /* Save a copy of the contents of the stack, for debugging. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3671 if (!purify_flag)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3672 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3673 /* 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
3674 static char *stack_copy;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3675 static Bytecount stack_copy_size;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3676
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3677 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
3678 Bytecount stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3679 if (stack_size < MAX_SAVE_STACK)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3680 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3681 if (stack_copy_size < stack_size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3682 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3683 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3684 stack_copy_size = stack_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3685 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3686
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3687 memcpy (stack_copy,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3688 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3689 stack_size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3690 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3691 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3692 #endif /* MAX_SAVE_STACK > 0 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3693
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3694 /* Do some totally ad-hoc resource clearing. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3695 /* #### generalize this? */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3696 clear_event_resource ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3697 cleanup_specifiers ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3698
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3699 /* Mark all the special slots that serve as the roots of accessibility. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3700
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3701 { /* staticpro() */
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3702 Lisp_Object **p = Dynarr_begin (staticpros);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3703 Elemcount count;
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3704 for (count = Dynarr_length (staticpros); count; count--)
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3705 mark_object (**p++);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3706 }
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3707
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3708 { /* staticpro_nodump() */
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3709 Lisp_Object **p = Dynarr_begin (staticpros_nodump);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3710 Elemcount count;
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3711 for (count = Dynarr_length (staticpros_nodump); count; count--)
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3712 mark_object (**p++);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3713 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3714
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3715 { /* GCPRO() */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3716 struct gcpro *tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3717 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3718 for (tail = gcprolist; tail; tail = tail->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3719 for (i = 0; i < tail->nvars; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3720 mark_object (tail->var[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3721 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3722
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3723 { /* specbind() */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3724 struct specbinding *bind;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3725 for (bind = specpdl; bind != specpdl_ptr; bind++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3726 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3727 mark_object (bind->symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3728 mark_object (bind->old_value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3729 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3730 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3731
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3732 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3733 struct catchtag *catch;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3734 for (catch = catchlist; catch; catch = catch->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3735 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3736 mark_object (catch->tag);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3737 mark_object (catch->val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3738 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3739 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3740
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3741 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3742 struct backtrace *backlist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3743 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3744 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3745 int nargs = backlist->nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3746 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3747
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3748 mark_object (*backlist->function);
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3749 if (nargs < 0 /* nargs == UNEVALLED || nargs == MANY */)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3750 mark_object (backlist->args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3751 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3752 for (i = 0; i < nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3753 mark_object (backlist->args[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3754 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3755 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3756
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3757 mark_profiling_info ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3758
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3759 /* OK, now do the after-mark stuff. This is for things that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3760 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
3761 There may be complex dependencies between such objects -- e.g.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3762 a weak hash table might be unmarked, but after processing a later
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3763 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
3764 iterate until nothing more gets marked. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3765
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3766 while (finish_marking_weak_hash_tables () > 0 ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3767 finish_marking_weak_lists () > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3768 ;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3769
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3770 /* And prune (this needs to be called after everything else has been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3771 marked and before we do any sweeping). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3772 /* #### this is somewhat ad-hoc and should probably be an object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3773 method */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3774 prune_weak_hash_tables ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3775 prune_weak_lists ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3776 prune_specifiers ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3777 prune_syntax_tables ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3778
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3779 gc_sweep ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3780
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3781 consing_since_gc = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3782 #ifndef DEBUG_XEMACS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3783 /* Allow you to set it really fucking low if you really want ... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3784 if (gc_cons_threshold < 10000)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3785 gc_cons_threshold = 10000;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3786 #endif
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
3787 recompute_need_to_garbage_collect ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3788
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3789 inhibit_non_essential_printing_operations = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3790 gc_in_progress = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3791
611
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3792 run_post_gc_actions ();
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3793
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3794 /******* End of garbage collection ********/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3795
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3796 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3797
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3798 /* Now remove the GC cursor/message */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3799 if (!noninteractive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3800 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3801 if (cursor_changed)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3802 Fset_frame_pointer (wrap_frame (f), pre_gc_cursor);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3803 else if (!FRAME_STREAM_P (f))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3804 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3805 /* Show "...done" only if the echo area would otherwise be empty. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3806 if (NILP (clear_echo_area (selected_frame (),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3807 Qgarbage_collecting, 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3808 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3809 Lisp_Object args[2], whole_msg;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3810 args[0] = (STRINGP (Vgc_message) ? Vgc_message :
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3811 build_msg_string (gc_default_message));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3812 args[1] = build_msg_string ("... done");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3813 whole_msg = Fconcat (2, args);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3814 echo_area_message (selected_frame (), (Intbyte *) 0,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3815 whole_msg, 0, -1,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3816 Qgarbage_collecting);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3817 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3818 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3819 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3820
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3821 /* now stop inhibiting GC */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3822 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3823
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3824 if (!breathing_space)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3825 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3826 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3827 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3828
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3829 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3830 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3831 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3832
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3833 /* Debugging aids. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3834
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3835 static Lisp_Object
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3836 gc_plist_hack (const Char_ASCII *name, int value, Lisp_Object tail)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3837 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3838 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3839 or portable numeric datatypes, or bit-vectors, or characters, or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3840 arrays, or exceptions, or ...) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3841 return cons3 (intern (name), make_int (value), tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3842 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3843
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3844 #define HACK_O_MATIC(type, name, pl) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3845 int s = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3846 struct type##_block *x = current_##type##_block; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3847 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3848 (pl) = gc_plist_hack ((name), s, (pl)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3849 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3850
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3851 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3852 Reclaim storage for Lisp objects no longer needed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3853 Return info on amount of space in use:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3854 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3855 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3856 PLIST)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3857 where `PLIST' is a list of alternating keyword/value pairs providing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3858 more detailed information.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3859 Garbage collection happens automatically if you cons more than
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3860 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3861 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3862 ())
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3863 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3864 Lisp_Object pl = Qnil;
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
3865 int i;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3866 int gc_count_vector_total_size = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3867
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3868 garbage_collect_1 ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3869
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3870 for (i = 0; i < lrecord_type_count; i++)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3871 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3872 if (lcrecord_stats[i].bytes_in_use != 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3873 || lcrecord_stats[i].bytes_freed != 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3874 || lcrecord_stats[i].instances_on_free_list != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3875 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3876 char buf [255];
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3877 const char *name = lrecord_implementations_table[i]->name;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3878 int len = strlen (name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3879 /* save this for the FSFmacs-compatible part of the summary */
460
223736d75acb Import from CVS: tag r21-2-45
cvs
parents: 458
diff changeset
3880 if (i == lrecord_type_vector)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3881 gc_count_vector_total_size =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3882 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3883
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3884 sprintf (buf, "%s-storage", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3885 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3886 /* Okay, simple pluralization check for `symbol-value-varalias' */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3887 if (name[len-1] == 's')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3888 sprintf (buf, "%ses-freed", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3889 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3890 sprintf (buf, "%ss-freed", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3891 if (lcrecord_stats[i].instances_freed != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3892 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3893 if (name[len-1] == 's')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3894 sprintf (buf, "%ses-on-free-list", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3895 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3896 sprintf (buf, "%ss-on-free-list", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3897 if (lcrecord_stats[i].instances_on_free_list != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3898 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3899 pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3900 if (name[len-1] == 's')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3901 sprintf (buf, "%ses-used", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3902 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3903 sprintf (buf, "%ss-used", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3904 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3905 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3906 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3907
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3908 HACK_O_MATIC (extent, "extent-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3909 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3910 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
3911 HACK_O_MATIC (event, "event-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3912 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3913 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
3914 HACK_O_MATIC (marker, "marker-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3915 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3916 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
3917 #ifdef LISP_FLOAT_TYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3918 HACK_O_MATIC (float, "float-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3919 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3920 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3921 #endif /* LISP_FLOAT_TYPE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3922 HACK_O_MATIC (string, "string-header-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3923 pl = gc_plist_hack ("long-strings-total-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3924 gc_count_string_total_size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3925 - gc_count_short_string_total_size, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3926 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3927 pl = gc_plist_hack ("short-strings-total-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3928 gc_count_short_string_total_size, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3929 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3930 pl = gc_plist_hack ("long-strings-used",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3931 gc_count_num_string_in_use
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3932 - gc_count_num_short_string_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3933 pl = gc_plist_hack ("short-strings-used",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3934 gc_count_num_short_string_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3935
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3936 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3937 pl = gc_plist_hack ("compiled-functions-free",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3938 gc_count_num_compiled_function_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3939 pl = gc_plist_hack ("compiled-functions-used",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3940 gc_count_num_compiled_function_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3941
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3942 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3943 pl = gc_plist_hack ("bit-vectors-total-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3944 gc_count_bit_vector_total_size, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3945 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3946
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3947 HACK_O_MATIC (symbol, "symbol-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3948 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3949 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
3950
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3951 HACK_O_MATIC (cons, "cons-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3952 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3953 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
3954
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3955 /* The things we do for backwards-compatibility */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3956 return
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3957 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3958 make_int (gc_count_num_cons_freelist)),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3959 Fcons (make_int (gc_count_num_symbol_in_use),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3960 make_int (gc_count_num_symbol_freelist)),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3961 Fcons (make_int (gc_count_num_marker_in_use),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3962 make_int (gc_count_num_marker_freelist)),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3963 make_int (gc_count_string_total_size),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3964 make_int (gc_count_vector_total_size),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3965 pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3966 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3967 #undef HACK_O_MATIC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3968
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3969 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3970 Return the number of bytes consed since the last garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3971 \"Consed\" is a misnomer in that this actually counts allocation
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3972 of all different kinds of objects, not just conses.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3973
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3974 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3975 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3976 ())
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3977 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3978 return make_int (consing_since_gc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3979 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3980
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3981 #if 0
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3982 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
3983 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
3984 This may be helpful in debugging XEmacs's memory usage.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3985 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
3986 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3987 ())
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3988 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3989 return make_int ((EMACS_INT) sbrk (0) / 1024);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3990 }
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3991 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3992
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
3993 DEFUN ("memory-usage", Fmemory_usage, 0, 0, 0, /*
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
3994 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
3995 This may be helpful in debugging XEmacs's memory usage.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
3996 */
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
3997 ())
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
3998 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
3999 return make_int (total_data_usage ());
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4000 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4001
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4002 /* 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
4003 static void
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4004 recompute_need_to_garbage_collect (void)
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4005 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4006 if (always_gc)
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4007 need_to_garbage_collect = 1;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4008 else
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4009 need_to_garbage_collect =
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4010 (consing_since_gc > gc_cons_threshold
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4011 #if 0 /* #### implement this better */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4012 &&
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4013 (100 * consing_since_gc) / total_data_usage () >=
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4014 gc_cons_percentage
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4015 #endif /* 0 */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4016 );
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4017 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4018
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4019
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4020 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4021 object_dead_p (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4022 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4023 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4024 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4025 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4026 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4027 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4028 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4029 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4030 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4031
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4032 #ifdef MEMORY_USAGE_STATS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4033
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4034 /* Attempt to determine the actual amount of space that is used for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4035 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4036
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4037 It seems that the following holds:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4038
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4039 1. When using the old allocator (malloc.c):
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4040
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4041 -- blocks are always allocated in chunks of powers of two. For
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4042 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
4043 defined, 20 bytes if it is defined. In other words, a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4044 one-byte allocation needs 8 bytes of overhead for a total of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4045 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
4046 it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4047
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4048 2. When using the new allocator (gmalloc.c):
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4049
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4050 -- blocks are always allocated in chunks of powers of two up
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4051 to 4096 bytes. Larger blocks are allocated in chunks of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4052 an integral multiple of 4096 bytes. The minimum block
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4053 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4054 is defined. There is no per-block overhead, but there
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4055 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4056 allocated.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4057
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4058 3. When using the system malloc, anything goes, but they are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4059 generally slower and more space-efficient than the GNU
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4060 allocators. One possibly reasonable assumption to make
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4061 for want of better data is that sizeof (void *), or maybe
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4062 2 * sizeof (void *), is required as overhead and that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4063 blocks are allocated in the minimum required size except
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4064 that some minimum block size is imposed (e.g. 16 bytes). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4065
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4066 Bytecount
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4067 malloced_storage_size (void *ptr, Bytecount claimed_size,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4068 struct overhead_stats *stats)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4069 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4070 Bytecount orig_claimed_size = claimed_size;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4071
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4072 #ifdef GNU_MALLOC
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4073 if (claimed_size < (Bytecount) (2 * sizeof (void *)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4074 claimed_size = 2 * sizeof (void *);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4075 # ifdef SUNOS_LOCALTIME_BUG
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4076 if (claimed_size < 16)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4077 claimed_size = 16;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4078 # endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4079 if (claimed_size < 4096)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4080 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4081 int log = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4082
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4083 /* 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
4084 the block size needed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4085 claimed_size--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4086 /* It's big, it's heavy, it's wood! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4087 while ((claimed_size /= 2) != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4088 ++log;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4089 claimed_size = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4090 /* It's better than bad, it's good! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4091 while (log > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4092 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4093 claimed_size *= 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4094 log--;
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 /* We have to come up with some average about the amount of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4097 blocks used. */
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4098 if ((Bytecount) (rand () & 4095) < claimed_size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4099 claimed_size += 3 * sizeof (void *);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4100 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4101 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4102 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4103 claimed_size += 4095;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4104 claimed_size &= ~4095;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4105 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4106 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4107
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4108 #elif defined (SYSTEM_MALLOC)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4109
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4110 if (claimed_size < 16)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4111 claimed_size = 16;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4112 claimed_size += 2 * sizeof (void *);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4113
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4114 #else /* old GNU allocator */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4115
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4116 # ifdef rcheck /* #### may not be defined here */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4117 claimed_size += 20;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4118 # else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4119 claimed_size += 8;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4120 # endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4121 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4122 int log = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4123
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4124 /* 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
4125 the block size needed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4126 claimed_size--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4127 /* It's big, it's heavy, it's wood! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4128 while ((claimed_size /= 2) != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4129 ++log;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4130 claimed_size = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4131 /* It's better than bad, it's good! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4132 while (log > 0)
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 claimed_size *= 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4135 log--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4136 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4137 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4138
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4139 #endif /* old GNU allocator */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4140
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4141 if (stats)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4142 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4143 stats->was_requested += orig_claimed_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4144 stats->malloc_overhead += claimed_size - orig_claimed_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4145 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4146 return claimed_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4147 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4148
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4149 Bytecount
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4150 fixed_type_block_overhead (Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4151 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4152 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
4153 Bytecount overhead = 0;
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4154 Bytecount storage_size = malloced_storage_size (0, per_block, 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4155 while (size >= per_block)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4156 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4157 size -= per_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4158 overhead += sizeof (void *) + per_block - storage_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4159 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4160 if (rand () % per_block < size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4161 overhead += sizeof (void *) + per_block - storage_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4162 return overhead;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4163 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4164
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4165 #endif /* MEMORY_USAGE_STATS */
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4168 /* Initialization */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4169 static void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4170 common_init_alloc_once_early (void)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4171 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4172 #ifndef Qzero
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4173 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
4174 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4175
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4176 #ifndef Qnull_pointer
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4177 /* 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
4178 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
4179 Qnull_pointer = wrap_pointer_1 (0);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4180 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4181
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4182 gc_generation_number[0] = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4183 breathing_space = 0;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4184 all_bit_vectors = Qzero;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4185 Vgc_message = Qzero;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4186 all_lcrecords = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4187 ignore_malloc_warnings = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4188 #ifdef DOUG_LEA_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4189 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4190 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4191 #if 0 /* Moved to emacs.c */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4192 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4193 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4194 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4195 init_string_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4196 init_string_chars_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4197 init_cons_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4198 init_symbol_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4199 init_compiled_function_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4200 #ifdef LISP_FLOAT_TYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4201 init_float_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4202 #endif /* LISP_FLOAT_TYPE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4203 init_marker_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4204 init_extent_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4205 init_event_alloc ();
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 ignore_malloc_warnings = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4208
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4209 if (staticpros_nodump)
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4210 Dynarr_free (staticpros_nodump);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4211 staticpros_nodump = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4212 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
4213 #ifdef DEBUG_XEMACS
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4214 if (staticpro_nodump_names)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4215 Dynarr_free (staticpro_nodump_names);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4216 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
4217 Dynarr_resize (staticpro_nodump_names, 100); /* ditto */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4218 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4219
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4220 consing_since_gc = 0;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4221 need_to_garbage_collect = always_gc;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4222
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4223 #if 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4224 gc_cons_threshold = 500000; /* XEmacs change */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4225 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4226 gc_cons_threshold = 15000; /* debugging */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4227 #endif
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4228 gc_cons_percentage = 0; /* #### 20; Don't have an accurate measure of
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4229 memory usage on Windows; not verified on other
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4230 systems */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4231 lrecord_uid_counter = 259;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4232 debug_string_purity = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4233 gcprolist = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4234
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4235 gc_currently_forbidden = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4236 gc_hooks_inhibited = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4237
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
4238 #ifdef ERROR_CHECK_TYPES
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4239 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
4240 666;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4241 ERROR_ME_NOT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4242 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4243 ERROR_ME_WARN.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4244 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4245 3333632;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4246 ERROR_ME_DEBUG_WARN.
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4247 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
4248 8675309;
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
4249 #endif /* ERROR_CHECK_TYPES */
428
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
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4252 static void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4253 init_lcrecord_lists (void)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4254 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4255 int i;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4256
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4257 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
4258 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4259 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
4260 staticpro_nodump (&all_lcrecord_lists[i]);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4261 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4262 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4263
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4264 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4265 reinit_alloc_once_early (void)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4266 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4267 common_init_alloc_once_early ();
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4268 init_lcrecord_lists ();
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4269 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4270
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4271 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4272 init_alloc_once_early (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4273 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4274 common_init_alloc_once_early ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4275
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4276 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4277 int i;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4278 for (i = 0; i < countof (lrecord_implementations_table); i++)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4279 lrecord_implementations_table[i] = 0;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4280 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4281
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4282 INIT_LRECORD_IMPLEMENTATION (cons);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4283 INIT_LRECORD_IMPLEMENTATION (vector);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4284 INIT_LRECORD_IMPLEMENTATION (string);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4285 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4286
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4287 staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4288 Dynarr_resize (staticpros, 1410); /* merely a small optimization */
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4289 dump_add_root_struct_ptr (&staticpros, &staticpros_description);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4290 #ifdef DEBUG_XEMACS
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4291 staticpro_names = Dynarr_new2 (char_ptr_dynarr, char *);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4292 Dynarr_resize (staticpro_names, 1410); /* merely a small optimization */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4293 dump_add_root_struct_ptr (&staticpro_names, &staticpro_names_description);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4294 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4295
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4296 init_lcrecord_lists ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4297 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4298
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4299 void
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4300 init_alloc_early (void)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4301 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4302 gcprolist = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4303 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4304
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4305 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4306 syms_of_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4307 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4308 DEFSYMBOL (Qpre_gc_hook);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4309 DEFSYMBOL (Qpost_gc_hook);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4310 DEFSYMBOL (Qgarbage_collecting);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4311
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4312 DEFSUBR (Fcons);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4313 DEFSUBR (Flist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4314 DEFSUBR (Fvector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4315 DEFSUBR (Fbit_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4316 DEFSUBR (Fmake_byte_code);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4317 DEFSUBR (Fmake_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4318 DEFSUBR (Fmake_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4319 DEFSUBR (Fmake_bit_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4320 DEFSUBR (Fmake_string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4321 DEFSUBR (Fstring);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4322 DEFSUBR (Fmake_symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4323 DEFSUBR (Fmake_marker);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4324 DEFSUBR (Fpurecopy);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4325 DEFSUBR (Fgarbage_collect);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4326 #if 0
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4327 DEFSUBR (Fmemory_limit);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4328 #endif
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4329 DEFSUBR (Fmemory_usage);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4330 DEFSUBR (Fconsing_since_gc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4331 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4332
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4333 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4334 vars_of_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4335 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4336 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4337 *Number of bytes of consing between garbage collections.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4338 \"Consing\" is a misnomer in that this actually counts allocation
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4339 of all different kinds of objects, not just conses.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4340 Garbage collection can happen automatically once this many bytes have been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4341 allocated since the last garbage collection. All data types count.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4342
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4343 Garbage collection happens automatically when `eval' or `funcall' are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4344 called. (Note that `funcall' is called implicitly as part of evaluation.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4345 By binding this temporarily to a large number, you can effectively
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4346 prevent garbage collection during a part of the program.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4347
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4348 See also `consing-since-gc'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4349 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4350
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4351 DEFVAR_INT ("gc-cons-percentage", &gc_cons_percentage /*
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4352 *Percentage of memory allocated between garbage collections.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4353
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4354 Garbage collection will happen if this percentage of the total amount of
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4355 memory used for data has been allocated since the last garbage collection.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4356 However, it will not happen if less than `gc-cons-threshold' bytes have
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4357 been allocated -- this sets an absolute minimum in case very little data
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4358 has been allocated or the percentage is set very low. Set this to 0 to
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4359 have garbage collection always happen after `gc-cons-threshold' bytes have
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4360 been allocated, regardless of current memory usage.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4361
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4362 Garbage collection happens automatically when `eval' or `funcall' are
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4363 called. (Note that `funcall' is called implicitly as part of evaluation.)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4364 By binding this temporarily to a large number, you can effectively
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4365 prevent garbage collection during a part of the program.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4366
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4367 See also `consing-since-gc'.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4368 */ );
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4369
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4370 #ifdef DEBUG_XEMACS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4371 DEFVAR_INT ("debug-allocation", &debug_allocation /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4372 If non-zero, print out information to stderr about all objects allocated.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4373 See also `debug-allocation-backtrace-length'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4374 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4375 debug_allocation = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4376
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4377 DEFVAR_INT ("debug-allocation-backtrace-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4378 &debug_allocation_backtrace_length /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4379 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
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 debug_allocation_backtrace_length = 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4382 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4383
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4384 DEFVAR_BOOL ("purify-flag", &purify_flag /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4385 Non-nil means loading Lisp code in order to dump an executable.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4386 This means that certain objects should be allocated in readonly space.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4387 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4388
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4389 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4390 Function or functions to be run just before each garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4391 Interrupts, garbage collection, and errors are inhibited while this hook
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4392 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
4393 consing, and do not interact with the user.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4394 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4395 Vpre_gc_hook = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4396
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4397 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4398 Function or functions to be run just after each garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4399 Interrupts, garbage collection, and errors are inhibited while this hook
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4400 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
4401 consing, and do not interact with the user.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4402 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4403 Vpost_gc_hook = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4404
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4405 DEFVAR_LISP ("gc-message", &Vgc_message /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4406 String to print to indicate that a garbage collection is in progress.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4407 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
4408 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
4409 image instance) in the domain of the selected frame, the mouse pointer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4410 will change instead of this message being printed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4411 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4412 Vgc_message = build_string (gc_default_message);
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 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4415 Pointer glyph used to indicate that a garbage collection is in progress.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4416 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
4417 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
4418 window, the pointer will be changed as specified during garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4419 Otherwise, a message will be printed in the echo area, as controlled
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4420 by `gc-message'.
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 }
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 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4425 complex_vars_of_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4426 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4427 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4428 }