annotate src/alloc.c @ 814:a634e3b7acc8

[xemacs-hg @ 2002-04-14 12:41:59 by ben] latest changes TODO.ben-mule-21-5: Update. make-docfile.c: Add basic support for handling ISO 2022 doc strings -- we parse the basic charset designation sequences so we know whether we're in ASCII and have to pay attention to end quotes and such. Reformat code according to coding standards. abbrev.el: Add `global-abbrev-mode', which turns on or off abbrev-mode in all buffers. Added `defining-abbrev-turns-on-abbrev-mode' -- if non-nil, defining an abbrev through an interactive function will automatically turn on abbrev-mode, either globally or locally depending on the command. This is the "what you'd expect" behavior. indent.el: general function for indenting a balanced expression in a mode-correct way. Works similar to indent-region in that a mode can specify a specific command to do the whole operation; if not, figure out the region using forward-sexp and indent each line using indent-according-to-mode. keydefs.el: Removed. Modify M-C-backslash to do indent-region-or-balanced-expression. Make S-Tab just insert a TAB char, like it's meant to do. make-docfile.el: Now that we're using the call-process-in-lisp, we need to load an extra file win32-native.el because we're running a bare temacs. menubar-items.el: Totally redo the Cmds menu so that most used commands appear directly on the menu and less used commands appear in submenus. The old way may have been very pretty, but rather impractical. process.el: Under Windows, don't ever use old-call-process-internal, even in batch mode. We can do processes in batch mode. subr.el: Someone recoded truncate-string-to-width, saying "the FSF version is too complicated and does lots of hard-to-understand stuff" but the resulting recoded version was *totally* wrong! it misunderstood the basic point of this function, which is work in *columns* not chars. i dumped ours and copied the version from FSF 21.1. Also added truncate-string-with-continuation-dots, since this idiom is used often. config.inc.samp, xemacs.mak: Separate out debug and optimize flags. Remove all vestiges of USE_MINIMAL_TAGBITS, USE_INDEXED_LRECORD_IMPLEMENTATION, and GUNG_HO, since those ifdefs have long been removed. Make error-checking support actually work. Some rearrangement of config.inc.samp to make it more logical. Remove callproc.c and ntproc.c from xemacs.mak, no longer used. Make pdump the default. lisp.h: Add support for strong type-checking of Bytecount, Bytebpos, Charcount, Charbpos, and others, by making them classes, overloading the operators to provide integer-like operation and carefully controlling what operations are allowed. Not currently enabled in C++ builds because there are still a number of compile errors, and it won't really work till we merge in my "8-bit-Mule" workspace, in which I make use of the new types Charxpos, Bytexpos, Memxpos, representing a "position" either in a buffer or a string. (This is especially important in the extent code.) abbrev.c, alloc.c, eval.c, buffer.c, buffer.h, editfns.c, fns.c, text.h: Warning fixes, some of them related to new C++ strict type checking of Bytecount, Charbpos, etc. dired.c: Caught an actual error due to strong type checking -- char len being passed when should be byte len. alloc.c, backtrace.h, bytecode.c, bytecode.h, eval.c, sysdep.c: Further optimize Ffuncall: -- process arg list at compiled-function creation time, converting into an array for extra-quick access at funcall time. -- rewrite funcall_compiled_function to use it, and inline this function. -- change the order of check for magic stuff in SPECBIND_FAST_UNSAFE to be faster. -- move the check for need to garbage collect into the allocation code, so only a single flag needs to be checked in funcall. buffer.c, symbols.c: add debug funs to check on mule optimization info in buffers and strings. eval.c, emacs.c, text.c, regex.c, scrollbar-msw.c, search.c: Fix evil crashes due to eistrings not properly reinitialized under pdump. Redo a bit some of the init routines; convert some complex_vars_of() into simple vars_of(), because they didn't need complex processing. callproc.c, emacs.c, event-stream.c, nt.c, process.c, process.h, sysdep.c, sysdep.h, syssignal.h, syswindows.h, ntproc.c: Delete. Hallelujah, praise the Lord, there is no god but Allah!!! fix so that processes can be invoked in bare temacs -- thereby eliminating any need for callproc.c. (currently only eliminated under NT.) remove all crufty and unnecessary old process code in ntproc.c and elsewhere. move non-callproc-specific stuff (mostly environment) into process.c, so callproc.c can be left out under NT. console-tty.c, doc.c, file-coding.c, file-coding.h, lstream.c, lstream.h: fix doc string handling so it works with Japanese, etc docs. change handling of "character mode" so callers don't have to manually set it (quite error-prone). event-msw.c: spacing fixes. lread.c: eliminate unused crufty vintage-19 "FSF defun hack" code. lrecord.h: improve pdump description docs. buffer.c, ntheap.c, unexnt.c, win32.c, emacs.c: Mule-ize some unexec and startup code. It was pseudo-Mule-ized before by simply always calling the ...A versions of functions, but that won't cut it -- eventually we want to be able to run properly even if XEmacs has been installed in a Japanese directory. (The current problem is the timing of the loading of the Unicode tables; this will eventually be fixed.) Go through and fix various other places where the code was not Mule-clean. Provide a function mswindows_get_module_file_name() to get our own name without resort to PATH_MAX and such. Add a big comment in main() about the problem with Unicode table load timing that I just alluded to. emacs.c: When error-checking is enabled (interpreted as "user is developing XEmacs"), don't ask user to "pause to read messages" when a fatal error has occurred, because it will wedge if we are in an inner modal loop (typically when a menu is popped up) and make us unable to get a useful stack trace in the debugger. text.c: Correct update_entirely_ascii_p_flag to actually work. lisp.h, symsinit.h: declarations for above changes.
author ben
date Sun, 14 Apr 2002 12:43:31 +0000
parents 2b676dc88c66
children 6728e641994e
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 #if SIZEOF_INT == 4
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
349 typedef unsigned int four_byte_t;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
350 #elif SIZEOF_LONG == 4
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
351 typedef unsigned long four_byte_t;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
352 #elif SIZEOF_SHORT == 4
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
353 typedef unsigned short four_byte_t;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
354 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
355 What kind of strange-ass system are we running on?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
356 #endif
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 static void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
359 deadbeef_memory (void *ptr, Bytecount size)
428
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 four_byte_t *ptr4 = (four_byte_t *) ptr;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
362 Bytecount beefs = size >> 2;
428
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 /* In practice, size will always be a multiple of four. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
365 while (beefs--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
366 (*ptr4++) = 0xDEADBEEF;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
367 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
368
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
369 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
370
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
371
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
372 #define deadbeef_memory(ptr, size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374 #endif /* !ERROR_CHECK_GC */
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 #undef xstrdup
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
377 char *
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
378 xstrdup (const char *str)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
379 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380 int len = strlen (str) + 1; /* for stupid terminating 0 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381 void *val = xmalloc (len);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
382
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383 if (val == 0) return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
384 return (char *) memcpy (val, str, len);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
387 #ifdef NEED_STRDUP
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
388 char *
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
389 strdup (const char *s)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
390 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
391 return xstrdup (s);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
392 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
393 #endif /* NEED_STRDUP */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
394
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
395
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
396 static void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
397 allocate_lisp_storage (Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
398 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
399 void *val = xmalloc (size);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
400 /* 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
401 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
402 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
403 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
404 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
405 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
406 get freed?) */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
407
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
408 /* 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
409 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
410 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
411 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
412 redisplay structures and allocated separately. */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
413 memset (val, 0, size);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
414 return val;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
415 }
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
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
418 /* lcrecords are chained together through their "next" field.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
419 After doing the mark phase, GC will walk this linked list
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
420 and free any lcrecord which hasn't been marked. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
421 static struct lcrecord_header *all_lcrecords;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
422
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
423 void *
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
424 alloc_lcrecord (Bytecount size,
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
425 const struct lrecord_implementation *implementation)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
426 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427 struct lcrecord_header *lcheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
428
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
429 type_checking_assert
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
430 ((implementation->static_size == 0 ?
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
431 implementation->size_in_bytes_method != NULL :
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
432 implementation->static_size == size)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
433 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
434 (! implementation->basic_p)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
435 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
436 (! (implementation->hash == NULL && implementation->equal != NULL)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
437
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
438 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
439 set_lheader_implementation (&lcheader->lheader, implementation);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
440 lcheader->next = all_lcrecords;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
441 #if 1 /* mly prefers to see small ID numbers */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
442 lcheader->uid = lrecord_uid_counter++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
443 #else /* jwz prefers to see real addrs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
444 lcheader->uid = (int) &lcheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
445 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
446 lcheader->free = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
447 all_lcrecords = lcheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
448 INCREMENT_CONS_COUNTER (size, implementation->name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
449 return lcheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
450 }
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 0 /* Presently unused */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
453 /* Very, very poor man's EGC?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
454 * This may be slow and thrash pages all over the place.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
455 * Only call it if you really feel you must (and if the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
456 * lrecord was fairly recently allocated).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
457 * 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
458 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
459 void
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
460 very_old_free_lcrecord (struct lcrecord_header *lcrecord)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
461 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
462 if (all_lcrecords == 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 all_lcrecords = lcrecord->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
465 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
466 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
467 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
468 struct lrecord_header *header = all_lcrecords;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
469 for (;;)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
470 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
471 struct lrecord_header *next = header->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
472 if (next == lcrecord)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
473 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
474 header->next = lrecord->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
475 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
476 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
477 else if (next == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
478 abort ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
479 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
480 header = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
481 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
482 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
483 if (lrecord->implementation->finalizer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
484 lrecord->implementation->finalizer (lrecord, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
485 xfree (lrecord);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
486 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
487 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
488 #endif /* Unused */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
489
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
490
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
491 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
492 disksave_object_finalization_1 (void)
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 struct lcrecord_header *header;
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 for (header = all_lcrecords; header; header = header->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
497 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
498 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
499 !header->free)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
500 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
501 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
502 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
503
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
504
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 /* Debugger support */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
507 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
508 /* Give gdb/dbx enough information to decode Lisp Objects. We make
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
509 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
510 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
511 to see how this is used. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
512
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
513 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
514 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
515
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
516 #ifdef USE_UNION_TYPE
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
517 unsigned char dbg_USE_UNION_TYPE = 1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
518 #else
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
519 unsigned char dbg_USE_UNION_TYPE = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
520 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
521
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
522 unsigned char dbg_valbits = VALBITS;
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
523 unsigned char dbg_gctypebits = GCTYPEBITS;
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
524
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
525 /* On some systems, the above definitions will be optimized away by
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
526 the compiler or linker unless they are referenced in some function. */
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
527 long dbg_inhibit_dbg_symbol_deletion (void);
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
528 long
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
529 dbg_inhibit_dbg_symbol_deletion (void)
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
530 {
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
531 return
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
532 (dbg_valmask +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
533 dbg_typemask +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
534 dbg_USE_UNION_TYPE +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
535 dbg_valbits +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
536 dbg_gctypebits);
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
537 }
428
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 /* Macros turned into functions for ease of debugging.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
540 Debuggers don't know about macros! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
541 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
542 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
543 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
544 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
545 return EQ (obj1, obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
546 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
547
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
548
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
549 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
550 /* Fixed-size type macros */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
551 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
552
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
553 /* For fixed-size types that are commonly used, we malloc() large blocks
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
554 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
555 size for an object of that type. This is more efficient than
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
556 malloc()ing each object separately because we save on malloc() time
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
557 and overhead due to the fewer number of malloc()ed blocks, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
558 also because we don't need any extra pointers within each object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
559 to keep them threaded together for GC purposes. For less common
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
560 (and frequently large-size) types, we use lcrecords, which are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
561 malloc()ed individually and chained together through a pointer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
562 in the lcrecord header. lcrecords do not need to be fixed-size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
563 (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
564 however, the size of a particular object cannot vary dynamically).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
565 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
566 additional code needs to be added to alloc.c. Finally, lcrecords
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
567 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
568
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
569 The types that are stored in these large blocks (or "frob blocks")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
570 are cons, float, compiled-function, symbol, marker, extent, event,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
571 and string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
572
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
573 Note that strings are special in that they are actually stored in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
574 two parts: a structure containing information about the string, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
575 the actual data associated with the string. The former structure
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
576 (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
577 same way as all the other such types. This structure contains a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
578 pointer to the actual string data, which is stored in structures of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
579 type struct string_chars_block. Each string_chars_block consists
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
580 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
581 string, followed by another pointer to a Lisp_String, followed by
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
582 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
583 blocks is compacted by searching sequentially through all the
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
584 blocks and compressing out any holes created by unmarked strings.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
585 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
586 a string_chars_block, although something like half as big might
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
587 make more sense) are malloc()ed separately and not stored in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
588 string_chars_blocks. Furthermore, no one string stretches across
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
589 two string_chars_blocks.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
590
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
591 Vectors are each malloc()ed separately, similar to lcrecords.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
592
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
593 In the following discussion, we use conses, but it applies equally
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
594 well to the other fixed-size types.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
595
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
596 We store cons cells inside of cons_blocks, allocating a new
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
597 cons_block with malloc() whenever necessary. Cons cells reclaimed
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
598 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
599 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
600 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
601 the versions in malloc.c and gmalloc.c) really allocates in units
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
602 of powers of two and uses 4 bytes for its own overhead.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
603
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
604 What GC actually does is to search through all the cons_blocks,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
605 from the most recently allocated to the oldest, and put all
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
606 cons cells that are not marked (whether or not they're already
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
607 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
608 so the cons cells in the oldest-allocated cons_block end up
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
609 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
610 If any cons_block is entirely free, it is freed with free()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
611 and its cons cells removed from the cons_free_list. Because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
612 the cons_free_list ends up basically in memory order, we have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
613 a high locality of reference (assuming a reasonable turnover
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
614 of allocating and freeing) and have a reasonable probability
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
615 of entirely freeing up cons_blocks that have been more recently
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
616 allocated. This stage is called the "sweep stage" of GC, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
617 is executed after the "mark stage", which involves starting
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
618 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
619 (e.g. the obarray, where are all symbols are stored; the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
620 current catches and condition-cases; the backtrace list of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
621 currently executing functions; the gcpro list; etc.) and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
622 recursively marking all objects that are accessible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
623
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
624 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
625 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
626 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
627 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
628 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
629 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
630 macro. This uses a special lrecord type `lrecord_type_free',
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
631 which is never associated with any valid object.
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
632
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
633 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
634 in the conses themselves. Because the cons is still in a
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
635 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
636 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
637 indicator and the chaining pointer. So this pointer is stored
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
638 after the lrecord header (actually where C places a pointer after
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
639 the lrecord header; they are not necessarily contiguous). This
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
640 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
641 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
642 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
643 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
644 ensure adequate space for the free list chain pointer.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
645
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
646 Some types of objects need additional "finalization" done
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
647 when an object is converted from in use to not in use;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648 this is the purpose of the ADDITIONAL_FREE_type macro.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
649 For example, markers need to be removed from the chain
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
650 of markers that is kept in each buffer. This is because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
651 markers in a buffer automatically disappear if the marker
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
652 is no longer referenced anywhere (the same does not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
653 apply to extents, however).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
654
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
655 WARNING: Things are in an extremely bizarre state when
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
656 the ADDITIONAL_FREE_type macros are called, so beware!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
657
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
658 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
659 maximize our chances of catching places where there is insufficient
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
660 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
661 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
662 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
663 something seemingly unrelated getting trashed, and is extremely
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
664 difficult to track down. If the object gets freed but not
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
665 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
666 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
667 to the invalid type `lrecord_type_free', however, and a pointer
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
668 used to chain freed objects together is stored after the lrecord
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
669 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
670 bogus, so crashes are more likely to occur right away.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
671
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
672 We want freed objects to stay free as long as possible,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
673 so instead of doing what we do above, we maintain the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
674 free objects in a first-in first-out queue. We also
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
675 don't recompute the free list each GC, unlike above;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
676 this ensures that the queue ordering is preserved.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
677 [This means that we are likely to have worse locality
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
678 of reference, and that we can never free a frob block
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
679 once it's allocated. (Even if we know that all cells
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
680 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
681 cells from the free list because the objects on the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
682 free list are unlikely to be in memory order.)]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
683 Furthermore, we never take objects off the free list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
684 unless there's a large number (usually 1000, but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
685 varies depending on type) of them already on the list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
686 This way, we ensure that an object that gets freed will
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
687 remain free for the next 1000 (or whatever) times that
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
688 an object of that type is allocated. */
428
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 #ifndef MALLOC_OVERHEAD
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
691 #ifdef GNU_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
692 #define MALLOC_OVERHEAD 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
693 #elif defined (rcheck)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
694 #define MALLOC_OVERHEAD 20
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
695 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
696 #define MALLOC_OVERHEAD 8
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
697 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
698 #endif /* MALLOC_OVERHEAD */
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 !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
701 /* If we released our reserve (due to running out of memory),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
702 and we have a fair amount free once again,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
703 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
704
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
705 This is called when a relocatable block is freed in ralloc.c. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
706 void refill_memory_reserve (void);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
707 void
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
708 refill_memory_reserve (void)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
709 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
710 if (breathing_space == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
711 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
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 #endif
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 #ifdef ALLOC_NO_POOLS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
716 # define TYPE_ALLOC_SIZE(type, structtype) 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
717 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
718 # define TYPE_ALLOC_SIZE(type, structtype) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
719 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
720 / sizeof (structtype))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
721 #endif /* ALLOC_NO_POOLS */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
722
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
723 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
724 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
725 struct type##_block \
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 struct type##_block *prev; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
728 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
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 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
731 static struct type##_block *current_##type##_block; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
732 static int current_##type##_block_index; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
733 \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
734 static Lisp_Free *type##_free_list; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
735 static Lisp_Free *type##_free_list_tail; \
428
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 void \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
738 init_##type##_alloc (void) \
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 current_##type##_block = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
741 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 type##_free_list = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
744 type##_free_list_tail = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
745 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
746 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
747 static int gc_count_num_##type##_in_use; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
748 static int gc_count_num_##type##_freelist
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 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
751 if (current_##type##_block_index \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
752 == countof (current_##type##_block->block)) \
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 struct type##_block *AFTFB_new = (struct type##_block *) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
755 allocate_lisp_storage (sizeof (struct type##_block)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
756 AFTFB_new->prev = current_##type##_block; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
757 current_##type##_block = AFTFB_new; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
758 current_##type##_block_index = 0; \
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 (result) = \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
761 &(current_##type##_block->block[current_##type##_block_index++]); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
762 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
763
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
764 /* Allocate an instance of a type that is stored in blocks.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
765 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
766 structure type. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
767
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
768 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
769
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
770 /* Note: if you get crashes in this function, suspect incorrect calls
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
771 to free_cons() and friends. This happened once because the cons
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
772 cell was not GC-protected and was getting collected before
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
773 free_cons() was called. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
774
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
775 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
776 if (gc_count_num_##type##_freelist > \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
777 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
778 { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
779 result = (structtype *) type##_free_list; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
780 /* Before actually using the chain pointer, \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
781 we complement all its bits; see FREE_FIXED_TYPE(). */ \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
782 type##_free_list = (Lisp_Free *) \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
783 (~ (EMACS_UINT) (type##_free_list->chain)); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
784 gc_count_num_##type##_freelist--; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
785 } \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
786 else \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
787 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
788 MARK_LRECORD_AS_NOT_FREE (result); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
789 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
790
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
791 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
792
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
793 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
794 if (type##_free_list) \
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 result = (structtype *) type##_free_list; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
797 type##_free_list = type##_free_list->chain; \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
798 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
799 else \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
800 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
801 MARK_LRECORD_AS_NOT_FREE (result); \
428
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 #endif /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
805
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
806
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
807 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
808 do \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
809 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
810 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
811 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
812 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
813
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
814 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
815 do \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
816 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
817 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
818 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
819 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
820
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
821
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
822 /* 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
823 block of any lisp object type. */
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
824 typedef struct Lisp_Free
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 struct lrecord_header lheader;
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
827 struct Lisp_Free *chain;
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
828 } Lisp_Free;
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
829
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
830 #define LRECORD_FREE_P(ptr) \
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
831 (((struct lrecord_header *) ptr)->type == lrecord_type_free)
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
832
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
833 #define MARK_LRECORD_AS_FREE(ptr) \
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
834 ((void) (((struct lrecord_header *) ptr)->type = lrecord_type_free))
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
835
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
836 #ifdef ERROR_CHECK_GC
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
837 #define MARK_LRECORD_AS_NOT_FREE(ptr) \
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
838 ((void) (((struct lrecord_header *) ptr)->type = lrecord_type_undefined))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
839 #else
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
840 #define MARK_LRECORD_AS_NOT_FREE(ptr) DO_NOTHING
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
841 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
842
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
843 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
844
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
845 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
846 if (type##_free_list_tail) \
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 /* When we store the chain pointer, we complement all \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
849 its bits; this should significantly increase its \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
850 bogosity in case someone tries to use the value, and \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
851 should make us crash faster if someone overwrites the \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
852 pointer because when it gets un-complemented in \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
853 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
854 extremely bogus. */ \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
855 type##_free_list_tail->chain = \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
856 (Lisp_Free *) ~ (EMACS_UINT) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
857 } \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
858 else \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
859 type##_free_list = (Lisp_Free *) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
860 type##_free_list_tail = (Lisp_Free *) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
861 } while (0)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
862
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
863 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
864
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
865 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
866 ((Lisp_Free *) (ptr))->chain = type##_free_list; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
867 type##_free_list = (Lisp_Free *) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
868 } while (0) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
869
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
870 #endif /* !ERROR_CHECK_GC */
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 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
873
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
874 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
875 structtype *FFT_ptr = (ptr); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
876 ADDITIONAL_FREE_##type (FFT_ptr); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
877 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
878 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
879 MARK_LRECORD_AS_FREE (FFT_ptr); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
880 } while (0)
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 /* Like FREE_FIXED_TYPE() but used when we are explicitly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
883 freeing a structure through free_cons(), free_marker(), etc.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
884 rather than through the normal process of sweeping.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
885 We attempt to undo the changes made to the allocation counters
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
886 as a result of this structure being allocated. This is not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
887 completely necessary but helps keep things saner: e.g. this way,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
888 repeatedly allocating and freeing a cons will not result in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
889 the consing-since-gc counter advancing, which would cause a GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
890 and somewhat defeat the purpose of explicitly freeing. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
891
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
892 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
893 do { FREE_FIXED_TYPE (type, structtype, ptr); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
894 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
895 gc_count_num_##type##_freelist++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
896 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
897
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
900 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
901 /* Cons allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
902 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
903
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
904 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
905 /* 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
906 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
907 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
910 mark_cons (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
911 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
912 if (NILP (XCDR (obj)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
913 return XCAR (obj);
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 mark_object (XCAR (obj));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
916 return XCDR (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
917 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
918
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
919 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
920 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
921 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
922 depth++;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
923 while (internal_equal (XCAR (ob1), XCAR (ob2), depth))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
924 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
925 ob1 = XCDR (ob1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
926 ob2 = XCDR (ob2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
927 if (! CONSP (ob1) || ! CONSP (ob2))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
928 return internal_equal (ob1, ob2, depth);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
929 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
930 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
931 }
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 static const struct lrecord_description cons_description[] = {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
934 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car) },
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
935 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr) },
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
936 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
937 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
938
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
939 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
940 mark_cons, print_cons, 0,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
941 cons_equal,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
942 /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
943 * No `hash' method needed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
944 * internal_hash knows how to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
945 * handle conses.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
946 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
947 0,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
948 cons_description,
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
949 Lisp_Cons);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
950
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
951 DEFUN ("cons", Fcons, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
952 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
953 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
954 (car, cdr))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
955 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
956 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
957 Lisp_Object val;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
958 Lisp_Cons *c;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
959
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
960 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
961 set_lheader_implementation (&c->lheader, &lrecord_cons);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
962 val = wrap_cons (c);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
963 c->car = car;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
964 c->cdr = cdr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
965 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
966 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
967
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
968 /* 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
969 going to free later, and is useful when trying to track down
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
970 "real" consing. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
971 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
972 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
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 Lisp_Object val;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
975 Lisp_Cons *c;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
976
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
977 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
978 set_lheader_implementation (&c->lheader, &lrecord_cons);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
979 val = wrap_cons (c);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
980 XCAR (val) = car;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
981 XCDR (val) = cdr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
982 return val;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
985 DEFUN ("list", Flist, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
986 Return a newly created list with specified arguments as elements.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
987 Any number of arguments, even zero arguments, are allowed.
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 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
990 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
991 Lisp_Object val = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
992 Lisp_Object *argp = args + nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
993
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
994 while (argp > args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
995 val = Fcons (*--argp, val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
996 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
997 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
998
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
999 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1000 list1 (Lisp_Object obj0)
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 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1003 return Fcons (obj0, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1004 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1005
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1006 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1007 list2 (Lisp_Object obj0, Lisp_Object obj1)
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 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1010 return Fcons (obj0, Fcons (obj1, Qnil));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1011 }
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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1014 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object 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 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1017 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1018 }
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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1021 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
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 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1024 return Fcons (obj0, Fcons (obj1, obj2));
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1027 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1028 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
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 return Fcons (Fcons (key, value), alist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1031 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1032
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1033 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1034 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
1035 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1036 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1037 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1038 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1039
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1040 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1041 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
1042 Lisp_Object obj4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1043 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1044 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1045 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1046 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1047
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1048 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1049 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
1050 Lisp_Object obj4, Lisp_Object obj5)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1051 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1052 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1053 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
1054 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1055
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1056 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1057 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
1058 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1059 (length, object))
428
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 CHECK_NATNUM (length);
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 Lisp_Object val = Qnil;
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
1065 EMACS_INT size = XINT (length);
428
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 while (size--)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1068 val = Fcons (object, val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1069 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1070 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1071 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1074 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1075 /* Float allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1076 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1077
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1078 #ifdef LISP_FLOAT_TYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1079
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1080 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1081 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1082
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1083 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1084 make_float (double float_value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1085 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1086 Lisp_Float *f;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1087
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1088 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1089
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1090 /* Avoid dump-time `uninitialized memory read' purify warnings. */
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1091 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1092 xzero (*f);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1093
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1094 set_lheader_implementation (&f->lheader, &lrecord_float);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1095 float_data (f) = float_value;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1096 return wrap_float (f);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1097 }
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 #endif /* LISP_FLOAT_TYPE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1100
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1101
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 /* Vector allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1104 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1105
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1106 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1107 mark_vector (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1108 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1109 Lisp_Vector *ptr = XVECTOR (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1110 int len = vector_length (ptr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1111 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1112
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1113 for (i = 0; i < len - 1; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1114 mark_object (ptr->contents[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1115 return (len > 0) ? ptr->contents[len - 1] : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1116 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1117
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1118 static Bytecount
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1119 size_vector (const void *lheader)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1120 {
456
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 454
diff changeset
1121 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, contents,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1122 ((Lisp_Vector *) lheader)->size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1123 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1124
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1125 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1126 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1127 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1128 int len = XVECTOR_LENGTH (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1129 if (len != XVECTOR_LENGTH (obj2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1130 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1131
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1132 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1133 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1134 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1135 while (len--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1136 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1137 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1138 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1139 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1140 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1141
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1142 static Hashcode
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1143 vector_hash (Lisp_Object obj, int depth)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1144 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1145 return HASH2 (XVECTOR_LENGTH (obj),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1146 internal_array_hash (XVECTOR_DATA (obj),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1147 XVECTOR_LENGTH (obj),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1148 depth + 1));
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1149 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1150
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1151 static const struct lrecord_description vector_description[] = {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1152 { XD_LONG, offsetof (Lisp_Vector, size) },
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1153 { 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
1154 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1155 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1156
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1157 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1158 mark_vector, print_vector, 0,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1159 vector_equal,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1160 vector_hash,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1161 vector_description,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1162 size_vector, Lisp_Vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1163
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1164 /* #### should allocate `small' vectors from a frob-block */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1165 static Lisp_Vector *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1166 make_vector_internal (Elemcount sizei)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1167 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1168 /* no vector_next */
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1169 Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object,
456
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 454
diff changeset
1170 contents, sizei);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1171 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
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 p->size = sizei;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1174 return p;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1175 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1176
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1177 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1178 make_vector (Elemcount length, Lisp_Object object)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1179 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1180 Lisp_Vector *vecp = make_vector_internal (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1181 Lisp_Object *p = vector_data (vecp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1182
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1183 while (length--)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1184 *p++ = object;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1185
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1186 return wrap_vector (vecp);
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 ("make-vector", Fmake_vector, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1190 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
1191 See also the function `vector'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1192 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1193 (length, object))
428
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 CONCHECK_NATNUM (length);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1196 return make_vector (XINT (length), object);
428
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1199 DEFUN ("vector", Fvector, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1200 Return a newly created vector with specified arguments as elements.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1201 Any number of arguments, even zero arguments, are allowed.
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 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1204 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1205 Lisp_Vector *vecp = make_vector_internal (nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1206 Lisp_Object *p = vector_data (vecp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1207
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1208 while (nargs--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1209 *p++ = *args++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1210
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1211 return wrap_vector (vecp);
428
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1214 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1215 vector1 (Lisp_Object obj0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1216 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1217 return Fvector (1, &obj0);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1220 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1221 vector2 (Lisp_Object obj0, Lisp_Object obj1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1222 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1223 Lisp_Object args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1224 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1225 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1226 return Fvector (2, 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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1230 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1231 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1232 Lisp_Object args[3];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1233 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1234 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1235 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1236 return Fvector (3, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1237 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1238
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1239 #if 0 /* currently unused */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1240
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1241 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1242 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1243 Lisp_Object obj3)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1244 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1245 Lisp_Object args[4];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1246 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1247 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1248 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1249 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1250 return Fvector (4, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1251 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1252
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1253 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1254 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1255 Lisp_Object obj3, Lisp_Object obj4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1256 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1257 Lisp_Object args[5];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1258 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1259 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1260 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1261 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1262 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1263 return Fvector (5, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1264 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1265
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1266 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1267 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1268 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
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 args[6];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1271 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1272 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1273 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1274 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1275 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1276 args[5] = obj5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1277 return Fvector (6, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1278 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1279
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1280 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1281 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1282 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1283 Lisp_Object obj6)
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 Lisp_Object args[7];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1286 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1287 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1288 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1289 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1290 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1291 args[5] = obj5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1292 args[6] = obj6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1293 return Fvector (7, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1294 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1295
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1296 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1297 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1298 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1299 Lisp_Object obj6, Lisp_Object obj7)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1300 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1301 Lisp_Object args[8];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1302 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1303 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1304 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1305 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1306 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1307 args[5] = obj5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1308 args[6] = obj6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1309 args[7] = obj7;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1310 return Fvector (8, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1311 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1312 #endif /* unused */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1313
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1314 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1315 /* Bit Vector allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1316 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1317
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1318 static Lisp_Object all_bit_vectors;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1319
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1320 /* #### should allocate `small' bit vectors from a frob-block */
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1321 static Lisp_Bit_Vector *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1322 make_bit_vector_internal (Elemcount sizei)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1323 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1324 Elemcount num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1325 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
1326 unsigned long,
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
1327 bits, num_longs);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1328 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
1329 set_lheader_implementation (&p->lheader, &lrecord_bit_vector);
428
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 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1332
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1333 bit_vector_length (p) = sizei;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1334 bit_vector_next (p) = all_bit_vectors;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1335 /* 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
1336 functions might not set them. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1337 p->bits[num_longs - 1] = 0;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1338 all_bit_vectors = wrap_bit_vector (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1339 return p;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1340 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1341
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1342 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1343 make_bit_vector (Elemcount length, Lisp_Object bit)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1344 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1345 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
1346 Elemcount num_longs = BIT_VECTOR_LONG_STORAGE (length);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1347
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1348 CHECK_BIT (bit);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1349
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1350 if (ZEROP (bit))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1351 memset (p->bits, 0, num_longs * sizeof (long));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1352 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1353 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1354 Elemcount bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1355 memset (p->bits, ~0, num_longs * sizeof (long));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1356 /* But we have to make sure that the unused bits in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1357 last long are 0, so that equal/hash is easy. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1358 if (bits_in_last)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1359 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
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
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1362 return wrap_bit_vector (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1363 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1364
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1365 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1366 make_bit_vector_from_byte_vector (unsigned char *bytevec, Elemcount length)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1367 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1368 Elemcount i;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1369 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1370
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1371 for (i = 0; i < length; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1372 set_bit_vector_bit (p, i, bytevec[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1373
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1374 return wrap_bit_vector (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1375 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1376
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1377 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1378 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
1379 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
1380 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1381 (length, bit))
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 CONCHECK_NATNUM (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1384
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1385 return make_bit_vector (XINT (length), bit);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1386 }
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 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1389 Return a newly created bit vector with specified arguments as elements.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1390 Any number of arguments, even zero arguments, are allowed.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1391 Each argument must be one of the integers 0 or 1.
428
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 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1394 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1395 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1396 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
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 for (i = 0; i < nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1399 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1400 CHECK_BIT (args[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1401 set_bit_vector_bit (p, i, !ZEROP (args[i]));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1402 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1403
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1404 return wrap_bit_vector (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1405 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1406
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 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1409 /* Compiled-function allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1410 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1411
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1412 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1413 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1414
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1415 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1416 make_compiled_function (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1417 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1418 Lisp_Compiled_Function *f;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1419
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1420 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1421 set_lheader_implementation (&f->lheader, &lrecord_compiled_function);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1422
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1423 f->stack_depth = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1424 f->specpdl_depth = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1425 f->flags.documentationp = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1426 f->flags.interactivep = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1427 f->flags.domainp = 0; /* I18N3 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1428 f->instructions = Qzero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1429 f->constants = Qzero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1430 f->arglist = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1431 f->doc_and_interactive = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1432 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1433 f->annotated = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1434 #endif
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1435 return wrap_compiled_function (f);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1436 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1437
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1438 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1439 Return a new compiled-function object.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1440 Usage: (arglist instructions constants stack-depth
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1441 &optional doc-string interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1442 Note that, unlike all other emacs-lisp functions, calling this with five
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1443 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
1444 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
1445 that this function was defined with `(interactive)'. If the arg is not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1446 specified, then that means the function is not interactive.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1447 This is terrible behavior which is retained for compatibility with old
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1448 `.elc' files which expect these semantics.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1449 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1450 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1451 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1452 /* In a non-insane world this function would have this arglist...
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1453 (arglist instructions constants stack_depth &optional doc_string interactive)
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 Lisp_Object fun = make_compiled_function ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1456 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1457
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1458 Lisp_Object arglist = args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1459 Lisp_Object instructions = args[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1460 Lisp_Object constants = args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1461 Lisp_Object stack_depth = args[3];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1462 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1463 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1464
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1465 if (nargs < 4 || nargs > 6)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1466 return Fsignal (Qwrong_number_of_arguments,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1467 list2 (intern ("make-byte-code"), make_int (nargs)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1468
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1469 /* Check for valid formal parameter list now, to allow us to use
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1470 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1471 {
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1472 EXTERNAL_LIST_LOOP_2 (symbol, arglist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1473 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1474 CHECK_SYMBOL (symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1475 if (EQ (symbol, Qt) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1476 EQ (symbol, Qnil) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1477 SYMBOL_IS_KEYWORD (symbol))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 551
diff changeset
1478 invalid_constant_2
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1479 ("Invalid constant symbol in formal parameter list",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1480 symbol, arglist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1481 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1482 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1483 f->arglist = arglist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1484
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1485 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1486 int minargs = 0, maxargs = 0, totalargs = 0;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1487 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
1488 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1489 LIST_LOOP_2 (arg, arglist)
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1490 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1491 if (EQ (arg, Qand_optional))
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1492 optional_p = 1;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1493 else if (EQ (arg, Qand_rest))
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1494 rest_p = 1;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1495 else
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1496 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1497 if (rest_p)
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 maxargs = MANY;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1500 totalargs++;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1501 break;
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 if (!optional_p)
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1504 minargs++;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1505 maxargs++;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1506 totalargs++;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1507 }
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->args = xnew_array (Lisp_Object, totalargs);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1512
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1513 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1514 LIST_LOOP_2 (arg, arglist)
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1515 {
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1516 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
1517 f->args[i++] = arg;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1518 }
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1519 }
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1520
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1521 f->max_args = maxargs;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1522 f->min_args = minargs;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1523 f->args_in_array = totalargs;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1524 }
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1525
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1526 /* `instructions' is a string or a cons (string . int) for a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1527 lazy-loaded function. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1528 if (CONSP (instructions))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1529 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1530 CHECK_STRING (XCAR (instructions));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1531 CHECK_INT (XCDR (instructions));
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 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1534 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1535 CHECK_STRING (instructions);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1536 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1537 f->instructions = instructions;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1538
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1539 if (!NILP (constants))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1540 CHECK_VECTOR (constants);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1541 f->constants = constants;
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 CHECK_NATNUM (stack_depth);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1544 f->stack_depth = (unsigned short) XINT (stack_depth);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1545
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1546 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1547 if (!NILP (Vcurrent_compiled_function_annotation))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1548 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1549 else if (!NILP (Vload_file_name_internal_the_purecopy))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1550 f->annotated = Vload_file_name_internal_the_purecopy;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1551 else if (!NILP (Vload_file_name_internal))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1552 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1553 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1554 GCPRO1 (fun); /* don't let fun get reaped */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1555 Vload_file_name_internal_the_purecopy =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1556 Ffile_name_nondirectory (Vload_file_name_internal);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1557 f->annotated = Vload_file_name_internal_the_purecopy;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1558 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1559 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1560 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1561
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1562 /* doc_string may be nil, string, int, or a cons (string . int).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1563 interactive may be list or string (or unbound). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1564 f->doc_and_interactive = Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1565 #ifdef I18N3
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1566 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1567 f->doc_and_interactive = Vfile_domain;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1568 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1569 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
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 f->doc_and_interactive
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1572 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1573 Fcons (interactive, f->doc_and_interactive));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1574 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1575 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
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 f->doc_and_interactive
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1578 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1579 Fcons (doc_string, f->doc_and_interactive));
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 if (UNBOUNDP (f->doc_and_interactive))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1582 f->doc_and_interactive = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1583
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1584 return fun;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1585 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1586
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1587
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1588 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1589 /* Symbol allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1590 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1591
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1592 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1593 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1594
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1595 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1596 Return a newly allocated uninterned symbol whose name is NAME.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1597 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
1598 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1599 (name))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1600 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1601 Lisp_Symbol *p;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1602
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1603 CHECK_STRING (name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1604
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1605 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1606 set_lheader_implementation (&p->lheader, &lrecord_symbol);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1607 p->name = name;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1608 p->plist = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1609 p->value = Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1610 p->function = Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1611 symbol_next (p) = 0;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1612 return wrap_symbol (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1613 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1614
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1615
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1616 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1617 /* Extent allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1618 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1619
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1620 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1621 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1622
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1623 struct extent *
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1624 allocate_extent (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1625 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1626 struct extent *e;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1627
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1628 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1629 set_lheader_implementation (&e->lheader, &lrecord_extent);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1630 extent_object (e) = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1631 set_extent_start (e, -1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1632 set_extent_end (e, -1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1633 e->plist = Qnil;
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 xzero (e->flags);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1636
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1637 extent_face (e) = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1638 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
1639 e->flags.detachable = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1640
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1641 return e;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1642 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1643
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1644
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1645 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1646 /* Event allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1647 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1648
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1649 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1650 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1653 allocate_event (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1654 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1655 Lisp_Event *e;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1656
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1657 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1658 set_lheader_implementation (&e->lheader, &lrecord_event);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1659
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1660 return wrap_event (e);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1661 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1662
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 /* Marker allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1666 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1667
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1668 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1669 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1670
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1671 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1672 Return a new marker which does not point at any place.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1673 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1674 ())
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1675 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1676 Lisp_Marker *p;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1677
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1678 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1679 set_lheader_implementation (&p->lheader, &lrecord_marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1680 p->buffer = 0;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1681 p->membpos = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1682 marker_next (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1683 marker_prev (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1684 p->insertion_type = 0;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1685 return wrap_marker (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1686 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1687
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1688 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1689 noseeum_make_marker (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1690 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1691 Lisp_Marker *p;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1692
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1693 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1694 set_lheader_implementation (&p->lheader, &lrecord_marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1695 p->buffer = 0;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1696 p->membpos = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1697 marker_next (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1698 marker_prev (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1699 p->insertion_type = 0;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1700 return wrap_marker (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1701 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1702
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 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1705 /* String allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1706 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1707
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1708 /* The data for "short" strings generally resides inside of structs of type
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1709 string_chars_block. The Lisp_String structure is allocated just like any
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1710 other Lisp object (except for vectors), and these are freelisted when
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1711 they get garbage collected. The data for short strings get compacted,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1712 but the data for large strings do not.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1713
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1714 Previously Lisp_String structures were relocated, but this caused a lot
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1715 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
1716 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
1717 that the reference would get relocated).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1718
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1719 This new method makes things somewhat bigger, but it is MUCH safer. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1720
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1721 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1722 /* strings are used and freed quite often */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1723 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1724 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1725
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1726 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1727 mark_string (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1728 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1729 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
1730 flush_cached_extent_info (XCAR (XSTRING_PLIST (obj)));
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1731 return XSTRING_PLIST (obj);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1732 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1733
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1734 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1735 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1736 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1737 Bytecount len;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1738 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1739 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1740 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1741
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1742 static const struct lrecord_description string_description[] = {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1743 { XD_BYTECOUNT, offsetof (Lisp_String, size_) },
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1744 { 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
1745 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1746 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1747 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1748
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1749 /* 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
1750 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
1751 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
1752 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
1753 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
1754 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
1755 extent info.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1756
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1757 #### 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
1758
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1759 static Lisp_Object *
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1760 string_plist_ptr (Lisp_Object string)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1761 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1762 Lisp_Object *ptr = &XSTRING_PLIST (string);
442
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 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1765 ptr = &XCDR (*ptr);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1766 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1767 ptr = &XCDR (*ptr);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1768 return ptr;
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
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1771 static Lisp_Object
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1772 string_getprop (Lisp_Object string, Lisp_Object property)
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 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
1775 }
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 static int
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1778 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
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 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
1781 return 1;
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
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1784 static int
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1785 string_remprop (Lisp_Object string, Lisp_Object property)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1786 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1787 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1788 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1789
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1790 static Lisp_Object
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1791 string_plist (Lisp_Object string)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1792 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1793 return *string_plist_ptr (string);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1794 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1795
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1796 /* No `finalize', or `hash' methods.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1797 internal_hash() already knows how to hash strings and finalization
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1798 is done with the ADDITIONAL_FREE_string macro, which is the
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1799 standard way to do finalization when using
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1800 SWEEP_FIXED_TYPE_BLOCK(). */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1801 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1802 mark_string, print_string,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1803 0, string_equal, 0,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1804 string_description,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1805 string_getprop,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1806 string_putprop,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1807 string_remprop,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1808 string_plist,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1809 Lisp_String);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1810
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1811 /* String blocks contain this many useful bytes. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1812 #define STRING_CHARS_BLOCK_SIZE \
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1813 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1814 ((2 * sizeof (struct string_chars_block *)) \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1815 + sizeof (EMACS_INT))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1816 /* Block header for small strings. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1817 struct string_chars_block
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1818 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1819 EMACS_INT pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1820 struct string_chars_block *next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1821 struct string_chars_block *prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1822 /* Contents of string_chars_block->string_chars are interleaved
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1823 string_chars structures (see below) and the actual string data */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1824 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1825 };
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 static struct string_chars_block *first_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1828 static struct string_chars_block *current_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1829
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1830 /* 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
1831 * the string occupies in string_chars_block->string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1832 * (including alignment padding).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1833 */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1834 #define STRING_FULLSIZE(size) \
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1835 ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1836 ALIGNOF (Lisp_String *))
428
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 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1839 #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
1840
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1841 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL)
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1842 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL))
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1843
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1844 struct string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1845 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1846 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1847 unsigned char chars[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1848 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1849
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1850 struct unused_string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1851 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1852 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1853 EMACS_INT fullsize;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1856 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1857 init_string_chars_alloc (void)
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 first_string_chars_block = xnew (struct string_chars_block);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1860 first_string_chars_block->prev = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1861 first_string_chars_block->next = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1862 first_string_chars_block->pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1863 current_string_chars_block = first_string_chars_block;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1866 static struct string_chars *
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1867 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
1868 Bytecount fullsize)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1869 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1870 struct string_chars *s_chars;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1871
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1872 if (fullsize <=
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1873 (countof (current_string_chars_block->string_chars)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1874 - current_string_chars_block->pos))
428
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 /* This string can fit in the current string chars block */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1877 s_chars = (struct string_chars *)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1878 (current_string_chars_block->string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1879 + current_string_chars_block->pos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1880 current_string_chars_block->pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1881 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1882 else
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 /* Make a new current string chars block */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1885 struct string_chars_block *new_scb = xnew (struct string_chars_block);
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 current_string_chars_block->next = new_scb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1888 new_scb->prev = current_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1889 new_scb->next = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1890 current_string_chars_block = new_scb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1891 new_scb->pos = fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1892 s_chars = (struct string_chars *)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1893 current_string_chars_block->string_chars;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1894 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1895
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1896 s_chars->string = XSTRING (string_it_goes_with);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1897
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1898 INCREMENT_CONS_COUNTER (fullsize, "string chars");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1899
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1900 return s_chars;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1901 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1902
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1903 #ifdef SLEDGEHAMMER_CHECK_ASCII_BEGIN
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1904 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1905 sledgehammer_check_ascii_begin (Lisp_Object str)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1906 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1907 Bytecount i;
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 for (i = 0; i < XSTRING_LENGTH (str); i++)
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 if (!BYTE_ASCII_P (XSTRING_BYTE (str, i)))
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1912 break;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1913 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1914
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1915 assert (i == (Bytecount) XSTRING_ASCII_BEGIN (str) ||
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1916 (i > MAX_STRING_ASCII_BEGIN &&
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1917 (Bytecount) XSTRING_ASCII_BEGIN (str) ==
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1918 (Bytecount) MAX_STRING_ASCII_BEGIN));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1919 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1920 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1921
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1922 /* 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
1923 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
1924 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
1925
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1926 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1927 make_uninit_string (Bytecount length)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1928 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1929 Lisp_String *s;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1930 Bytecount fullsize = STRING_FULLSIZE (length);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1931
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1932 assert (length >= 0 && fullsize > 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1933
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1934 /* Allocate the string header */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1935 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1936 xzero (*s);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1937 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
1938
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1939 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1940 ? xnew_array (Intbyte, length + 1)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1941 : allocate_string_chars_struct (wrap_string (s),
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1942 fullsize)->chars);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1943
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1944 set_string_length (s, length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1945 s->plist = Qnil;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1946 set_string_byte (wrap_string (s), length, 0);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1947
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1948 return wrap_string (s);
428
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1951 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1952 static void verify_string_chars_integrity (void);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1953 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1954
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1955 /* Resize the string S so that DELTA bytes can be inserted starting
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1956 at POS. If DELTA < 0, it means deletion starting at POS. If
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1957 POS < 0, resize the string but don't copy any characters. Use
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1958 this if you're planning on completely overwriting the string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1959 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1960
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1961 void
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1962 resize_string (Lisp_Object s, Bytecount pos, Bytecount delta)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1963 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1964 Bytecount oldfullsize, newfullsize;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1965 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1966 verify_string_chars_integrity ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1967 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1968
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
1969 #ifdef ERROR_CHECK_TEXT
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1970 if (pos >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1971 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1972 assert (pos <= XSTRING_LENGTH (s));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1973 if (delta < 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1974 assert (pos + (-delta) <= XSTRING_LENGTH (s));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1975 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1976 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1977 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1978 if (delta < 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1979 assert ((-delta) <= XSTRING_LENGTH (s));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1980 }
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
1981 #endif /* ERROR_CHECK_TEXT */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1982
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1983 if (delta == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1984 /* simplest case: no size change. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1985 return;
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1986
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1987 if (pos >= 0 && delta < 0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1988 /* If DELTA < 0, the functions below will delete the characters
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1989 before POS. We want to delete characters *after* POS, however,
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1990 so convert this to the appropriate form. */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1991 pos += -delta;
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1992
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1993 oldfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s));
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1994 newfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s) + delta);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1995
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1996 if (BIG_STRING_FULLSIZE_P (oldfullsize))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1997 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1998 if (BIG_STRING_FULLSIZE_P (newfullsize))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1999 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2000 /* Both strings are big. We can just realloc().
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2001 But careful! If the string is shrinking, we have to
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2002 memmove() _before_ realloc(), and if growing, we have to
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2003 memmove() _after_ realloc() - otherwise the access is
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2004 illegal, and we might crash. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2005 Bytecount len = XSTRING_LENGTH (s) + 1 - pos;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2006
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2007 if (delta < 0 && pos >= 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2008 memmove (XSTRING_DATA (s) + pos + delta,
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2009 XSTRING_DATA (s) + pos, len);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2010 XSET_STRING_DATA
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2011 (s, (Intbyte *) xrealloc (XSTRING_DATA (s),
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2012 XSTRING_LENGTH (s) + delta + 1));
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2013 if (delta > 0 && pos >= 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2014 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
2015 len);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2016 }
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2017 else /* String has been demoted from BIG_STRING. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2018 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2019 Intbyte *new_data =
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2020 allocate_string_chars_struct (s, newfullsize)->chars;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2021 Intbyte *old_data = XSTRING_DATA (s);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2022
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2023 if (pos >= 0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2024 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2025 memcpy (new_data, old_data, pos);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2026 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
2027 XSTRING_LENGTH (s) + 1 - pos);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2028 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2029 XSET_STRING_DATA (s, new_data);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2030 xfree (old_data);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2031 }
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2032 }
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2033 else /* old string is small */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2034 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2035 if (oldfullsize == newfullsize)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2036 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2037 /* special case; size change but the necessary
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2038 allocation size won't change (up or down; code
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2039 somewhere depends on there not being any unused
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2040 allocation space, modulo any alignment
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2041 constraints). */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2042 if (pos >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2043 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2044 Intbyte *addroff = pos + XSTRING_DATA (s);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2045
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2046 memmove (addroff + delta, addroff,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2047 /* +1 due to zero-termination. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2048 XSTRING_LENGTH (s) + 1 - pos);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2049 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2050 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2051 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2052 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2053 Intbyte *old_data = XSTRING_DATA (s);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2054 Intbyte *new_data =
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2055 BIG_STRING_FULLSIZE_P (newfullsize)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2056 ? xnew_array (Intbyte, XSTRING_LENGTH (s) + delta + 1)
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2057 : allocate_string_chars_struct (s, newfullsize)->chars;
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2058
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2059 if (pos >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2060 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2061 memcpy (new_data, old_data, pos);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2062 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
2063 XSTRING_LENGTH (s) + 1 - pos);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2064 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2065 XSET_STRING_DATA (s, new_data);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2066
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2067 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2068 /* We need to mark this chunk of the string_chars_block
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2069 as unused so that compact_string_chars() doesn't
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2070 freak. */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2071 struct string_chars *old_s_chars = (struct string_chars *)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2072 ((char *) old_data - offsetof (struct string_chars, chars));
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2073 /* Sanity check to make sure we aren't hosed by strange
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2074 alignment/padding. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2075 assert (old_s_chars->string == XSTRING (s));
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2076 MARK_STRING_CHARS_AS_FREE (old_s_chars);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2077 ((struct unused_string_chars *) old_s_chars)->fullsize =
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2078 oldfullsize;
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2079 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2080 }
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2081 }
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2082
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2083 XSET_STRING_LENGTH (s, XSTRING_LENGTH (s) + delta);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2084 /* If pos < 0, the string won't be zero-terminated.
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2085 Terminate now just to make sure. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2086 XSTRING_DATA (s)[XSTRING_LENGTH (s)] = '\0';
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2087
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2088 if (pos >= 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2089 /* 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
2090 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
2091 adjust_extents() is exclusive of the starting position
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2092 passed to it. */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2093 adjust_extents (s, pos - 1, XSTRING_LENGTH (s), delta);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2094
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2095 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2096 verify_string_chars_integrity ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2097 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2098 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2099
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2100 #ifdef MULE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2101
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2102 /* 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
2103 CHECK_LISP_WRITEABLE() before and bump_string_modiff() afterwards. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2104 void
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2105 set_string_char (Lisp_Object s, Charcount i, Emchar c)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2106 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2107 Intbyte newstr[MAX_EMCHAR_LEN];
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2108 Bytecount bytoff = string_index_char_to_byte (s, i);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2109 Bytecount oldlen = charcount_to_bytecount (XSTRING_DATA (s) + bytoff, 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2110 Bytecount newlen = set_charptr_emchar (newstr, c);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2111
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2112 sledgehammer_check_ascii_begin (s);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2113 if (oldlen != newlen)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2114 resize_string (s, bytoff, newlen - oldlen);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2115 /* 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
2116 memcpy (XSTRING_DATA (s) + bytoff, newstr, newlen);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2117 if (oldlen != newlen)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2118 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2119 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
2120 /* 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
2121 ascii_begin */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2122 XSET_STRING_ASCII_BEGIN (s, i);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2123 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
2124 /* 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
2125 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2126 Bytecount j;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2127 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
2128 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2129 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
2130 break;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2131 }
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2132 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
2133 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2134 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2135 sledgehammer_check_ascii_begin (s);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2136 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2137
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2138 #endif /* MULE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2139
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2140 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2141 Return a new string consisting of LENGTH copies of CHARACTER.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2142 LENGTH must be a non-negative integer.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2143 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2144 (length, character))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2145 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2146 CHECK_NATNUM (length);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2147 CHECK_CHAR_COERCE_INT (character);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2148 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2149 Intbyte init_str[MAX_EMCHAR_LEN];
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2150 int len = set_charptr_emchar (init_str, XCHAR (character));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2151 Lisp_Object val = make_uninit_string (len * XINT (length));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2152
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2153 if (len == 1)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2154 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2155 /* Optimize the single-byte case */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2156 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
2157 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
2158 len * XINT (length)));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2159 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2160 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2161 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
2162 EMACS_INT i;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2163 Intbyte *ptr = XSTRING_DATA (val);
428
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 for (i = XINT (length); i; i--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2166 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2167 Intbyte *init_ptr = init_str;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2168 switch (len)
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 case 4: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2171 case 3: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2172 case 2: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2173 case 1: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2174 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2175 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2176 }
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2177 sledgehammer_check_ascii_begin (val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2178 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2179 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2182 DEFUN ("string", Fstring, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2183 Concatenate all the argument characters and make the result a string.
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 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2186 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2187 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
2188 Intbyte *p = storage;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2189
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2190 for (; nargs; nargs--, args++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2191 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2192 Lisp_Object lisp_char = *args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2193 CHECK_CHAR_COERCE_INT (lisp_char);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2194 p += set_charptr_emchar (p, XCHAR (lisp_char));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2195 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2196 return make_string (storage, p - storage);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2197 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2198
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2199 /* 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
2200
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2201 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2202 init_string_ascii_begin (Lisp_Object string)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2203 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2204 #ifdef MULE
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2205 int i;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2206 Bytecount length = XSTRING_LENGTH (string);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2207 Intbyte *contents = XSTRING_DATA (string);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2208
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2209 for (i = 0; i < length; i++)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2210 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2211 if (!BYTE_ASCII_P (contents[i]))
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2212 break;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2213 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2214 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
2215 #else
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2216 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
2217 MAX_STRING_ASCII_BEGIN));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2218 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2219 sledgehammer_check_ascii_begin (string);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2220 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2221
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2222 /* Take some raw memory, which MUST already be in internal format,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2223 and package it up into a Lisp string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2224 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2225 make_string (const Intbyte *contents, Bytecount length)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2226 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2227 Lisp_Object 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 /* 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
2230 #if defined (ERROR_CHECK_TEXT) && defined (MULE)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2231 bytecount_to_charcount (contents, length); /* Just for the assertions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2232 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2233
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2234 val = make_uninit_string (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2235 memcpy (XSTRING_DATA (val), contents, length);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2236 init_string_ascii_begin (val);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2237 sledgehammer_check_ascii_begin (val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2238 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2239 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2240
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2241 /* Take some raw memory, encoded in some external data format,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2242 and convert it into a Lisp string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2243 Lisp_Object
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2244 make_ext_string (const Extbyte *contents, EMACS_INT length,
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2245 Lisp_Object coding_system)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2246 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2247 Lisp_Object string;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2248 TO_INTERNAL_FORMAT (DATA, (contents, length),
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2249 LISP_STRING, string,
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2250 coding_system);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2251 return string;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2254 Lisp_Object
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2255 build_intstring (const Intbyte *str)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2256 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2257 /* 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
2258 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
2259 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2260
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2261 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2262 build_string (const CIntbyte *str)
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 /* 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
2265 return make_string ((const Intbyte *) str, (str ? strlen (str) : 0));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2266 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2267
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2268 Lisp_Object
593
5fd7ba8b56e7 [xemacs-hg @ 2001-05-31 12:45:27 by ben]
ben
parents: 578
diff changeset
2269 build_ext_string (const Extbyte *str, Lisp_Object coding_system)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2270 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2271 /* Some strlen's crash and burn if passed null. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2272 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
2273 coding_system);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2274 }
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 Lisp_Object
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2277 build_msg_intstring (const Intbyte *str)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2278 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2279 return build_intstring (GETTEXT (str));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2280 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2281
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2282 Lisp_Object
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2283 build_msg_string (const CIntbyte *str)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2284 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2285 return build_string (CGETTEXT (str));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2286 }
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 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2289 make_string_nocopy (const Intbyte *contents, Bytecount length)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2290 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2291 Lisp_String *s;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2292 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2293
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2294 /* 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
2295 #if defined (ERROR_CHECK_TEXT) && defined (MULE)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2296 bytecount_to_charcount (contents, length); /* Just for the assertions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2297 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2298
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2299 /* Allocate the string header */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2300 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2301 set_lheader_implementation (&s->u.lheader, &lrecord_string);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2302 SET_C_READONLY_RECORD_HEADER (&s->u.lheader);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2303 s->plist = Qnil;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2304 set_string_data (s, (Intbyte *) contents);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2305 set_string_length (s, length);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2306 val = wrap_string (s);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2307 init_string_ascii_begin (val);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2308 sledgehammer_check_ascii_begin (val);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2309
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2310 return val;
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
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 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2315 /* lcrecord lists */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2316 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2317
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2318 /* Lcrecord lists are used to manage the allocation of particular
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2319 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2320 malloc() and garbage-collection junk) as much as possible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2321 It is similar to the Blocktype class.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2322
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2323 It works like this:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2324
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2325 1) Create an lcrecord-list object using make_lcrecord_list().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2326 This is often done at initialization. Remember to staticpro_nodump
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2327 this object! The arguments to make_lcrecord_list() are the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2328 same as would be passed to alloc_lcrecord().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2329 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2330 and pass the lcrecord-list earlier created.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2331 3) When done with the lcrecord, call free_managed_lcrecord().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2332 The standard freeing caveats apply: ** make sure there are no
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2333 pointers to the object anywhere! **
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2334 4) Calling free_managed_lcrecord() is just like kissing the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2335 lcrecord goodbye as if it were garbage-collected. This means:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2336 -- the contents of the freed lcrecord are undefined, and the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2337 contents of something produced by allocate_managed_lcrecord()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2338 are undefined, just like for alloc_lcrecord().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2339 -- the mark method for the lcrecord's type will *NEVER* be called
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2340 on freed lcrecords.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2341 -- the finalize method for the lcrecord's type will be called
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2342 at the time that free_managed_lcrecord() is called.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2343
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2344 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2345
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2346 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2347 mark_lcrecord_list (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2348 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2349 struct lcrecord_list *list = XLCRECORD_LIST (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2350 Lisp_Object chain = list->free;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2351
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2352 while (!NILP (chain))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2353 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2354 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2355 struct free_lcrecord_header *free_header =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2356 (struct free_lcrecord_header *) lheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2357
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2358 gc_checking_assert
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2359 (/* There should be no other pointers to the free list. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2360 ! MARKED_RECORD_HEADER_P (lheader)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2361 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2362 /* Only lcrecords should be here. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2363 ! LHEADER_IMPLEMENTATION (lheader)->basic_p
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2364 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2365 /* Only free lcrecords should be here. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2366 free_header->lcheader.free
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2367 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2368 /* The type of the lcrecord must be right. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2369 LHEADER_IMPLEMENTATION (lheader) == list->implementation
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2370 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2371 /* So must the size. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2372 (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2373 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2374 );
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2375
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2376 MARK_RECORD_HEADER (lheader);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2377 chain = free_header->chain;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2378 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2379
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2380 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2381 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2382
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2383 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2384 mark_lcrecord_list, internal_object_printer,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2385 0, 0, 0, 0, struct lcrecord_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2386 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2387 make_lcrecord_list (Elemcount size,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2388 const struct lrecord_implementation *implementation)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2389 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2390 struct lcrecord_list *p =
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2391 /* Avoid infinite recursion allocating this */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2392 alloc_unmanaged_lcrecord_type (struct lcrecord_list,
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2393 &lrecord_lcrecord_list);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2394
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2395 p->implementation = implementation;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2396 p->size = size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2397 p->free = Qnil;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2398 return wrap_lcrecord_list (p);
428
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2401 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2402 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2403 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2404 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2405 if (!NILP (list->free))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2406 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2407 Lisp_Object val = list->free;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2408 struct free_lcrecord_header *free_header =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2409 (struct free_lcrecord_header *) XPNTR (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2410
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2411 #ifdef ERROR_CHECK_GC
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2412 struct lrecord_header *lheader = &free_header->lcheader.lheader;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2413
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2414 /* There should be no other pointers to the free list. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2415 assert (! MARKED_RECORD_HEADER_P (lheader));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2416 /* Only lcrecords should be here. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2417 assert (! LHEADER_IMPLEMENTATION (lheader)->basic_p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2418 /* Only free lcrecords should be here. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2419 assert (free_header->lcheader.free);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2420 /* The type of the lcrecord must be right. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2421 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2422 /* So must the size. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2423 assert (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2424 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2425 #endif /* ERROR_CHECK_GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2426
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2427 list->free = free_header->chain;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2428 free_header->lcheader.free = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2429 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2430 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2431 else
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2432 return wrap_pointer_1 (alloc_lcrecord (list->size, list->implementation));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2433 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2434
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2435 /* "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
2436 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
2437 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
2438 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
2439 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
2440 used!
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2441
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2442 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
2443 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
2444
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2445 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2446 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2447 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2448 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2449 struct free_lcrecord_header *free_header =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2450 (struct free_lcrecord_header *) XPNTR (lcrecord);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2451 struct lrecord_header *lheader = &free_header->lcheader.lheader;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2452 const struct lrecord_implementation *implementation
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2453 = LHEADER_IMPLEMENTATION (lheader);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2454
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2455 /* 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
2456 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
2457 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
2458 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
2459 (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
2460 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
2461 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
2462 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
2463 problems. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2464 gc_checking_assert (!gc_in_progress);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2465
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2466 /* Make sure the size is correct. This will catch, for example,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2467 putting a window configuration on the wrong free list. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2468 gc_checking_assert ((implementation->size_in_bytes_method ?
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2469 implementation->size_in_bytes_method (lheader) :
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2470 implementation->static_size)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2471 == list->size);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2472 /* Make sure the object isn't already freed. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2473 gc_checking_assert (!free_header->lcheader.free);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2474
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2475 if (implementation->finalizer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2476 implementation->finalizer (lheader, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2477 free_header->chain = list->free;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2478 free_header->lcheader.free = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2479 list->free = lcrecord;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2480 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2481
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2482 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
2483
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2484 void *
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2485 alloc_automanaged_lcrecord (Bytecount size,
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2486 const struct lrecord_implementation *imp)
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 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
2489 all_lcrecord_lists[imp->lrecord_type_index] =
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2490 make_lcrecord_list (size, imp);
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 return XPNTR (allocate_managed_lcrecord
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2493 (all_lcrecord_lists[imp->lrecord_type_index]));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2494 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2495
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2496 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2497 free_lcrecord (Lisp_Object rec)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2498 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2499 int type = XRECORD_LHEADER (rec)->type;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2500
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2501 assert (!EQ (all_lcrecord_lists[type], Qzero));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2502
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2503 free_managed_lcrecord (all_lcrecord_lists[type], rec);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2504 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2505
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 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2508 Kept for compatibility, returns its argument.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2509 Old:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2510 Make a copy of OBJECT in pure storage.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2511 Recursively copies contents of vectors and cons cells.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2512 Does not copy symbols.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2513 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2514 (object))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2515 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2516 return object;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2517 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2518
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2519
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2520 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2521 /* Garbage Collection */
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
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2524 /* 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
2525 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
2526 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
2527 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
2528 int lrecord_type_count = lrecord_type_last_built_in_type;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2529 /* Object marker functions are in the lrecord_implementation structure.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2530 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
2531 This hack speeds up (garbage-collect) by about 5%. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2532 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2533
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2534 struct gcpro *gcprolist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2535
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2536 /* 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
2537 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
2538 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
2539 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
2540 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
2541 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
2542 "root pointer"; this happens in the call to staticpro(). */
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2543 static const struct lrecord_description staticpro_description_1[] = {
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2544 { XD_END }
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
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2547 static const struct struct_description staticpro_description = {
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2548 sizeof (Lisp_Object *),
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2549 staticpro_description_1
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2550 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2551
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2552 static const struct lrecord_description staticpros_description_1[] = {
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2553 XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description),
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2554 { XD_END }
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2555 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2556
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2557 static const struct struct_description staticpros_description = {
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2558 sizeof (Lisp_Object_ptr_dynarr),
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2559 staticpros_description_1
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2560 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2561
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2562 #ifdef DEBUG_XEMACS
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2563
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2564 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
2565 { XD_C_STRING, 0 },
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2566 { XD_END }
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
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2569 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
2570 sizeof (char *),
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2571 staticpro_one_name_description_1
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
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2574 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
2575 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
2576 { XD_END }
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
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2579 static const struct struct_description staticpro_names_description = {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2580 sizeof (char_ptr_dynarr),
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2581 staticpro_names_description_1
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
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2584 /* 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
2585
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2586 Lisp_Object_ptr_dynarr *staticpros;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2587 char_ptr_dynarr *staticpro_names;
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 /* 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
2590 garbage collection, and for dumping. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2591 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2592 staticpro_1 (Lisp_Object *varaddress, char *varname)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2593 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2594 Dynarr_add (staticpros, varaddress);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2595 Dynarr_add (staticpro_names, varname);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2596 dump_add_root_object (varaddress);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2597 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2598
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 Lisp_Object_ptr_dynarr *staticpros_nodump;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2601 char_ptr_dynarr *staticpro_nodump_names;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2602
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2603 /* 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
2604 garbage collection, but not for dumping. (See below.) */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2605 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2606 staticpro_nodump_1 (Lisp_Object *varaddress, char *varname)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2607 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2608 Dynarr_add (staticpros_nodump, varaddress);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2609 Dynarr_add (staticpro_nodump_names, varname);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2610 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2611
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2612 #else /* not DEBUG_XEMACS */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2613
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2614 Lisp_Object_ptr_dynarr *staticpros;
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2615
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2616 /* 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
2617 garbage collection, and for dumping. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2618 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2619 staticpro (Lisp_Object *varaddress)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2620 {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2621 Dynarr_add (staticpros, varaddress);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2622 dump_add_root_object (varaddress);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2623 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2624
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2625
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2626 Lisp_Object_ptr_dynarr *staticpros_nodump;
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2627
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2628 /* 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
2629 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
2630 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
2631 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
2632 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
2633 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
2634 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
2635 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
2636 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
2637 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
2638 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
2639 reloaded at a different address.)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2640
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2641 #### 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
2642 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
2643 loads the data in. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2644
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2645 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2646 staticpro_nodump (Lisp_Object *varaddress)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2647 {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2648 Dynarr_add (staticpros_nodump, varaddress);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2649 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2650
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2651 #endif /* not DEBUG_XEMACS */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2652
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2653 #ifdef ERROR_CHECK_GC
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2654 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2655 struct lrecord_header * GCLI_lh = (lheader); \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2656 assert (GCLI_lh != 0); \
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
2657 assert (GCLI_lh->type < (unsigned int) lrecord_type_count); \
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2658 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2659 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2660 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2661 } while (0)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2662 #else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2663 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2664 #endif
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2665
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2666
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2667 /* 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
2668 seen yet, recursively mark all the references contained in it. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2669
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2670 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2671 mark_object (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2672 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2673 tail_recurse:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2674
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2675 /* Checks we used to perform */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2676 /* if (EQ (obj, Qnull_pointer)) return; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2677 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2678 /* if (PURIFIED (XPNTR (obj))) return; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2679
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2680 if (XTYPE (obj) == Lisp_Type_Record)
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 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
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 GC_CHECK_LHEADER_INVARIANTS (lheader);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2685
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2686 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2687 ! ((struct lcrecord_header *) lheader)->free);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2688
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2689 /* All c_readonly objects have their mark bit set,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2690 so that we only need to check the mark bit here. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2691 if (! MARKED_RECORD_HEADER_P (lheader))
428
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_RECORD_HEADER (lheader);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2694
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2695 if (RECORD_MARKER (lheader))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2696 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2697 obj = RECORD_MARKER (lheader) (obj);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2698 if (!NILP (obj)) goto tail_recurse;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2699 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2700 }
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 }
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 /* 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
2705 DO NOT mark the cars.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2706
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2707 Use only for internal lists! There should never be other pointers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2708 to the cons cells, because if so, the cars will remain unmarked
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2709 even when they maybe should be marked. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2710 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2711 mark_conses_in_list (Lisp_Object obj)
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 Lisp_Object rest;
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 for (rest = obj; CONSP (rest); rest = XCDR (rest))
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 if (CONS_MARKED_P (XCONS (rest)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2718 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2719 MARK_CONS (XCONS (rest));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2720 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2721
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2722 mark_object (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2723 }
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 /* Find all structures not marked, and free them. */
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 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
2729 static int gc_count_bit_vector_storage;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2730 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
2731 static Bytecount gc_count_string_total_size;
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
2732 static Bytecount gc_count_short_string_total_size;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2733
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2734 /* static int gc_count_total_records_used, gc_count_records_total_size; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2735
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2736
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2737 /* stats on lcrecords in use - kinda kludgy */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2738
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2739 static struct
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2740 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2741 int instances_in_use;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2742 int bytes_in_use;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2743 int instances_freed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2744 int bytes_freed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2745 int instances_on_free_list;
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 665
diff changeset
2746 } lcrecord_stats [countof (lrecord_implementations_table)
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 665
diff changeset
2747 + MODULE_DEFINABLE_TYPE_COUNT];
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2748
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2749 static void
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2750 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2751 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
2752 int type_index = h->type;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2753
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2754 if (((struct lcrecord_header *) h)->free)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2755 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2756 gc_checking_assert (!free_p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2757 lcrecord_stats[type_index].instances_on_free_list++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2758 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2759 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2760 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2761 const struct lrecord_implementation *implementation =
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2762 LHEADER_IMPLEMENTATION (h);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2763
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2764 Bytecount sz = (implementation->size_in_bytes_method ?
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2765 implementation->size_in_bytes_method (h) :
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2766 implementation->static_size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2767 if (free_p)
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 lcrecord_stats[type_index].instances_freed++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2770 lcrecord_stats[type_index].bytes_freed += sz;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2771 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2772 else
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 lcrecord_stats[type_index].instances_in_use++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2775 lcrecord_stats[type_index].bytes_in_use += sz;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2776 }
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 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2781 /* Free all unmarked records */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2782 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2783 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2784 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2785 struct lcrecord_header *header;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2786 int num_used = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2787 /* int total_size = 0; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2788
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2789 xzero (lcrecord_stats); /* Reset all statistics to 0. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2790
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2791 /* First go through and call all the finalize methods.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2792 Then go through and free the objects. There used to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2793 be only one loop here, with the call to the finalizer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2794 occurring directly before the xfree() below. That
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2795 is marginally faster but much less safe -- if the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2796 finalize method for an object needs to reference any
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2797 other objects contained within it (and many do),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2798 we could easily be screwed by having already freed that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2799 other object. */
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 for (header = *prev; header; header = header->next)
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 struct lrecord_header *h = &(header->lheader);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2804
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2805 GC_CHECK_LHEADER_INVARIANTS (h);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2806
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2807 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2808 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2809 if (LHEADER_IMPLEMENTATION (h)->finalizer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2810 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2811 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2812 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2813
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2814 for (header = *prev; header; )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2815 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2816 struct lrecord_header *h = &(header->lheader);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2817 if (MARKED_RECORD_HEADER_P (h))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2818 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2819 if (! C_READONLY_RECORD_HEADER_P (h))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2820 UNMARK_RECORD_HEADER (h);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2821 num_used++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2822 /* total_size += n->implementation->size_in_bytes (h);*/
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2823 /* #### May modify header->next on a C_READONLY lcrecord */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2824 prev = &(header->next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2825 header = *prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2826 tick_lcrecord_stats (h, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2827 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2828 else
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 struct lcrecord_header *next = header->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2831 *prev = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2832 tick_lcrecord_stats (h, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2833 /* used to call finalizer right here. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2834 xfree (header);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2835 header = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2836 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2837 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2838 *used = num_used;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2839 /* *total = total_size; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2840 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2841
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2842
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2843 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2844 sweep_bit_vectors_1 (Lisp_Object *prev,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2845 int *used, int *total, int *storage)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2846 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2847 Lisp_Object bit_vector;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2848 int num_used = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2849 int total_size = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2850 int total_storage = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2851
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2852 /* BIT_VECTORP fails because the objects are marked, which changes
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2853 their implementation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2854 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2855 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2856 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2857 int len = v->size;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2858 if (MARKED_RECORD_P (bit_vector))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2859 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2860 if (! C_READONLY_RECORD_HEADER_P(&(v->lheader)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2861 UNMARK_RECORD_HEADER (&(v->lheader));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2862 total_size += len;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2863 total_storage +=
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2864 MALLOC_OVERHEAD +
456
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 454
diff changeset
2865 FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long,
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 454
diff changeset
2866 bits, BIT_VECTOR_LONG_STORAGE (len));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2867 num_used++;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2868 /* #### May modify next on a C_READONLY bitvector */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2869 prev = &(bit_vector_next (v));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2870 bit_vector = *prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2871 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2872 else
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 Lisp_Object next = bit_vector_next (v);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2875 *prev = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2876 xfree (v);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2877 bit_vector = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2878 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2879 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2880 *used = num_used;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2881 *total = total_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2882 *storage = total_storage;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2883 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2884
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2885 /* And the Lord said: Thou shalt use the `c-backslash-region' command
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2886 to make macros prettier. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2887
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2888 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2889
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2890 #define SWEEP_FIXED_TYPE_BLOCK_1(typename, obj_type, lheader) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2891 do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2892 struct typename##_block *SFTB_current; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2893 int SFTB_limit; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2894 int num_free = 0, num_used = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2895 \
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2896 for (SFTB_current = current_##typename##_block, \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2897 SFTB_limit = current_##typename##_block_index; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2898 SFTB_current; \
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 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2901 int SFTB_iii; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2902 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2903 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2904 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2905 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2906 \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2907 if (LRECORD_FREE_P (SFTB_victim)) \
428
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 num_free++; \
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 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2912 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2913 num_used++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2914 } \
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2915 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2916 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2917 num_free++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2918 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2919 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2920 else \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2921 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2922 num_used++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2923 UNMARK_##typename (SFTB_victim); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2924 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2925 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2926 SFTB_current = SFTB_current->prev; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2927 SFTB_limit = countof (current_##typename##_block->block); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2928 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2929 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2930 gc_count_num_##typename##_in_use = num_used; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2931 gc_count_num_##typename##_freelist = num_free; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2932 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2933
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2934 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2935
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2936 #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
2937 do { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2938 struct typename##_block *SFTB_current; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2939 struct typename##_block **SFTB_prev; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2940 int SFTB_limit; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2941 int num_free = 0, num_used = 0; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2942 \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2943 typename##_free_list = 0; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2944 \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2945 for (SFTB_prev = &current_##typename##_block, \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2946 SFTB_current = current_##typename##_block, \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2947 SFTB_limit = current_##typename##_block_index; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2948 SFTB_current; \
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 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2951 int SFTB_iii; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2952 int SFTB_empty = 1; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2953 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
2954 \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2955 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
2956 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2957 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
2958 \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2959 if (LRECORD_FREE_P (SFTB_victim)) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2960 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2961 num_free++; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2962 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
2963 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2964 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
2965 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2966 SFTB_empty = 0; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2967 num_used++; \
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 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
2970 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2971 num_free++; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2972 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2973 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2974 else \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2975 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2976 SFTB_empty = 0; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2977 num_used++; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2978 UNMARK_##typename (SFTB_victim); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2979 } \
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 if (!SFTB_empty) \
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 SFTB_prev = &(SFTB_current->prev); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2984 SFTB_current = SFTB_current->prev; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2985 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2986 else if (SFTB_current == current_##typename##_block \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2987 && !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 /* No real point in freeing sole allocation block */ \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2990 break; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2991 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2992 else \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2993 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2994 struct typename##_block *SFTB_victim_block = SFTB_current; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2995 if (SFTB_victim_block == current_##typename##_block) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2996 current_##typename##_block_index \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2997 = countof (current_##typename##_block->block); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2998 SFTB_current = SFTB_current->prev; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2999 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3000 *SFTB_prev = SFTB_current; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3001 xfree (SFTB_victim_block); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3002 /* 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
3003 typename##_free_list = SFTB_old_free_list; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3004 num_free -= SFTB_limit; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3005 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3006 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3007 SFTB_limit = countof (current_##typename##_block->block); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3008 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3009 \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3010 gc_count_num_##typename##_in_use = num_used; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3011 gc_count_num_##typename##_freelist = num_free; \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3012 } while (0)
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 #endif /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3015
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3016 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3017 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
3018
428
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3021
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3022 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3023 sweep_conses (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3024 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3025 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3026 #define ADDITIONAL_FREE_cons(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3027
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3028 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3029 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3030
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3031 /* Explicitly free a cons cell. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3032 void
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3033 free_cons (Lisp_Cons *ptr)
428
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 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3036 /* 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
3037 always be four-byte aligned. If this cons cell has already been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3038 placed on the free list, however, its car will probably contain
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3039 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
3040 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
3041 check to make sure we're not freeing something already freed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3042 if (POINTER_TYPE_P (XTYPE (ptr->car)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3043 ASSERT_VALID_POINTER (XPNTR (ptr->car));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3044 #endif /* ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3045
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3046 #ifndef ALLOC_NO_POOLS
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3047 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3048 #endif /* ALLOC_NO_POOLS */
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3051 /* explicitly free a list. You **must make sure** that you have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3052 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
3053 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
3054 are, you will lose. */
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 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3057 free_list (Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3058 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3059 Lisp_Object rest, next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3060
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3061 for (rest = list; !NILP (rest); rest = next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3062 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3063 next = XCDR (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3064 free_cons (XCONS (rest));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3065 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3068 /* explicitly free an alist. You **must make sure** that you have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3069 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
3070 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
3071 are, you will lose. */
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 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3074 free_alist (Lisp_Object alist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3075 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3076 Lisp_Object rest, next;
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 for (rest = alist; !NILP (rest); rest = next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3079 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3080 next = XCDR (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3081 free_cons (XCONS (XCAR (rest)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3082 free_cons (XCONS (rest));
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
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_compiled_functions (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_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3090 #define ADDITIONAL_FREE_compiled_function(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3091
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3092 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
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
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 #ifdef LISP_FLOAT_TYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3097 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3098 sweep_floats (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3099 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3100 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3101 #define ADDITIONAL_FREE_float(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3102
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3103 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
428
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 #endif /* LISP_FLOAT_TYPE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3106
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3107 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3108 sweep_symbols (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3109 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3110 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3111 #define ADDITIONAL_FREE_symbol(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3112
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3113 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3114 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3115
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3116 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3117 sweep_extents (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3118 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3119 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3120 #define ADDITIONAL_FREE_extent(ptr)
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 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3123 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3124
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3125 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3126 sweep_events (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3127 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3128 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3129 #define ADDITIONAL_FREE_event(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3130
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3131 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3132 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3133
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3134 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3135 sweep_markers (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3136 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3137 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3138 #define ADDITIONAL_FREE_marker(ptr) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3139 do { Lisp_Object tem; \
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3140 tem = wrap_marker (ptr); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3141 unchain_marker (tem); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3142 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3143
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3144 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3145 }
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 /* Explicitly free a marker. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3148 void
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3149 free_marker (Lisp_Marker *ptr)
428
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 /* Perhaps this will catch freeing an already-freed marker. */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3152 gc_checking_assert (ptr->lheader.type == lrecord_type_marker);
428
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 #ifndef ALLOC_NO_POOLS
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3155 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3156 #endif /* ALLOC_NO_POOLS */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3157 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3160 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3161
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3162 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3163 verify_string_chars_integrity (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3164 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3165 struct string_chars_block *sb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3166
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3167 /* Scan each existing string block sequentially, string by string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3168 for (sb = first_string_chars_block; sb; sb = sb->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3169 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3170 int pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3171 /* POS is the index of the next string in the block. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3172 while (pos < sb->pos)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3173 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3174 struct string_chars *s_chars =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3175 (struct string_chars *) &(sb->string_chars[pos]);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3176 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3177 int size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3178 int fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3179
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3180 /* 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
3181 STRING pointer is NULL) then this is an unused chunk of
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3182 string storage. (See below.) */
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3183
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3184 if (STRING_CHARS_FREE_P (s_chars))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3185 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3186 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3187 pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3188 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3189 }
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 string = s_chars->string;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3192 /* Must be 32-bit aligned. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3193 assert ((((int) string) & 3) == 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3194
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3195 size = string->size_;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3196 fullsize = STRING_FULLSIZE (size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3197
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3198 assert (!BIG_STRING_FULLSIZE_P (fullsize));
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3199 assert (string->data_ == s_chars->chars);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3200 pos += fullsize;
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 assert (pos == sb->pos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3203 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3204 }
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 #endif /* MULE && ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3207
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3208 /* Compactify string chars, relocating the reference to each --
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3209 free any empty string_chars_block we see. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3210 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3211 compact_string_chars (void)
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_block *to_sb = first_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3214 int to_pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3215 struct string_chars_block *from_sb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3216
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3217 /* Scan each existing string block sequentially, string by string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3218 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
3219 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3220 int from_pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3221 /* FROM_POS is the index of the next string in the block. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3222 while (from_pos < from_sb->pos)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3223 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3224 struct string_chars *from_s_chars =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3225 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3226 struct string_chars *to_s_chars;
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3227 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3228 int size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3229 int fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3230
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3231 /* 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
3232 STRING pointer is NULL) then this is an unused chunk of
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3233 string storage. This happens under Mule when a string's
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3234 size changes in such a way that its fullsize changes.
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3235 (Strings can change size because a different-length
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3236 character can be substituted for another character.)
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3237 In this case, after the bogus string pointer is the
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3238 "fullsize" of this entry, i.e. how many bytes to skip. */
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3239
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3240 if (STRING_CHARS_FREE_P (from_s_chars))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3241 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3242 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3243 from_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3244 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3245 }
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 string = from_s_chars->string;
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3248 assert (!(LRECORD_FREE_P (string)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3249
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3250 size = string->size_;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3251 fullsize = STRING_FULLSIZE (size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3252
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3253 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3254
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3255 /* 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
3256 if (! MARKED_RECORD_HEADER_P (&(string->u.lheader)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3257 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3258 from_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3259 continue;
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 /* 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
3263 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
3264 cannot advance past FROM_SB here since FROM_SB is large enough
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3265 to currently contain this string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3266 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3267 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3268 to_sb->pos = to_pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3269 to_sb = to_sb->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3270 to_pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3271 }
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 /* Compute new address of this string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3274 and update TO_POS for the space being used. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3275 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
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 /* Copy the string_chars to the new place. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3278 if (from_s_chars != to_s_chars)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3279 memmove (to_s_chars, from_s_chars, fullsize);
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 /* Relocate FROM_S_CHARS's reference */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3282 set_string_data (string, &(to_s_chars->chars[0]));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3283
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3284 from_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3285 to_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3286 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3287 }
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 /* Set current to the last string chars block still used and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3290 free any that follow. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3291 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3292 struct string_chars_block *victim;
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 for (victim = to_sb->next; victim; )
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 struct string_chars_block *next = victim->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3297 xfree (victim);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3298 victim = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3299 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3300
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3301 current_string_chars_block = to_sb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3302 current_string_chars_block->pos = to_pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3303 current_string_chars_block->next = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3304 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3305 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3306
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3307 #if 1 /* Hack to debug missing purecopy's */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3308 static int debug_string_purity;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3309
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3310 static void
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3311 debug_string_purity_print (Lisp_Object p)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3312 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3313 Charcount i;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3314 Charcount s = XSTRING_CHAR_LENGTH (p);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3315 stderr_out ("\"");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3316 for (i = 0; i < s; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3317 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3318 Emchar ch = XSTRING_CHAR (p, i);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3319 if (ch < 32 || ch >= 126)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3320 stderr_out ("\\%03o", ch);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3321 else if (ch == '\\' || ch == '\"')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3322 stderr_out ("\\%c", ch);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3323 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3324 stderr_out ("%c", ch);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3325 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3326 stderr_out ("\"\n");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3327 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3328 #endif /* 1 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3329
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3330
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3331 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3332 sweep_strings (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3333 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
3334 int num_small_used = 0;
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
3335 Bytecount num_small_bytes = 0, num_bytes = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3336 int debug = debug_string_purity;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3337
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3338 #define UNMARK_string(ptr) do { \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3339 Lisp_String *p = (ptr); \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3340 Bytecount size = p->size_; \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3341 UNMARK_RECORD_HEADER (&(p->u.lheader)); \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3342 num_bytes += size; \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3343 if (!BIG_STRING_SIZE_P (size)) \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3344 { \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3345 num_small_bytes += size; \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3346 num_small_used++; \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3347 } \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3348 if (debug) \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3349 debug_string_purity_print (wrap_string (p)); \
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3350 } while (0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3351 #define ADDITIONAL_FREE_string(ptr) do { \
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3352 Bytecount size = ptr->size_; \
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3353 if (BIG_STRING_SIZE_P (size)) \
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3354 xfree (ptr->data_); \
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3355 } while (0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3356
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3357 SWEEP_FIXED_TYPE_BLOCK_1 (string, Lisp_String, u.lheader);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3358
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3359 gc_count_num_short_string_in_use = num_small_used;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3360 gc_count_string_total_size = num_bytes;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3361 gc_count_short_string_total_size = num_small_bytes;
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
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 /* I hate duplicating all this crap! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3366 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3367 marked_p (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3368 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3369 /* Checks we used to perform. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3370 /* if (EQ (obj, Qnull_pointer)) return 1; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3371 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3372 /* if (PURIFIED (XPNTR (obj))) return 1; */
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 if (XTYPE (obj) == Lisp_Type_Record)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3375 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3376 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3377
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3378 GC_CHECK_LHEADER_INVARIANTS (lheader);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3379
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3380 return MARKED_RECORD_HEADER_P (lheader);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3381 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3382 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3383 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3384
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3385 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3386 gc_sweep (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3387 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3388 /* Free all unmarked records. Do this at the very beginning,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3389 before anything else, so that the finalize methods can safely
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3390 examine items in the objects. sweep_lcrecords_1() makes
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3391 sure to call all the finalize methods *before* freeing anything,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3392 to complete the safety. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3393 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3394 int ignored;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3395 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3396 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3397
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3398 compact_string_chars ();
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 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3401 macros) must be *extremely* careful to make sure they're not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3402 referencing freed objects. The only two existing finalize
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3403 methods (for strings and markers) pass muster -- the string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3404 finalizer doesn't look at anything but its own specially-
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3405 created block, and the marker finalizer only looks at live
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3406 buffers (which will never be freed) and at the markers before
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3407 and after it in the chain (which, by induction, will never be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3408 freed because if so, they would have already removed themselves
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3409 from the chain). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3410
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3411 /* Put all unmarked strings on free list, free'ing the string chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3412 of large unmarked strings */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3413 sweep_strings ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3414
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3415 /* Put all unmarked conses on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3416 sweep_conses ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3417
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3418 /* Free all unmarked bit vectors */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3419 sweep_bit_vectors_1 (&all_bit_vectors,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3420 &gc_count_num_bit_vector_used,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3421 &gc_count_bit_vector_total_size,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3422 &gc_count_bit_vector_storage);
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 /* Free all unmarked compiled-function objects */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3425 sweep_compiled_functions ();
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 #ifdef LISP_FLOAT_TYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3428 /* Put all unmarked floats on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3429 sweep_floats ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3430 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3431
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3432 /* Put all unmarked symbols on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3433 sweep_symbols ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3434
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3435 /* Put all unmarked extents on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3436 sweep_extents ();
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 /* Put all unmarked markers on free list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3439 Dechain each one first from the buffer into which it points. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3440 sweep_markers ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3441
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3442 sweep_events ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3443
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3444 #ifdef PDUMP
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3445 pdump_objects_unmark ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3446 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3447 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3448
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3449 /* Clearing for disksave. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3450
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3451 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3452 disksave_object_finalization (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3453 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3454 /* It's important that certain information from the environment not get
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3455 dumped with the executable (pathnames, environment variables, etc.).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3456 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
3457 clear some known-to-be-garbage blocks of memory, so that leftover
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3458 results of old evaluation don't look like potential problems.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3459 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
3460 to turn those strings into garbage.
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3461 */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3462
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3463 /* Yeah, this list is pretty ad-hoc... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3464 Vprocess_environment = Qnil;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3465 env_initted = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3466 Vexec_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3467 Vdata_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3468 Vsite_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3469 Vdoc_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3470 Vconfigure_info_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3471 Vexec_path = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3472 Vload_path = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3473 /* Vdump_load_path = Qnil; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3474 /* Release hash tables for locate_file */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3475 Flocate_file_clear_hashing (Qt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3476 uncache_home_directory ();
776
79940b592197 [xemacs-hg @ 2002-03-15 07:43:14 by ben]
ben
parents: 771
diff changeset
3477 zero_out_command_line_status_vars ();
428
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 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3480 defined(LOADHIST_BUILTIN))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3481 Vload_history = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3482 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3483 Vshell_file_name = Qnil;
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 garbage_collect_1 ();
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 /* Run the disksave finalization methods of all live objects. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3488 disksave_object_finalization_1 ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3489
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3490 /* Zero out the uninitialized (really, unused) part of the containers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3491 for the live strings. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3492 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3493 struct string_chars_block *scb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3494 for (scb = first_string_chars_block; scb; scb = scb->next)
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 int count = sizeof (scb->string_chars) - scb->pos;
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 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3499 if (count != 0)
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3500 {
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3501 /* from the block's fill ptr to the end */
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3502 memset ((scb->string_chars + scb->pos), 0, count);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3503 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3504 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3505 }
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 /* There, that ought to be enough... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3508
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3509 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3510
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3511
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3512 static Lisp_Object
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3513 restore_gc_inhibit (Lisp_Object val)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3514 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3515 gc_currently_forbidden = XINT (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3516 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3517 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3518
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3519 int
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3520 begin_gc_forbidden (void)
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 int speccount = record_unwind_protect (restore_gc_inhibit,
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3523 make_int (gc_currently_forbidden));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3524 gc_currently_forbidden = 1;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3525 return speccount;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3526 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3527
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3528 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3529 end_gc_forbidden (int count)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3530 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3531 unbind_to (count);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3532 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3533
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3534 /* 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
3535 static int gc_hooks_inhibited;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3536
611
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3537 struct post_gc_action
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 void (*fun) (void *);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3540 void *arg;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3541 };
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3542
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3543 typedef struct post_gc_action post_gc_action;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3544
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3545 typedef struct
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3546 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3547 Dynarr_declare (post_gc_action);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3548 } post_gc_action_dynarr;
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 static post_gc_action_dynarr *post_gc_actions;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3551
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3552 /* 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
3553 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
3554 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
3555 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
3556
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3557 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
3558 And NEVER signal an error.
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3559 */
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 void
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3562 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
3563 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3564 post_gc_action action;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3565
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3566 if (!post_gc_actions)
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3567 post_gc_actions = Dynarr_new (post_gc_action);
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 action.fun = fun;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3570 action.arg = arg;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3571
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3572 Dynarr_add (post_gc_actions, action);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3573 }
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3574
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3575 static void
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3576 run_post_gc_actions (void)
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3577 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3578 int i;
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 if (post_gc_actions)
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3581 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3582 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
3583 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3584 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
3585 (action.fun) (action.arg);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3586 }
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3587
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3588 Dynarr_reset (post_gc_actions);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3589 }
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3590 }
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3591
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3592
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3593 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3594 garbage_collect_1 (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3595 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3596 #if MAX_SAVE_STACK > 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3597 char stack_top_variable;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3598 extern char *stack_bottom;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3599 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3600 struct frame *f;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3601 int speccount;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3602 int cursor_changed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3603 Lisp_Object pre_gc_cursor;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3604 struct gcpro gcpro1;
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 if (gc_in_progress
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3607 || gc_currently_forbidden
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3608 || in_display
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3609 || preparing_for_armageddon)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3610 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3611
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3612 /* We used to call selected_frame() here.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3613
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3614 The following functions cannot be called inside GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3615 so we move to after the above tests. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3616 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3617 Lisp_Object frame;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3618 Lisp_Object device = Fselected_device (Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3619 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3620 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3621 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3622 if (NILP (frame))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 551
diff changeset
3623 invalid_state ("No frames exist on device", device);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3624 f = XFRAME (frame);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3627 pre_gc_cursor = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3628 cursor_changed = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3629
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3630 GCPRO1 (pre_gc_cursor);
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 /* Very important to prevent GC during any of the following
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3633 stuff that might run Lisp code; otherwise, we'll likely
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3634 have infinite GC recursion. */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3635 speccount = begin_gc_forbidden ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3636
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3637 if (!gc_hooks_inhibited)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3638 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3639
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3640 /* Now show the GC cursor/message. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3641 if (!noninteractive)
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 if (FRAME_WIN_P (f))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3644 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3645 Lisp_Object frame = wrap_frame (f);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3646 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3647 FRAME_SELECTED_WINDOW (f),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3648 ERROR_ME_NOT, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3649 pre_gc_cursor = f->pointer;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3650 if (POINTER_IMAGE_INSTANCEP (cursor)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3651 /* don't change if we don't know how to change back. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3652 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3653 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3654 cursor_changed = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3655 Fset_frame_pointer (frame, cursor);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3656 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3657 }
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 /* Don't print messages to the stream device. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3660 if (!cursor_changed && !FRAME_STREAM_P (f))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3661 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3662 Lisp_Object args[2], whole_msg;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3663 args[0] = (STRINGP (Vgc_message) ? Vgc_message :
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3664 build_msg_string (gc_default_message));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3665 args[1] = build_string ("...");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3666 whole_msg = Fconcat (2, args);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3667 echo_area_message (f, (Intbyte *) 0, whole_msg, 0, -1,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3668 Qgarbage_collecting);
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3671
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3672 /***** Now we actually start the garbage collection. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3673
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3674 gc_in_progress = 1;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3675 inhibit_non_essential_printing_operations = 1;
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 gc_generation_number[0]++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3678
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3679 #if MAX_SAVE_STACK > 0
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 /* Save a copy of the contents of the stack, for debugging. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3682 if (!purify_flag)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3683 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3684 /* 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
3685 static char *stack_copy;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3686 static Bytecount stack_copy_size;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3687
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3688 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
3689 Bytecount stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3690 if (stack_size < MAX_SAVE_STACK)
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 if (stack_copy_size < stack_size)
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 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3695 stack_copy_size = stack_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3696 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3697
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3698 memcpy (stack_copy,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3699 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3700 stack_size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3701 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3702 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3703 #endif /* MAX_SAVE_STACK > 0 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3704
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3705 /* Do some totally ad-hoc resource clearing. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3706 /* #### generalize this? */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3707 clear_event_resource ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3708 cleanup_specifiers ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3709
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3710 /* Mark all the special slots that serve as the roots of accessibility. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3711
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3712 { /* staticpro() */
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3713 Lisp_Object **p = Dynarr_begin (staticpros);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3714 Elemcount count;
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3715 for (count = Dynarr_length (staticpros); count; count--)
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3716 mark_object (**p++);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3717 }
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3718
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3719 { /* staticpro_nodump() */
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3720 Lisp_Object **p = Dynarr_begin (staticpros_nodump);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3721 Elemcount count;
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3722 for (count = Dynarr_length (staticpros_nodump); count; count--)
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3723 mark_object (**p++);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3724 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3725
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3726 { /* GCPRO() */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3727 struct gcpro *tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3728 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3729 for (tail = gcprolist; tail; tail = tail->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3730 for (i = 0; i < tail->nvars; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3731 mark_object (tail->var[i]);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3734 { /* specbind() */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3735 struct specbinding *bind;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3736 for (bind = specpdl; bind != specpdl_ptr; bind++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3737 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3738 mark_object (bind->symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3739 mark_object (bind->old_value);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3743 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3744 struct catchtag *catch;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3745 for (catch = catchlist; catch; catch = catch->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3746 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3747 mark_object (catch->tag);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3748 mark_object (catch->val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3749 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3750 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3751
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3752 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3753 struct backtrace *backlist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3754 for (backlist = backtrace_list; backlist; backlist = backlist->next)
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 int nargs = backlist->nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3757 int i;
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 mark_object (*backlist->function);
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3760 if (nargs < 0 /* nargs == UNEVALLED || nargs == MANY */)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3761 mark_object (backlist->args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3762 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3763 for (i = 0; i < nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3764 mark_object (backlist->args[i]);
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3767
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3768 mark_profiling_info ();
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 /* OK, now do the after-mark stuff. This is for things that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3771 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
3772 There may be complex dependencies between such objects -- e.g.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3773 a weak hash table might be unmarked, but after processing a later
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3774 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
3775 iterate until nothing more gets marked. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3776
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3777 while (finish_marking_weak_hash_tables () > 0 ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3778 finish_marking_weak_lists () > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3779 ;
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 /* And prune (this needs to be called after everything else has been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3782 marked and before we do any sweeping). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3783 /* #### this is somewhat ad-hoc and should probably be an object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3784 method */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3785 prune_weak_hash_tables ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3786 prune_weak_lists ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3787 prune_specifiers ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3788 prune_syntax_tables ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3789
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3790 gc_sweep ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3791
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3792 consing_since_gc = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3793 #ifndef DEBUG_XEMACS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3794 /* Allow you to set it really fucking low if you really want ... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3795 if (gc_cons_threshold < 10000)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3796 gc_cons_threshold = 10000;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3797 #endif
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
3798 recompute_need_to_garbage_collect ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3799
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3800 inhibit_non_essential_printing_operations = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3801 gc_in_progress = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3802
611
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3803 run_post_gc_actions ();
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3804
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3805 /******* End of garbage collection ********/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3806
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3807 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
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 /* Now remove the GC cursor/message */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3810 if (!noninteractive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3811 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3812 if (cursor_changed)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3813 Fset_frame_pointer (wrap_frame (f), pre_gc_cursor);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3814 else if (!FRAME_STREAM_P (f))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3815 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3816 /* Show "...done" only if the echo area would otherwise be empty. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3817 if (NILP (clear_echo_area (selected_frame (),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3818 Qgarbage_collecting, 0)))
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 Lisp_Object args[2], whole_msg;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3821 args[0] = (STRINGP (Vgc_message) ? Vgc_message :
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3822 build_msg_string (gc_default_message));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3823 args[1] = build_msg_string ("... done");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3824 whole_msg = Fconcat (2, args);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3825 echo_area_message (selected_frame (), (Intbyte *) 0,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3826 whole_msg, 0, -1,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3827 Qgarbage_collecting);
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3830 }
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 /* now stop inhibiting GC */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3833 unbind_to (speccount);
428
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 if (!breathing_space)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3836 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3837 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3838 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3839
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3840 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3841 return;
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 /* Debugging aids. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3845
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3846 static Lisp_Object
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3847 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
3848 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3849 /* 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
3850 or portable numeric datatypes, or bit-vectors, or characters, or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3851 arrays, or exceptions, or ...) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3852 return cons3 (intern (name), make_int (value), tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3853 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3854
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3855 #define HACK_O_MATIC(type, name, pl) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3856 int s = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3857 struct type##_block *x = current_##type##_block; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3858 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3859 (pl) = gc_plist_hack ((name), s, (pl)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3860 } while (0)
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 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3863 Reclaim storage for Lisp objects no longer needed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3864 Return info on amount of space in use:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3865 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3866 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3867 PLIST)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3868 where `PLIST' is a list of alternating keyword/value pairs providing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3869 more detailed information.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3870 Garbage collection happens automatically if you cons more than
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3871 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3872 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3873 ())
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3874 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3875 Lisp_Object pl = Qnil;
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
3876 int i;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3877 int gc_count_vector_total_size = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3878
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3879 garbage_collect_1 ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3880
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3881 for (i = 0; i < lrecord_type_count; i++)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3882 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3883 if (lcrecord_stats[i].bytes_in_use != 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3884 || lcrecord_stats[i].bytes_freed != 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3885 || lcrecord_stats[i].instances_on_free_list != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3886 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3887 char buf [255];
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3888 const char *name = lrecord_implementations_table[i]->name;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3889 int len = strlen (name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3890 /* save this for the FSFmacs-compatible part of the summary */
460
223736d75acb Import from CVS: tag r21-2-45
cvs
parents: 458
diff changeset
3891 if (i == lrecord_type_vector)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3892 gc_count_vector_total_size =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3893 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3894
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3895 sprintf (buf, "%s-storage", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3896 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3897 /* Okay, simple pluralization check for `symbol-value-varalias' */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3898 if (name[len-1] == 's')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3899 sprintf (buf, "%ses-freed", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3900 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3901 sprintf (buf, "%ss-freed", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3902 if (lcrecord_stats[i].instances_freed != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3903 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3904 if (name[len-1] == 's')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3905 sprintf (buf, "%ses-on-free-list", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3906 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3907 sprintf (buf, "%ss-on-free-list", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3908 if (lcrecord_stats[i].instances_on_free_list != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3909 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3910 pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3911 if (name[len-1] == 's')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3912 sprintf (buf, "%ses-used", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3913 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3914 sprintf (buf, "%ss-used", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3915 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3916 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3917 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3918
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3919 HACK_O_MATIC (extent, "extent-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3920 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3921 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
3922 HACK_O_MATIC (event, "event-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3923 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3924 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
3925 HACK_O_MATIC (marker, "marker-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3926 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3927 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
3928 #ifdef LISP_FLOAT_TYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3929 HACK_O_MATIC (float, "float-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3930 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3931 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
3932 #endif /* LISP_FLOAT_TYPE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3933 HACK_O_MATIC (string, "string-header-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3934 pl = gc_plist_hack ("long-strings-total-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3935 gc_count_string_total_size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3936 - gc_count_short_string_total_size, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3937 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3938 pl = gc_plist_hack ("short-strings-total-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3939 gc_count_short_string_total_size, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3940 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3941 pl = gc_plist_hack ("long-strings-used",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3942 gc_count_num_string_in_use
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3943 - gc_count_num_short_string_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3944 pl = gc_plist_hack ("short-strings-used",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3945 gc_count_num_short_string_in_use, 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 (compiled_function, "compiled-function-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3948 pl = gc_plist_hack ("compiled-functions-free",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3949 gc_count_num_compiled_function_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3950 pl = gc_plist_hack ("compiled-functions-used",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3951 gc_count_num_compiled_function_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3952
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3953 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
3954 pl = gc_plist_hack ("bit-vectors-total-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3955 gc_count_bit_vector_total_size, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3956 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
3957
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3958 HACK_O_MATIC (symbol, "symbol-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3959 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3960 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
3961
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3962 HACK_O_MATIC (cons, "cons-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3963 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3964 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
3965
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3966 /* The things we do for backwards-compatibility */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3967 return
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3968 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3969 make_int (gc_count_num_cons_freelist)),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3970 Fcons (make_int (gc_count_num_symbol_in_use),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3971 make_int (gc_count_num_symbol_freelist)),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3972 Fcons (make_int (gc_count_num_marker_in_use),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3973 make_int (gc_count_num_marker_freelist)),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3974 make_int (gc_count_string_total_size),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3975 make_int (gc_count_vector_total_size),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3976 pl);
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 #undef HACK_O_MATIC
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 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3981 Return the number of bytes consed since the last garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3982 \"Consed\" is a misnomer in that this actually counts allocation
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3983 of all different kinds of objects, not just conses.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3984
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3985 If this value exceeds `gc-cons-threshold', a garbage collection happens.
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 (consing_since_gc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3990 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3991
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3992 #if 0
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3993 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
3994 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
3995 This may be helpful in debugging XEmacs's memory usage.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3996 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
3997 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3998 ())
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3999 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4000 return make_int ((EMACS_INT) sbrk (0) / 1024);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4001 }
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4002 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4003
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4004 DEFUN ("memory-usage", Fmemory_usage, 0, 0, 0, /*
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4005 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
4006 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
4007 */
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4008 ())
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4009 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4010 return make_int (total_data_usage ());
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4011 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4012
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4013 /* 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
4014 static void
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4015 recompute_need_to_garbage_collect (void)
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4016 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4017 if (always_gc)
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4018 need_to_garbage_collect = 1;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4019 else
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4020 need_to_garbage_collect =
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4021 (consing_since_gc > gc_cons_threshold
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4022 #if 0 /* #### implement this better */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4023 &&
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4024 (100 * consing_since_gc) / total_data_usage () >=
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4025 gc_cons_percentage
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4026 #endif /* 0 */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4027 );
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4028 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4029
428
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 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4032 object_dead_p (Lisp_Object obj)
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 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4035 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4036 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4037 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4038 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4039 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4040 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4041 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4042
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4043 #ifdef MEMORY_USAGE_STATS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4044
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4045 /* Attempt to determine the actual amount of space that is used for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4046 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
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 It seems that the following holds:
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 1. When using the old allocator (malloc.c):
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4051
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4052 -- blocks are always allocated in chunks of powers of two. For
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4053 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
4054 defined, 20 bytes if it is defined. In other words, a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4055 one-byte allocation needs 8 bytes of overhead for a total of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4056 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
4057 it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4058
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4059 2. When using the new allocator (gmalloc.c):
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4060
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4061 -- blocks are always allocated in chunks of powers of two up
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4062 to 4096 bytes. Larger blocks are allocated in chunks of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4063 an integral multiple of 4096 bytes. The minimum block
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4064 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4065 is defined. There is no per-block overhead, but there
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4066 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4067 allocated.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4068
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4069 3. When using the system malloc, anything goes, but they are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4070 generally slower and more space-efficient than the GNU
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4071 allocators. One possibly reasonable assumption to make
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4072 for want of better data is that sizeof (void *), or maybe
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4073 2 * sizeof (void *), is required as overhead and that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4074 blocks are allocated in the minimum required size except
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4075 that some minimum block size is imposed (e.g. 16 bytes). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4076
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4077 Bytecount
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4078 malloced_storage_size (void *ptr, Bytecount claimed_size,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4079 struct overhead_stats *stats)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4080 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4081 Bytecount orig_claimed_size = claimed_size;
428
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 #ifdef GNU_MALLOC
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4084 if (claimed_size < (Bytecount) (2 * sizeof (void *)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4085 claimed_size = 2 * sizeof (void *);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4086 # ifdef SUNOS_LOCALTIME_BUG
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4087 if (claimed_size < 16)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4088 claimed_size = 16;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4089 # endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4090 if (claimed_size < 4096)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4091 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4092 int log = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4093
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4094 /* 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
4095 the block size needed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4096 claimed_size--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4097 /* It's big, it's heavy, it's wood! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4098 while ((claimed_size /= 2) != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4099 ++log;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4100 claimed_size = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4101 /* It's better than bad, it's good! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4102 while (log > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4103 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4104 claimed_size *= 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4105 log--;
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 /* We have to come up with some average about the amount of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4108 blocks used. */
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4109 if ((Bytecount) (rand () & 4095) < claimed_size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4110 claimed_size += 3 * sizeof (void *);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4111 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4112 else
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 claimed_size += 4095;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4115 claimed_size &= ~4095;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4116 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4117 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4118
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4119 #elif defined (SYSTEM_MALLOC)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4120
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4121 if (claimed_size < 16)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4122 claimed_size = 16;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4123 claimed_size += 2 * sizeof (void *);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4124
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4125 #else /* old GNU allocator */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4126
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4127 # ifdef rcheck /* #### may not be defined here */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4128 claimed_size += 20;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4129 # else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4130 claimed_size += 8;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4131 # endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4132 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4133 int log = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4134
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4135 /* 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
4136 the block size needed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4137 claimed_size--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4138 /* It's big, it's heavy, it's wood! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4139 while ((claimed_size /= 2) != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4140 ++log;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4141 claimed_size = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4142 /* It's better than bad, it's good! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4143 while (log > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4144 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4145 claimed_size *= 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4146 log--;
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4149
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4150 #endif /* old GNU allocator */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4151
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4152 if (stats)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4153 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4154 stats->was_requested += orig_claimed_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4155 stats->malloc_overhead += claimed_size - orig_claimed_size;
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 return claimed_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4158 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4159
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4160 Bytecount
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4161 fixed_type_block_overhead (Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4162 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4163 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
4164 Bytecount overhead = 0;
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4165 Bytecount storage_size = malloced_storage_size (0, per_block, 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4166 while (size >= per_block)
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 size -= per_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4169 overhead += sizeof (void *) + per_block - storage_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4170 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4171 if (rand () % per_block < size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4172 overhead += sizeof (void *) + per_block - storage_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4173 return overhead;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4174 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4175
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4176 #endif /* MEMORY_USAGE_STATS */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4177
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4178
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4179 /* Initialization */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4180 static void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4181 common_init_alloc_once_early (void)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4182 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4183 #ifndef Qzero
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4184 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
4185 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4186
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4187 #ifndef Qnull_pointer
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4188 /* 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
4189 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
4190 Qnull_pointer = wrap_pointer_1 (0);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4191 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4192
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4193 gc_generation_number[0] = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4194 breathing_space = 0;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4195 all_bit_vectors = Qzero;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4196 Vgc_message = Qzero;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4197 all_lcrecords = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4198 ignore_malloc_warnings = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4199 #ifdef DOUG_LEA_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4200 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4201 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4202 #if 0 /* Moved to emacs.c */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4203 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4204 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4205 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4206 init_string_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4207 init_string_chars_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4208 init_cons_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4209 init_symbol_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4210 init_compiled_function_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4211 #ifdef LISP_FLOAT_TYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4212 init_float_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4213 #endif /* LISP_FLOAT_TYPE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4214 init_marker_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4215 init_extent_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4216 init_event_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4217
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4218 ignore_malloc_warnings = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4219
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4220 if (staticpros_nodump)
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4221 Dynarr_free (staticpros_nodump);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4222 staticpros_nodump = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4223 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
4224 #ifdef DEBUG_XEMACS
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4225 if (staticpro_nodump_names)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4226 Dynarr_free (staticpro_nodump_names);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4227 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
4228 Dynarr_resize (staticpro_nodump_names, 100); /* ditto */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4229 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4230
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4231 consing_since_gc = 0;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4232 need_to_garbage_collect = always_gc;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4233
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4234 #if 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4235 gc_cons_threshold = 500000; /* XEmacs change */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4236 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4237 gc_cons_threshold = 15000; /* debugging */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4238 #endif
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4239 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
4240 memory usage on Windows; not verified on other
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4241 systems */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4242 lrecord_uid_counter = 259;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4243 debug_string_purity = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4244 gcprolist = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4245
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4246 gc_currently_forbidden = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4247 gc_hooks_inhibited = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4248
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
4249 #ifdef ERROR_CHECK_TYPES
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4250 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
4251 666;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4252 ERROR_ME_NOT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4253 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4254 ERROR_ME_WARN.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4255 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4256 3333632;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4257 ERROR_ME_DEBUG_WARN.
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4258 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
4259 8675309;
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
4260 #endif /* ERROR_CHECK_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4261 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4262
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4263 static void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4264 init_lcrecord_lists (void)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4265 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4266 int i;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4267
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4268 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
4269 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4270 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
4271 staticpro_nodump (&all_lcrecord_lists[i]);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4272 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4273 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4274
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4275 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4276 reinit_alloc_once_early (void)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4277 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4278 common_init_alloc_once_early ();
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4279 init_lcrecord_lists ();
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4280 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4281
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4282 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4283 init_alloc_once_early (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4284 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4285 common_init_alloc_once_early ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4286
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4287 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4288 int i;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4289 for (i = 0; i < countof (lrecord_implementations_table); i++)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4290 lrecord_implementations_table[i] = 0;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4291 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4292
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4293 INIT_LRECORD_IMPLEMENTATION (cons);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4294 INIT_LRECORD_IMPLEMENTATION (vector);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4295 INIT_LRECORD_IMPLEMENTATION (string);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4296 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4297
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4298 staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4299 Dynarr_resize (staticpros, 1410); /* merely a small optimization */
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4300 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
4301 #ifdef DEBUG_XEMACS
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4302 staticpro_names = Dynarr_new2 (char_ptr_dynarr, char *);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4303 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
4304 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
4305 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4306
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4307 init_lcrecord_lists ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4308 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4309
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4310 void
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4311 init_alloc_early (void)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4312 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4313 gcprolist = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4314 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4315
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4316 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4317 syms_of_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4318 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4319 DEFSYMBOL (Qpre_gc_hook);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4320 DEFSYMBOL (Qpost_gc_hook);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4321 DEFSYMBOL (Qgarbage_collecting);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4322
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4323 DEFSUBR (Fcons);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4324 DEFSUBR (Flist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4325 DEFSUBR (Fvector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4326 DEFSUBR (Fbit_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4327 DEFSUBR (Fmake_byte_code);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4328 DEFSUBR (Fmake_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4329 DEFSUBR (Fmake_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4330 DEFSUBR (Fmake_bit_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4331 DEFSUBR (Fmake_string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4332 DEFSUBR (Fstring);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4333 DEFSUBR (Fmake_symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4334 DEFSUBR (Fmake_marker);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4335 DEFSUBR (Fpurecopy);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4336 DEFSUBR (Fgarbage_collect);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4337 #if 0
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4338 DEFSUBR (Fmemory_limit);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4339 #endif
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4340 DEFSUBR (Fmemory_usage);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4341 DEFSUBR (Fconsing_since_gc);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4344 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4345 vars_of_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4346 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4347 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4348 *Number of bytes of consing between garbage collections.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4349 \"Consing\" is a misnomer in that this actually counts allocation
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4350 of all different kinds of objects, not just conses.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4351 Garbage collection can happen automatically once this many bytes have been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4352 allocated since the last garbage collection. All data types count.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4353
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4354 Garbage collection happens automatically when `eval' or `funcall' are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4355 called. (Note that `funcall' is called implicitly as part of evaluation.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4356 By binding this temporarily to a large number, you can effectively
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4357 prevent garbage collection during a part of the program.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4358
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4359 See also `consing-since-gc'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4360 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4361
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4362 DEFVAR_INT ("gc-cons-percentage", &gc_cons_percentage /*
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4363 *Percentage of memory allocated between garbage collections.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4364
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4365 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
4366 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
4367 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
4368 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
4369 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
4370 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
4371 been allocated, regardless of current memory usage.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4372
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4373 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
4374 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
4375 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
4376 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
4377
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4378 See also `consing-since-gc'.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4379 */ );
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4380
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4381 #ifdef DEBUG_XEMACS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4382 DEFVAR_INT ("debug-allocation", &debug_allocation /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4383 If non-zero, print out information to stderr about all objects allocated.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4384 See also `debug-allocation-backtrace-length'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4385 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4386 debug_allocation = 0;
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 DEFVAR_INT ("debug-allocation-backtrace-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4389 &debug_allocation_backtrace_length /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4390 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4391 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4392 debug_allocation_backtrace_length = 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4393 #endif
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 DEFVAR_BOOL ("purify-flag", &purify_flag /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4396 Non-nil means loading Lisp code in order to dump an executable.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4397 This means that certain objects should be allocated in readonly space.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4398 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4399
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4400 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4401 Function or functions to be run just before each garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4402 Interrupts, garbage collection, and errors are inhibited while this hook
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4403 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
4404 consing, and do not interact with the user.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4405 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4406 Vpre_gc_hook = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4407
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4408 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4409 Function or functions to be run just after each garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4410 Interrupts, garbage collection, and errors are inhibited while this hook
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4411 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
4412 consing, and do not interact with the user.
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 Vpost_gc_hook = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4415
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4416 DEFVAR_LISP ("gc-message", &Vgc_message /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4417 String to print to indicate that a garbage collection is in progress.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4418 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
4419 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
4420 image instance) in the domain of the selected frame, the mouse pointer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4421 will change instead of this message being printed.
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 Vgc_message = build_string (gc_default_message);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4424
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4425 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4426 Pointer glyph used to indicate that a garbage collection is in progress.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4427 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
4428 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
4429 window, the pointer will be changed as specified during garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4430 Otherwise, a message will be printed in the echo area, as controlled
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4431 by `gc-message'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4432 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4433 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4434
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4435 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4436 complex_vars_of_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4437 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4438 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4439 }