annotate src/alloc.c @ 872:79c6ff3eef26

[xemacs-hg @ 2002-06-20 21:18:01 by ben] font changes etc.; some 21.4 changes mule/mule-msw-init-late.el: Specify charset->windows-registry conversion. mule/mule-x-init.el: Delete extra mule font additions here. Put them in faces.c. cl-macs.el: Document better. font-lock.el: Move Lisp function regexp to lisp-mode.el. lisp-mode.el: Various indentation fixes: Handle flet functions better. Handle argument lists in defuns and flets. Handle quoted lists, e.g. property lists -- don't indent like function calls. Distinguish between lambdas and other lists. lisp-mode.el: Handle this form. faces.el, font-menu.el, font.el, gtk-faces.el, msw-faces.el, msw-font-menu.el, x-faces.el, x-init.el: Major overhaul of face-handling code: -- Fix lots of bogus code in msw-faces.el, msw-font-menu.el, font-menu.el that was "truenaming" font specs -- i.e. in the process of frobbing a particular field in a general user-specified font spec with wildcarded fields, sticking in particular values for all the remaining wildcarded fields. This bug was rampant everywhere except in x-faces.el (the oldest and only correctly written code). This also means that we need to work with font names at all times and not font instances, because a font instance is essentially a truenamed font. -- Total rewrite of extremely junky code in msw-faces.el. Work with names as well as font instances, and return names; stop truenaming when canonicalizing and frobbing; fix handling of the combined style field, i.e. weight/slant (also fixed in font.el). -- Totally rewrite the frobbing functions in faces.el. This time, we frob all the instantiators rather than just computing a single instance value and working backwards. That way, e.g., `bold' will work for all charsets that have bold available, rather than only for whatever charset was part of the computed font instance (another example of the truename virus). Also fix up code to look at the fallbacks (all of them) when no global value present, so we don't need to put something in the global value. Intelligently handle a request to frob a buffer locale, rather than signalling an error. When frobbing instantiators, try hard to figure out what device type is associated with them, and frob each according to its own proper device type. Correctly handle inheritance vectors given as instantiators. Preserve existing tags when putting back frobbed instantiators. Extract out general specifier-frobbing code into specifier.el. Document everything cleanly. Do lots of other things better, etc. -- Don't duplicatively set a global specification for the default font -- it's already in the fallback and we no longer need a default global specification present. Delete various code in x-faces.el and msw-faces.el that duplicated the lists of fonts in faces.c. -- init-global-faces was not being called at all under MS Windows! Major bogosity. That caused device-specific values to get stuck into all the fonts, making it very hard to change them -- setting global specs caused nothing to happen. -- Correct weight names in font.el. -- Lots more font fixups in objects*.c. Printer.el: Warning fix. specifier.el: Add more args to map-specifier. Add various "heuristic" specifier functions to aid in creation of specifier-munging code such as in faces.el. subr.el: New functions. lwlib.c: Fix warning. config.inc.samp: Clean up, add args to control fastcall (not yet supported! the changes needed are in another ws of mine), profile support, vc6 support, union-type. xemacs.dsp, xemacs.mak: Semi-major overhaul. Fix bug where dump-id was always getting recomputed, forcing a redump even when nothing changed. Add support for fastcall. Support edit-and-continue (on by default) with vc6. Use incremental linking when doing a debug compilation. Add support for profiling. Consolidate the various debug flags. Partial support for "batch-compiling" -- compiling many files on a single invocation of the compiler. Doesn't seem to help that much for me, so it's not finished or enabled by default. Remove HAVE_MSW_C_DIRED, we always do. Correct some sloppy use of directories. s/cygwin32.h: Allow pdump to work under Cygwin (mmap is broken, so need to undefine HAVE_MMAP). s/win32-common.h, s/windowsnt.h: Support for fastcall. Add WIN32_ANY for identifying all Win32 variants (Cygwin, native, MinGW). Both of these are properly used in another ws. alloc.c, balloon-x.c, buffer.c, bytecode.c, callint.c, cm.c, cmdloop.c, cmds.c, console-gtk.c, console-gtk.h, console-msw.c, console-msw.h, console-stream.c, console-stream.h, console-tty.c, console-tty.h, console-x.c, console-x.h, console.c, console.h, device-gtk.c, device-msw.c, device-tty.c, device-x.c, device.c, device.h, devslots.h, dialog-gtk.c, dialog-msw.c, dialog-x.c, dialog.c, dired-msw.c, editfns.c, emacs.c, event-Xt.c, event-gtk.c, event-msw.c, event-stream.c, event-tty.c, event-unixoid.c, events.c, extents.c, extents.h, faces.c, fileio.c, fns.c, frame-gtk.c, frame-msw.c, frame-tty.c, frame-x.c, frame.c, frame.h, glyphs-eimage.c, glyphs-gtk.c, glyphs-msw.c, glyphs-widget.c, glyphs-x.c, glyphs.c, glyphs.h, gui-gtk.c, gui-msw.c, gui-x.c, gui.c, gutter.c, input-method-xlib.c, intl-encap-win32.c, intl-win32.c, keymap.c, lisp.h, macros.c, menubar-gtk.c, menubar-msw.c, menubar-x.c, menubar.c, menubar.h, minibuf.c, mule-charset.c, nt.c, objects-gtk.c, objects-gtk.h, objects-msw.c, objects-msw.h, objects-tty.c, objects-tty.h, objects-x.c, objects-x.h, objects.c, objects.h, postgresql.c, print.c, process.h, redisplay-gtk.c, redisplay-msw.c, redisplay-output.c, redisplay-tty.c, redisplay-x.c, redisplay.c, redisplay.h, scrollbar-gtk.c, scrollbar-msw.c, scrollbar-x.c, scrollbar.c, select-gtk.c, select-msw.c, select-x.c, select.c, signal.c, sound.c, specifier.c, symbols.c, syntax.c, sysdep.c, syssignal.h, syswindows.h, toolbar-common.c, toolbar-gtk.c, toolbar-msw.c, toolbar-x.c, toolbar.c, unicode.c, window.c, window.h: The following are the major changes made: (1) Separation of various header files into an external and an internal version, similar to the existing separation of process.h and procimpl.h. Eventually this should be done for all Lisp objects. The external version has the same name as currently; the internal adds -impl. The external file has XFOO() macros for objects, but the structure is opaque and defined only in the internal file. It's now reasonable to move all prototypes in lisp.h into the appropriate external file, and this should be done. Currently, separation has been done on extents.h, objects*.h, console.h, device.h, frame.h, and window.h. For c/d/f/w, the most basic properties are available in the external header file, with the macros resolving to functions. In the internal header file, the macros are redefined to directly access the structure. Also, the global MARK_FOO_CHANGED macros have been made into functions so that they can be accessed without needing to include lots of -impl headers -- they are used in almost exclusively in non-time-critical functions, and take up enough time that the function overhead will be negligible. Similarly, the function overhead from making the basic properties mentioned above into functions is negligible, and code that does heavy accessing of c/d/f/w structures inevitably ends up needing the internal header files, anyway. (2) More face changes. -- Major rewrite of objects-msw.c. Now handles wildcard specs properly, rather than "truenaming" (or even worse, signalling an error, which previously happened with some of the fallbacks if you tried to use them in make-font-instance!). -- Split charset matching of fonts into two stages -- one to find a font specifically designed for a particular charset (by examining its registry), the second to find a Unicode font that can support the charset. This needs to proceed as two complete, separate instantiations in order to work properly (otherwise many of the fonts in the HELLO page look wrong). This should also make it easy to support iso10646 (Unicode) fonts under X. -- All default values for fonts are now completely specified in the fallbacks. Stuff from mule-x-init.el has all been moved here, merged with the existing specs, and totally rethought so you get sensible results. (HELLO now looks much better!). -- Generalize the "default X/GTK device" stuff into a per-device-type "default device". -- Add mswindows-{set-}charset-registry. In time, charset<->code-page conversion functions will be removed. -- Wrap protective code around calls to compute device specifier tags, and do this computation before calling the face initialization code because the latter may need these tags to be correctly updated. (3) Other changes. EmacsFrame.c, glyphs-msw.c, eval.c, gui-x.c, intl-encap-win32.c, search.c, signal.c, toolbar-msw.c, unicode.c: Warning fixes. config.h.in: #undefs meant to be frobbed by configure *MUST* go inside of #ifndef WIN32_NO_CONFIGURE, and everything else *MUST* go outside! eval.c: Let detailed backtraces be detailed. specifier.c: Don't override user's print-string-length/print-length settings. glyphs.c: New function image-instance-instantiator. config.h.in, sysdep.c: Changes for fastcall. sysdep.c, nt.c: Fix up a previous botched patch that tried to add support for both EEXIST and EACCES. IF THE BOTCHED PATCH WENT INTO 21.4, THIS FIXUP NEEDS TO GO IN, TOO. search.c: Fix *evil* crash due to incorrect synching of syntax-cache code with 21.1. THIS SHOULD GO INTO 21.4.
author ben
date Thu, 20 Jun 2002 21:19:10 +0000
parents 804517e16990
children ccc3177ef10b
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"
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
52 #include "extents-impl.h"
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
53 #include "frame-impl.h"
428
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"
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
56 #include "process.h"
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
57 #include "redisplay.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58 #include "specifier.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
59 #include "sysfile.h"
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
60 #include "sysdep.h"
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61 #include "window.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62 #include "console-stream.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
64 #ifdef DOUG_LEA_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65 #include <malloc.h>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
66 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
67
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
68 #ifdef PDUMP
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
69 #include "dumper.h"
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
72 EXFUN (Fgarbage_collect, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
73
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
74 static void recompute_need_to_garbage_collect (void);
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
75
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
76 #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
77 #if defined(DEBUG_XEMACS) && defined(MULE)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
78 #define VERIFY_STRING_CHARS_INTEGRITY
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 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
81
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
82 /* Define this to use malloc/free with no freelist for all datatypes,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
83 the hope being that some debugging tools may help detect
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
84 freed memory references */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
85 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86 #include <dmalloc.h>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 #define ALLOC_NO_POOLS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
88 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90 #ifdef DEBUG_XEMACS
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
91 static Fixnum debug_allocation;
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
92 static Fixnum debug_allocation_backtrace_length;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
93 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
95 /* 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
96 static EMACS_INT consing_since_gc;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
97 int need_to_garbage_collect;
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
98 int need_to_check_c_alloca;
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
99 int funcall_allocation_flag;
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
100 Bytecount __temp_alloca_size__;
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
101 Bytecount funcall_alloca_count;
814
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 /* 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
104 Ffuncall() faster */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
105 #define INCREMENT_CONS_COUNTER_1(size) \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
106 do \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
107 { \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
108 consing_since_gc += (size); \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
109 recompute_need_to_garbage_collect (); \
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
110 } while (0)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
111
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
112 #define debug_allocation_backtrace() \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
113 do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
114 if (debug_allocation_backtrace_length > 0) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
115 debug_short_backtrace (debug_allocation_backtrace_length); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
117
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
118 #ifdef DEBUG_XEMACS
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
119 #define INCREMENT_CONS_COUNTER(foosize, type) \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
120 do { \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
121 if (debug_allocation) \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
122 { \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
123 stderr_out ("allocating %s (size %ld)\n", type, \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
124 (long) foosize); \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
125 debug_allocation_backtrace (); \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
126 } \
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
127 INCREMENT_CONS_COUNTER_1 (foosize); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
128 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
129 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131 if (debug_allocation > 1) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
132 { \
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
133 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
134 (long) foosize); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
135 debug_allocation_backtrace (); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
136 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137 INCREMENT_CONS_COUNTER_1 (foosize); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
140 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
141 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
142 INCREMENT_CONS_COUNTER_1 (size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
144
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
145 #define DECREMENT_CONS_COUNTER(size) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146 consing_since_gc -= (size); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147 if (consing_since_gc < 0) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148 consing_since_gc = 0; \
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
149 recompute_need_to_garbage_collect (); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
152 /* 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
153 static EMACS_INT gc_cons_threshold;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
154
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
155 /* 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
156 static EMACS_INT gc_cons_percentage;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
157
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
158 #ifdef ERROR_CHECK_GC
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
159 int always_gc; /* Debugging hack; equivalent to
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
160 (setq gc-cons-thresold -1) */
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
161 #else
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
162 #define always_gc 0
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
163 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
165 /* Nonzero during gc */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
166 int gc_in_progress;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
167
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
168 /* Number of times GC has happened at this level or below.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
169 * Level 0 is most volatile, contrary to usual convention.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
170 * (Of course, there's only one level at present) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
171 EMACS_INT gc_generation_number[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
172
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
173 /* 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
174 static int lrecord_uid_counter;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
175
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176 /* Nonzero when calling certain hooks or doing other things where
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
177 a GC would be bad */
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
178 static int gc_currently_forbidden;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
180 /* Hooks. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
181 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
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 /* "Garbage collecting" */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
185 Lisp_Object Vgc_message;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
186 Lisp_Object Vgc_pointer_glyph;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
187 static const Char_ASCII gc_default_message[] = "Garbage collecting";
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
188 Lisp_Object Qgarbage_collecting;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
189
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
190 /* Non-zero means we're in the process of doing the dump */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191 int purify_flag;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
192
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
193 #ifdef ERROR_CHECK_TYPES
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
195 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
196
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
197 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
198
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
199 /* 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
200 data. #### Need better (system-dependent) ways. */
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
201 void *minimum_address_seen;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
202 void *maximum_address_seen;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
203
428
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 c_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)) && C_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 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
211 lisp_readonly (Lisp_Object obj)
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 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
214 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
215
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 /* Maximum amount of C stack to save when a GC happens. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
218
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
219 #ifndef MAX_SAVE_STACK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
220 #define MAX_SAVE_STACK 0 /* 16000 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
221 #endif
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 /* Non-zero means ignore malloc warnings. Set during initialization. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
224 int ignore_malloc_warnings;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
227 static void *breathing_space;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
228
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230 release_breathing_space (void)
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 if (breathing_space)
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 void *tmp = breathing_space;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
235 breathing_space = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
236 xfree (tmp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
237 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
238 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
239
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
240 /* malloc calls this if it finds we are near exhausting storage */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
241 void
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
242 malloc_warning (const char *str)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
243 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
244 if (ignore_malloc_warnings)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
246
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
247 warn_when_safe
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
248 (Qmemory, Qemergency,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
249 "%s\n"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
250 "Killing some buffers may delay running out of memory.\n"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
251 "However, certainly by the time you receive the 95%% warning,\n"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252 "you should clean up, kill this Emacs, and start a new one.",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253 str);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
255
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
256 /* Called if malloc returns zero */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
257 DOESNT_RETURN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
258 memory_full (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
259 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
260 /* Force a GC next time eval is called.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
261 It's better to loop garbage-collecting (we might reclaim enough
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
262 to win) than to loop beeping and barfing "Memory exhausted"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
263 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
264 consing_since_gc = gc_cons_threshold + 1;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
265 recompute_need_to_garbage_collect ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
266 release_breathing_space ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
267
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
268 /* Flush some histories which might conceivably contain garbalogical
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
269 inhibitors. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
270 if (!NILP (Fboundp (Qvalues)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
271 Fset (Qvalues, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
272 Vcommand_history = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
273
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 551
diff changeset
274 out_of_memory ("Memory exhausted", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
275 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
276
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
277 static void
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
278 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
279 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
280 if (!val)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
281 return;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
282 if ((char *) val + size > (char *) maximum_address_seen)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
283 maximum_address_seen = (char *) val + size;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
284 if (!minimum_address_seen)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
285 minimum_address_seen =
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
286 #if SIZEOF_VOID_P == 8
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
287 (void *) 0xFFFFFFFFFFFFFFFF;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
288 #else
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
289 (void *) 0xFFFFFFFF;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
290 #endif
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
291 if ((char *) val < (char *) minimum_address_seen)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
292 minimum_address_seen = (char *) val;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
293 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
294
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
295 /* like malloc and realloc but check for no memory left. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
296
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
297 #undef xmalloc
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
298 void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
299 xmalloc (Bytecount size)
428
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 void *val = malloc (size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
302 if (!val && (size != 0)) memory_full ();
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
303 set_alloc_mins_and_maxes (val, size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
304 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
305 }
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 #undef xcalloc
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
308 static void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
309 xcalloc (Elemcount nelem, Bytecount elsize)
428
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 void *val = calloc (nelem, elsize);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
312
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
313 if (!val && (nelem != 0)) memory_full ();
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
314 set_alloc_mins_and_maxes (val, nelem * elsize);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
315 return val;
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 void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
319 xmalloc_and_zero (Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
320 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
321 return xcalloc (size, sizeof (char));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
322 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
323
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
324 #undef xrealloc
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
325 void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
326 xrealloc (void *block, Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
327 {
551
e9a3f8b4de53 [xemacs-hg @ 2001-05-21 05:26:06 by martinb]
martinb
parents: 460
diff changeset
328 block = realloc (block, size);
e9a3f8b4de53 [xemacs-hg @ 2001-05-21 05:26:06 by martinb]
martinb
parents: 460
diff changeset
329
e9a3f8b4de53 [xemacs-hg @ 2001-05-21 05:26:06 by martinb]
martinb
parents: 460
diff changeset
330 if (!block && (size != 0)) memory_full ();
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
331 set_alloc_mins_and_maxes (block, size);
551
e9a3f8b4de53 [xemacs-hg @ 2001-05-21 05:26:06 by martinb]
martinb
parents: 460
diff changeset
332 return block;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
333 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
334
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
335 void
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 xfree_1 (void *block)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
338 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
339 xfree (void *block)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
340 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
341 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
342 #ifdef ERROR_CHECK_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
343 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
344 error until much later on for many system mallocs, such as
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
345 the one that comes with Solaris 2.3. FMH!! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
346 assert (block != (void *) 0xDEADBEEF);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
347 assert (block);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
348 #endif /* ERROR_CHECK_MALLOC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
349 free (block);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
350 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
351
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
352 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
353
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
354 static void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
355 deadbeef_memory (void *ptr, Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
356 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
357 UINT_32_BIT *ptr4 = (UINT_32_BIT *) ptr;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
358 Bytecount beefs = size >> 2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
359
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
360 /* In practice, size will always be a multiple of four. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
361 while (beefs--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
362 (*ptr4++) = 0xDEADBEEF;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
365 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
366
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 #define deadbeef_memory(ptr, size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
369
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
370 #endif /* !ERROR_CHECK_GC */
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 #undef xstrdup
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373 char *
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
374 xstrdup (const char *str)
428
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 int len = strlen (str) + 1; /* for stupid terminating 0 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
377 void *val = xmalloc (len);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
378
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
379 if (val == 0) return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380 return (char *) memcpy (val, str, len);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
382
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383 #ifdef NEED_STRDUP
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
384 char *
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
385 strdup (const char *s)
428
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 return xstrdup (s);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
388 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
389 #endif /* NEED_STRDUP */
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
392 static void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
393 allocate_lisp_storage (Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
394 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
395 void *val = xmalloc (size);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
396 /* 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
397 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
398 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
399 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
400 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
401 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
402 get freed?) */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
403
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
404 /* 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
405 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
406 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
407 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
408 redisplay structures and allocated separately. */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
409 memset (val, 0, size);
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
410
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
411 if (need_to_check_c_alloca)
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
412 xemacs_c_alloca (0);
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
413
793
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[] = {
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
934 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car_) },
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
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);
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
963 XSETCAR (val, car);
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
964 XSETCDR (val, cdr);
428
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) \
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
1835 ALIGN_FOR_TYPE (((size) + 1 + sizeof (Lisp_String *)), Lisp_String *)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1836
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1837 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1838 #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
1839
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1840 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL)
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1841 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL))
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1842
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1843 struct string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1844 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1845 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1846 unsigned char chars[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1847 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1848
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1849 struct unused_string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1850 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1851 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1852 EMACS_INT fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1853 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1854
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1855 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1856 init_string_chars_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1857 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1858 first_string_chars_block = xnew (struct string_chars_block);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1859 first_string_chars_block->prev = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1860 first_string_chars_block->next = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1861 first_string_chars_block->pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1862 current_string_chars_block = first_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1863 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1864
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1865 static struct string_chars *
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1866 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
1867 Bytecount fullsize)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1868 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1869 struct string_chars *s_chars;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1870
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1871 if (fullsize <=
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1872 (countof (current_string_chars_block->string_chars)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1873 - current_string_chars_block->pos))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1874 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1875 /* This string can fit in the current string chars block */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1876 s_chars = (struct string_chars *)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1877 (current_string_chars_block->string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1878 + current_string_chars_block->pos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1879 current_string_chars_block->pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1880 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1881 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1882 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1883 /* Make a new current string chars block */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1884 struct string_chars_block *new_scb = xnew (struct string_chars_block);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1885
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1886 current_string_chars_block->next = new_scb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1887 new_scb->prev = current_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1888 new_scb->next = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1889 current_string_chars_block = new_scb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1890 new_scb->pos = fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1891 s_chars = (struct string_chars *)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1892 current_string_chars_block->string_chars;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1893 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1894
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1895 s_chars->string = XSTRING (string_it_goes_with);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1896
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1897 INCREMENT_CONS_COUNTER (fullsize, "string chars");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1898
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1899 return s_chars;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1900 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1901
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1902 #ifdef SLEDGEHAMMER_CHECK_ASCII_BEGIN
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1903 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1904 sledgehammer_check_ascii_begin (Lisp_Object str)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1905 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1906 Bytecount i;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1907
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1908 for (i = 0; i < XSTRING_LENGTH (str); i++)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1909 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
1910 if (!byte_ascii_p (string_byte (str, i)))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1911 break;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1912 }
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 assert (i == (Bytecount) XSTRING_ASCII_BEGIN (str) ||
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1915 (i > MAX_STRING_ASCII_BEGIN &&
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1916 (Bytecount) XSTRING_ASCII_BEGIN (str) ==
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1917 (Bytecount) MAX_STRING_ASCII_BEGIN));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1918 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1919 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1920
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1921 /* You do NOT want to be calling this! (And if you do, you must call
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
1922 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
1923 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
1924
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1925 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1926 make_uninit_string (Bytecount length)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1927 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1928 Lisp_String *s;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
1929 Bytecount fullsize = STRING_FULLSIZE (length);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1930
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1931 assert (length >= 0 && fullsize > 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1932
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1933 /* Allocate the string header */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1934 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1935 xzero (*s);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
1936 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
1937
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
1938 set_lispstringp_data (s, BIG_STRING_FULLSIZE_P (fullsize)
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
1939 ? xnew_array (Ibyte, length + 1)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1940 : allocate_string_chars_struct (wrap_string (s),
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1941 fullsize)->chars);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1942
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
1943 set_lispstringp_length (s, length);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1944 s->plist = Qnil;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1945 set_string_byte (wrap_string (s), length, 0);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1946
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1947 return wrap_string (s);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1948 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1949
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1950 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1951 static void verify_string_chars_integrity (void);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1952 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1953
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1954 /* Resize the string S so that DELTA bytes can be inserted starting
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1955 at POS. If DELTA < 0, it means deletion starting at POS. If
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1956 POS < 0, resize the string but don't copy any characters. Use
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1957 this if you're planning on completely overwriting the string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1958 */
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 void
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1961 resize_string (Lisp_Object s, Bytecount pos, Bytecount delta)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1962 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1963 Bytecount oldfullsize, newfullsize;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1964 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1965 verify_string_chars_integrity ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1966 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1967
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
1968 #ifdef ERROR_CHECK_TEXT
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1969 if (pos >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1970 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1971 assert (pos <= XSTRING_LENGTH (s));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1972 if (delta < 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1973 assert (pos + (-delta) <= XSTRING_LENGTH (s));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1974 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1975 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1976 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1977 if (delta < 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1978 assert ((-delta) <= XSTRING_LENGTH (s));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1979 }
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
1980 #endif /* ERROR_CHECK_TEXT */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1981
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1982 if (delta == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1983 /* simplest case: no size change. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1984 return;
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1985
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1986 if (pos >= 0 && delta < 0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1987 /* If DELTA < 0, the functions below will delete the characters
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1988 before POS. We want to delete characters *after* POS, however,
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1989 so convert this to the appropriate form. */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1990 pos += -delta;
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1991
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1992 oldfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s));
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
1993 newfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s) + delta);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1994
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1995 if (BIG_STRING_FULLSIZE_P (oldfullsize))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1996 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1997 if (BIG_STRING_FULLSIZE_P (newfullsize))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1998 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1999 /* Both strings are big. We can just realloc().
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2000 But careful! If the string is shrinking, we have to
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2001 memmove() _before_ realloc(), and if growing, we have to
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2002 memmove() _after_ realloc() - otherwise the access is
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2003 illegal, and we might crash. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2004 Bytecount len = XSTRING_LENGTH (s) + 1 - pos;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2005
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2006 if (delta < 0 && pos >= 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2007 memmove (XSTRING_DATA (s) + pos + delta,
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2008 XSTRING_DATA (s) + pos, len);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2009 XSET_STRING_DATA
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2010 (s, (Ibyte *) xrealloc (XSTRING_DATA (s),
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2011 XSTRING_LENGTH (s) + delta + 1));
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2012 if (delta > 0 && pos >= 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2013 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
2014 len);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2015 }
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2016 else /* String has been demoted from BIG_STRING. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2017 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2018 Ibyte *new_data =
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2019 allocate_string_chars_struct (s, newfullsize)->chars;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2020 Ibyte *old_data = XSTRING_DATA (s);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2021
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2022 if (pos >= 0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2023 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2024 memcpy (new_data, old_data, pos);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2025 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
2026 XSTRING_LENGTH (s) + 1 - pos);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2027 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2028 XSET_STRING_DATA (s, new_data);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2029 xfree (old_data);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2030 }
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 else /* old string is small */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2033 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2034 if (oldfullsize == newfullsize)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2035 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2036 /* special case; size change but the necessary
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2037 allocation size won't change (up or down; code
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2038 somewhere depends on there not being any unused
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2039 allocation space, modulo any alignment
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2040 constraints). */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2041 if (pos >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2042 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2043 Ibyte *addroff = pos + XSTRING_DATA (s);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2044
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2045 memmove (addroff + delta, addroff,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2046 /* +1 due to zero-termination. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2047 XSTRING_LENGTH (s) + 1 - pos);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2048 }
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 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2051 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2052 Ibyte *old_data = XSTRING_DATA (s);
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2053 Ibyte *new_data =
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2054 BIG_STRING_FULLSIZE_P (newfullsize)
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2055 ? xnew_array (Ibyte, XSTRING_LENGTH (s) + delta + 1)
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2056 : allocate_string_chars_struct (s, newfullsize)->chars;
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2057
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2058 if (pos >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2059 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2060 memcpy (new_data, old_data, pos);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2061 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
2062 XSTRING_LENGTH (s) + 1 - pos);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2063 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2064 XSET_STRING_DATA (s, new_data);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2065
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 /* We need to mark this chunk of the string_chars_block
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2068 as unused so that compact_string_chars() doesn't
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2069 freak. */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2070 struct string_chars *old_s_chars = (struct string_chars *)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2071 ((char *) old_data - offsetof (struct string_chars, chars));
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2072 /* Sanity check to make sure we aren't hosed by strange
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2073 alignment/padding. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2074 assert (old_s_chars->string == XSTRING (s));
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2075 MARK_STRING_CHARS_AS_FREE (old_s_chars);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2076 ((struct unused_string_chars *) old_s_chars)->fullsize =
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2077 oldfullsize;
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2078 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2079 }
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2080 }
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2081
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2082 XSET_STRING_LENGTH (s, XSTRING_LENGTH (s) + delta);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2083 /* If pos < 0, the string won't be zero-terminated.
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2084 Terminate now just to make sure. */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2085 XSTRING_DATA (s)[XSTRING_LENGTH (s)] = '\0';
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2086
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2087 if (pos >= 0)
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2088 /* 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
2089 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
2090 adjust_extents() is exclusive of the starting position
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2091 passed to it. */
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2092 adjust_extents (s, pos - 1, XSTRING_LENGTH (s), delta);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2093
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2094 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2095 verify_string_chars_integrity ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2096 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2097 }
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 #ifdef MULE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2100
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2101 /* 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
2102 CHECK_LISP_WRITEABLE() before and bump_string_modiff() afterwards. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2103 void
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2104 set_string_char (Lisp_Object s, Charcount i, Ichar c)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2105 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2106 Ibyte newstr[MAX_ICHAR_LEN];
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2107 Bytecount bytoff = string_index_char_to_byte (s, i);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2108 Bytecount oldlen = itext_ichar_len (XSTRING_DATA (s) + bytoff);
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2109 Bytecount newlen = set_itext_ichar (newstr, c);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2110
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2111 sledgehammer_check_ascii_begin (s);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2112 if (oldlen != newlen)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2113 resize_string (s, bytoff, newlen - oldlen);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2114 /* 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
2115 memcpy (XSTRING_DATA (s) + bytoff, newstr, newlen);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2116 if (oldlen != newlen)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2117 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2118 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
2119 /* 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
2120 ascii_begin */
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2121 XSET_STRING_ASCII_BEGIN (s, i);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2122 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
2123 /* 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
2124 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2125 Bytecount j;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2126 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
2127 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2128 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
2129 break;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2130 }
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
2131 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
2132 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2133 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2134 sledgehammer_check_ascii_begin (s);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2135 }
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 #endif /* MULE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2138
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2139 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2140 Return a new string consisting of LENGTH copies of CHARACTER.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2141 LENGTH must be a non-negative integer.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2142 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2143 (length, character))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2144 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2145 CHECK_NATNUM (length);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2146 CHECK_CHAR_COERCE_INT (character);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2147 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2148 Ibyte init_str[MAX_ICHAR_LEN];
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2149 int len = set_itext_ichar (init_str, XCHAR (character));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2150 Lisp_Object val = make_uninit_string (len * XINT (length));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2151
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2152 if (len == 1)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2153 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2154 /* Optimize the single-byte case */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2155 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
2156 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
2157 len * XINT (length)));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2158 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2159 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2160 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
2161 EMACS_INT i;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2162 Ibyte *ptr = XSTRING_DATA (val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2163
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2164 for (i = XINT (length); i; i--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2165 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2166 Ibyte *init_ptr = init_str;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2167 switch (len)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2168 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2169 case 4: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2170 case 3: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2171 case 2: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2172 case 1: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2173 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2174 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2175 }
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2176 sledgehammer_check_ascii_begin (val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2177 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2178 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2179 }
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 DEFUN ("string", Fstring, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2182 Concatenate all the argument characters and make the result a string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2183 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2184 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2185 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2186 Ibyte *storage = alloca_array (Ibyte, nargs * MAX_ICHAR_LEN);
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2187 Ibyte *p = storage;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2188
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2189 for (; nargs; nargs--, args++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2190 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2191 Lisp_Object lisp_char = *args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2192 CHECK_CHAR_COERCE_INT (lisp_char);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2193 p += set_itext_ichar (p, XCHAR (lisp_char));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2194 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2195 return make_string (storage, p - storage);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2196 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2197
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2198 /* 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
2199
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2200 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2201 init_string_ascii_begin (Lisp_Object string)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2202 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2203 #ifdef MULE
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2204 int i;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2205 Bytecount length = XSTRING_LENGTH (string);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2206 Ibyte *contents = XSTRING_DATA (string);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2207
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2208 for (i = 0; i < length; i++)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2209 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2210 if (!byte_ascii_p (contents[i]))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2211 break;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2212 }
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2213 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
2214 #else
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2215 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
2216 MAX_STRING_ASCII_BEGIN));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2217 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2218 sledgehammer_check_ascii_begin (string);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2219 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2220
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2221 /* Take some raw memory, which MUST already be in internal format,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2222 and package it up into a Lisp string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2223 Lisp_Object
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2224 make_string (const Ibyte *contents, Bytecount length)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2225 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2226 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2227
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2228 /* 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
2229 #if defined (ERROR_CHECK_TEXT) && defined (MULE)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2230 bytecount_to_charcount (contents, length); /* Just for the assertions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2231 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2232
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2233 val = make_uninit_string (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2234 memcpy (XSTRING_DATA (val), contents, length);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2235 init_string_ascii_begin (val);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2236 sledgehammer_check_ascii_begin (val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2237 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2238 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2239
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2240 /* Take some raw memory, encoded in some external data format,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2241 and convert it into a Lisp string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2242 Lisp_Object
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2243 make_ext_string (const Extbyte *contents, EMACS_INT length,
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2244 Lisp_Object coding_system)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2245 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2246 Lisp_Object string;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2247 TO_INTERNAL_FORMAT (DATA, (contents, length),
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2248 LISP_STRING, string,
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2249 coding_system);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2250 return string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2251 }
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 Lisp_Object
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2254 build_intstring (const Ibyte *str)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2255 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2256 /* 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
2257 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
2258 }
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 Lisp_Object
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2261 build_string (const CIbyte *str)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2262 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2263 /* Some strlen's crash and burn if passed null. */
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2264 return make_string ((const Ibyte *) str, (str ? strlen (str) : 0));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2265 }
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 Lisp_Object
593
5fd7ba8b56e7 [xemacs-hg @ 2001-05-31 12:45:27 by ben]
ben
parents: 578
diff changeset
2268 build_ext_string (const Extbyte *str, Lisp_Object coding_system)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2269 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2270 /* Some strlen's crash and burn if passed null. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2271 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
2272 coding_system);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2273 }
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 Lisp_Object
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2276 build_msg_intstring (const Ibyte *str)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2277 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2278 return build_intstring (GETTEXT (str));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2279 }
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 Lisp_Object
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2282 build_msg_string (const CIbyte *str)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2283 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2284 return build_string (CGETTEXT (str));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2285 }
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 Lisp_Object
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2288 make_string_nocopy (const Ibyte *contents, Bytecount length)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2289 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2290 Lisp_String *s;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2291 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2292
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2293 /* 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
2294 #if defined (ERROR_CHECK_TEXT) && defined (MULE)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2295 bytecount_to_charcount (contents, length); /* Just for the assertions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2296 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2297
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2298 /* Allocate the string header */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2299 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2300 set_lheader_implementation (&s->u.lheader, &lrecord_string);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2301 SET_C_READONLY_RECORD_HEADER (&s->u.lheader);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2302 s->plist = Qnil;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
2303 set_lispstringp_data (s, (Ibyte *) contents);
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2304 set_lispstringp_length (s, length);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2305 val = wrap_string (s);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2306 init_string_ascii_begin (val);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2307 sledgehammer_check_ascii_begin (val);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2308
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2309 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2310 }
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 /* lcrecord lists */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2315 /************************************************************************/
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 /* Lcrecord lists are used to manage the allocation of particular
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2318 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2319 malloc() and garbage-collection junk) as much as possible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2320 It is similar to the Blocktype class.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2321
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2322 It works like this:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2323
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2324 1) Create an lcrecord-list object using make_lcrecord_list().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2325 This is often done at initialization. Remember to staticpro_nodump
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2326 this object! The arguments to make_lcrecord_list() are the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2327 same as would be passed to alloc_lcrecord().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2328 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2329 and pass the lcrecord-list earlier created.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2330 3) When done with the lcrecord, call free_managed_lcrecord().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2331 The standard freeing caveats apply: ** make sure there are no
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2332 pointers to the object anywhere! **
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2333 4) Calling free_managed_lcrecord() is just like kissing the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2334 lcrecord goodbye as if it were garbage-collected. This means:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2335 -- the contents of the freed lcrecord are undefined, and the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2336 contents of something produced by allocate_managed_lcrecord()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2337 are undefined, just like for alloc_lcrecord().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2338 -- the mark method for the lcrecord's type will *NEVER* be called
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2339 on freed lcrecords.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2340 -- the finalize method for the lcrecord's type will be called
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2341 at the time that free_managed_lcrecord() is called.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2342
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2343 */
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 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2346 mark_lcrecord_list (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2347 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2348 struct lcrecord_list *list = XLCRECORD_LIST (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2349 Lisp_Object chain = list->free;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2350
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2351 while (!NILP (chain))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2352 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2353 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2354 struct free_lcrecord_header *free_header =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2355 (struct free_lcrecord_header *) lheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2356
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2357 gc_checking_assert
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2358 (/* There should be no other pointers to the free list. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2359 ! MARKED_RECORD_HEADER_P (lheader)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2360 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2361 /* Only lcrecords should be here. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2362 ! LHEADER_IMPLEMENTATION (lheader)->basic_p
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2363 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2364 /* Only free lcrecords should be here. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2365 free_header->lcheader.free
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2366 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2367 /* The type of the lcrecord must be right. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2368 LHEADER_IMPLEMENTATION (lheader) == list->implementation
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2369 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2370 /* So must the size. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2371 (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2372 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2373 );
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2374
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2375 MARK_RECORD_HEADER (lheader);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2376 chain = free_header->chain;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2377 }
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 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2380 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2381
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2382 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2383 mark_lcrecord_list, internal_object_printer,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2384 0, 0, 0, 0, struct lcrecord_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2385 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2386 make_lcrecord_list (Elemcount size,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2387 const struct lrecord_implementation *implementation)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2388 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2389 struct lcrecord_list *p =
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2390 /* Avoid infinite recursion allocating this */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2391 alloc_unmanaged_lcrecord_type (struct lcrecord_list,
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2392 &lrecord_lcrecord_list);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2393
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2394 p->implementation = implementation;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2395 p->size = size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2396 p->free = Qnil;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2397 return wrap_lcrecord_list (p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2398 }
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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2401 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2402 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2403 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2404 if (!NILP (list->free))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2405 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2406 Lisp_Object val = list->free;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2407 struct free_lcrecord_header *free_header =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2408 (struct free_lcrecord_header *) XPNTR (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2409
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2410 #ifdef ERROR_CHECK_GC
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2411 struct lrecord_header *lheader = &free_header->lcheader.lheader;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2412
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2413 /* There should be no other pointers to the free list. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2414 assert (! MARKED_RECORD_HEADER_P (lheader));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2415 /* Only lcrecords should be here. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2416 assert (! LHEADER_IMPLEMENTATION (lheader)->basic_p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2417 /* Only free lcrecords should be here. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2418 assert (free_header->lcheader.free);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2419 /* The type of the lcrecord must be right. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2420 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2421 /* So must the size. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2422 assert (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2423 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2424 #endif /* ERROR_CHECK_GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2425
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2426 list->free = free_header->chain;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2427 free_header->lcheader.free = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2428 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2429 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2430 else
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
2431 return wrap_pointer_1 (alloc_lcrecord (list->size, list->implementation));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2432 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2433
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2434 /* "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
2435 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
2436 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
2437 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
2438 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
2439 used!
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2440
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2441 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
2442 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
2443
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2444 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2445 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2446 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2447 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2448 struct free_lcrecord_header *free_header =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2449 (struct free_lcrecord_header *) XPNTR (lcrecord);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2450 struct lrecord_header *lheader = &free_header->lcheader.lheader;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2451 const struct lrecord_implementation *implementation
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2452 = LHEADER_IMPLEMENTATION (lheader);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2453
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2454 /* 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
2455 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
2456 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
2457 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
2458 (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
2459 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
2460 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
2461 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
2462 problems. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2463 gc_checking_assert (!gc_in_progress);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2464
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2465 /* Make sure the size is correct. This will catch, for example,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2466 putting a window configuration on the wrong free list. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2467 gc_checking_assert ((implementation->size_in_bytes_method ?
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2468 implementation->size_in_bytes_method (lheader) :
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2469 implementation->static_size)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2470 == list->size);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2471 /* Make sure the object isn't already freed. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2472 gc_checking_assert (!free_header->lcheader.free);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2473
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2474 if (implementation->finalizer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2475 implementation->finalizer (lheader, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2476 free_header->chain = list->free;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2477 free_header->lcheader.free = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2478 list->free = lcrecord;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2479 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2480
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2481 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
2482
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2483 void *
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2484 alloc_automanaged_lcrecord (Bytecount size,
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2485 const struct lrecord_implementation *imp)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2486 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2487 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
2488 all_lcrecord_lists[imp->lrecord_type_index] =
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2489 make_lcrecord_list (size, imp);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2490
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2491 return XPNTR (allocate_managed_lcrecord
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2492 (all_lcrecord_lists[imp->lrecord_type_index]));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2493 }
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 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2496 free_lcrecord (Lisp_Object rec)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2497 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2498 int type = XRECORD_LHEADER (rec)->type;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2499
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2500 assert (!EQ (all_lcrecord_lists[type], Qzero));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2501
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2502 free_managed_lcrecord (all_lcrecord_lists[type], rec);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2503 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2504
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2505
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2506 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2507 Kept for compatibility, returns its argument.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2508 Old:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2509 Make a copy of OBJECT in pure storage.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2510 Recursively copies contents of vectors and cons cells.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2511 Does not copy symbols.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2512 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2513 (object))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2514 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2515 return object;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2516 }
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 /* Garbage Collection */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2521 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2522
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2523 /* 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
2524 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
2525 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
2526 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
2527 int lrecord_type_count = lrecord_type_last_built_in_type;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2528 /* Object marker functions are in the lrecord_implementation structure.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2529 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
2530 This hack speeds up (garbage-collect) by about 5%. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2531 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2532
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2533 struct gcpro *gcprolist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2534
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2535 /* 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
2536 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
2537 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
2538 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
2539 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
2540 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
2541 "root pointer"; this happens in the call to staticpro(). */
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2542 static const struct lrecord_description staticpro_description_1[] = {
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2543 { XD_END }
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2544 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2545
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2546 static const struct struct_description staticpro_description = {
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2547 sizeof (Lisp_Object *),
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2548 staticpro_description_1
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2549 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2550
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2551 static const struct lrecord_description staticpros_description_1[] = {
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2552 XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description),
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2553 { XD_END }
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2554 };
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 static const struct struct_description staticpros_description = {
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2557 sizeof (Lisp_Object_ptr_dynarr),
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2558 staticpros_description_1
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2559 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2560
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2561 #ifdef DEBUG_XEMACS
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2562
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2563 static const struct lrecord_description staticpro_one_name_description_1[] = {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2564 { XD_C_STRING, 0 },
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2565 { XD_END }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2566 };
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2567
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2568 static const struct struct_description staticpro_one_name_description = {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2569 sizeof (char *),
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2570 staticpro_one_name_description_1
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2571 };
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2572
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2573 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
2574 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
2575 { XD_END }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2576 };
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 static const struct struct_description staticpro_names_description = {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2579 sizeof (char_ptr_dynarr),
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2580 staticpro_names_description_1
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2581 };
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 /* 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
2584
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2585 Lisp_Object_ptr_dynarr *staticpros;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2586 char_ptr_dynarr *staticpro_names;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2587
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2588 /* 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
2589 garbage collection, and for dumping. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2590 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2591 staticpro_1 (Lisp_Object *varaddress, char *varname)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2592 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2593 Dynarr_add (staticpros, varaddress);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2594 Dynarr_add (staticpro_names, varname);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2595 dump_add_root_object (varaddress);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2596 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2597
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 Lisp_Object_ptr_dynarr *staticpros_nodump;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2600 char_ptr_dynarr *staticpro_nodump_names;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2601
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2602 /* 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
2603 garbage collection, but not for dumping. (See below.) */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2604 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2605 staticpro_nodump_1 (Lisp_Object *varaddress, char *varname)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2606 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2607 Dynarr_add (staticpros_nodump, varaddress);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2608 Dynarr_add (staticpro_nodump_names, varname);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2609 }
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 #else /* not DEBUG_XEMACS */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2612
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2613 Lisp_Object_ptr_dynarr *staticpros;
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2614
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2615 /* 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
2616 garbage collection, and for dumping. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2617 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2618 staticpro (Lisp_Object *varaddress)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2619 {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2620 Dynarr_add (staticpros, varaddress);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2621 dump_add_root_object (varaddress);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2622 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2623
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2624
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2625 Lisp_Object_ptr_dynarr *staticpros_nodump;
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2626
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2627 /* 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
2628 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
2629 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
2630 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
2631 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
2632 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
2633 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
2634 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
2635 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
2636 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
2637 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
2638 reloaded at a different address.)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2639
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2640 #### 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
2641 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
2642 loads the data in. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2643
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2644 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2645 staticpro_nodump (Lisp_Object *varaddress)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2646 {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2647 Dynarr_add (staticpros_nodump, varaddress);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2648 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2649
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2650 #endif /* not DEBUG_XEMACS */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2651
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2652 #ifdef ERROR_CHECK_GC
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2653 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2654 struct lrecord_header * GCLI_lh = (lheader); \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2655 assert (GCLI_lh != 0); \
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
2656 assert (GCLI_lh->type < (unsigned int) lrecord_type_count); \
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2657 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2658 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2659 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2660 } while (0)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2661 #else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2662 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2663 #endif
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2664
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2665
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2666 /* 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
2667 seen yet, recursively mark all the references contained in it. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2668
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2669 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2670 mark_object (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2671 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2672 tail_recurse:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2673
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2674 /* Checks we used to perform */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2675 /* if (EQ (obj, Qnull_pointer)) return; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2676 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2677 /* if (PURIFIED (XPNTR (obj))) return; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2678
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2679 if (XTYPE (obj) == Lisp_Type_Record)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2680 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2681 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2682
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2683 GC_CHECK_LHEADER_INVARIANTS (lheader);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2684
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2685 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2686 ! ((struct lcrecord_header *) lheader)->free);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2687
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2688 /* All c_readonly objects have their mark bit set,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2689 so that we only need to check the mark bit here. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2690 if (! MARKED_RECORD_HEADER_P (lheader))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2691 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2692 MARK_RECORD_HEADER (lheader);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2693
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2694 if (RECORD_MARKER (lheader))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2695 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2696 obj = RECORD_MARKER (lheader) (obj);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2697 if (!NILP (obj)) goto tail_recurse;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2698 }
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 /* 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
2704 DO NOT mark the cars.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2705
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2706 Use only for internal lists! There should never be other pointers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2707 to the cons cells, because if so, the cars will remain unmarked
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2708 even when they maybe should be marked. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2709 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2710 mark_conses_in_list (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2711 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2712 Lisp_Object rest;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2713
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2714 for (rest = obj; CONSP (rest); rest = XCDR (rest))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2715 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2716 if (CONS_MARKED_P (XCONS (rest)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2717 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2718 MARK_CONS (XCONS (rest));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2719 }
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 mark_object (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2722 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2723
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 /* Find all structures not marked, and free them. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2726
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2727 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
2728 static int gc_count_bit_vector_storage;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2729 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
2730 static Bytecount gc_count_string_total_size;
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
2731 static Bytecount gc_count_short_string_total_size;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2732
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2733 /* static int gc_count_total_records_used, gc_count_records_total_size; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2734
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 /* stats on lcrecords in use - kinda kludgy */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2737
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2738 static struct
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2739 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2740 int instances_in_use;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2741 int bytes_in_use;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2742 int instances_freed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2743 int bytes_freed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2744 int instances_on_free_list;
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 665
diff changeset
2745 } lcrecord_stats [countof (lrecord_implementations_table)
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 665
diff changeset
2746 + MODULE_DEFINABLE_TYPE_COUNT];
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2747
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2748 static void
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2749 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2750 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
2751 int type_index = h->type;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2752
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2753 if (((struct lcrecord_header *) h)->free)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2754 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2755 gc_checking_assert (!free_p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2756 lcrecord_stats[type_index].instances_on_free_list++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2757 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2758 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2759 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2760 const struct lrecord_implementation *implementation =
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2761 LHEADER_IMPLEMENTATION (h);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2762
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2763 Bytecount sz = (implementation->size_in_bytes_method ?
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2764 implementation->size_in_bytes_method (h) :
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2765 implementation->static_size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2766 if (free_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2767 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2768 lcrecord_stats[type_index].instances_freed++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2769 lcrecord_stats[type_index].bytes_freed += sz;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2770 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2771 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2772 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2773 lcrecord_stats[type_index].instances_in_use++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2774 lcrecord_stats[type_index].bytes_in_use += sz;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2775 }
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 /* Free all unmarked records */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2781 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2782 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2783 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2784 struct lcrecord_header *header;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2785 int num_used = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2786 /* int total_size = 0; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2787
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2788 xzero (lcrecord_stats); /* Reset all statistics to 0. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2789
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2790 /* First go through and call all the finalize methods.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2791 Then go through and free the objects. There used to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2792 be only one loop here, with the call to the finalizer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2793 occurring directly before the xfree() below. That
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2794 is marginally faster but much less safe -- if the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2795 finalize method for an object needs to reference any
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2796 other objects contained within it (and many do),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2797 we could easily be screwed by having already freed that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2798 other object. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2799
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2800 for (header = *prev; header; header = header->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2801 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2802 struct lrecord_header *h = &(header->lheader);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2803
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2804 GC_CHECK_LHEADER_INVARIANTS (h);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2805
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2806 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2807 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2808 if (LHEADER_IMPLEMENTATION (h)->finalizer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2809 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2810 }
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 for (header = *prev; header; )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2814 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2815 struct lrecord_header *h = &(header->lheader);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2816 if (MARKED_RECORD_HEADER_P (h))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2817 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2818 if (! C_READONLY_RECORD_HEADER_P (h))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2819 UNMARK_RECORD_HEADER (h);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2820 num_used++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2821 /* total_size += n->implementation->size_in_bytes (h);*/
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2822 /* #### May modify header->next on a C_READONLY lcrecord */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2823 prev = &(header->next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2824 header = *prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2825 tick_lcrecord_stats (h, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2826 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2827 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2828 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2829 struct lcrecord_header *next = header->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2830 *prev = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2831 tick_lcrecord_stats (h, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2832 /* used to call finalizer right here. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2833 xfree (header);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2834 header = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2835 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2836 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2837 *used = num_used;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2838 /* *total = total_size; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2839 }
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 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2843 sweep_bit_vectors_1 (Lisp_Object *prev,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2844 int *used, int *total, int *storage)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2845 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2846 Lisp_Object bit_vector;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2847 int num_used = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2848 int total_size = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2849 int total_storage = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2850
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2851 /* BIT_VECTORP fails because the objects are marked, which changes
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2852 their implementation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2853 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2854 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2855 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2856 int len = v->size;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2857 if (MARKED_RECORD_P (bit_vector))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2858 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2859 if (! C_READONLY_RECORD_HEADER_P(&(v->lheader)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2860 UNMARK_RECORD_HEADER (&(v->lheader));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2861 total_size += len;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2862 total_storage +=
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2863 MALLOC_OVERHEAD +
456
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 454
diff changeset
2864 FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long,
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 454
diff changeset
2865 bits, BIT_VECTOR_LONG_STORAGE (len));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2866 num_used++;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2867 /* #### May modify next on a C_READONLY bitvector */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2868 prev = &(bit_vector_next (v));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2869 bit_vector = *prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2870 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2871 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2872 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2873 Lisp_Object next = bit_vector_next (v);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2874 *prev = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2875 xfree (v);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2876 bit_vector = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2877 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2878 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2879 *used = num_used;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2880 *total = total_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2881 *storage = total_storage;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2882 }
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 /* And the Lord said: Thou shalt use the `c-backslash-region' command
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2885 to make macros prettier. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2886
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2887 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2888
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2889 #define SWEEP_FIXED_TYPE_BLOCK_1(typename, obj_type, lheader) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2890 do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2891 struct typename##_block *SFTB_current; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2892 int SFTB_limit; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2893 int num_free = 0, num_used = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2894 \
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2895 for (SFTB_current = current_##typename##_block, \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2896 SFTB_limit = current_##typename##_block_index; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2897 SFTB_current; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2898 ) \
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 int SFTB_iii; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2901 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2902 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2903 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2904 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2905 \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2906 if (LRECORD_FREE_P (SFTB_victim)) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2907 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2908 num_free++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2909 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2910 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2911 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2912 num_used++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2913 } \
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2914 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2915 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2916 num_free++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2917 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2918 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2919 else \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2920 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2921 num_used++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2922 UNMARK_##typename (SFTB_victim); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2923 } \
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 SFTB_current = SFTB_current->prev; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2926 SFTB_limit = countof (current_##typename##_block->block); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2927 } \
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 gc_count_num_##typename##_in_use = num_used; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2930 gc_count_num_##typename##_freelist = num_free; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2931 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2932
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2933 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2934
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2935 #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
2936 do { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2937 struct typename##_block *SFTB_current; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2938 struct typename##_block **SFTB_prev; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2939 int SFTB_limit; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2940 int num_free = 0, num_used = 0; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2941 \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2942 typename##_free_list = 0; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2943 \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2944 for (SFTB_prev = &current_##typename##_block, \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2945 SFTB_current = current_##typename##_block, \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2946 SFTB_limit = current_##typename##_block_index; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2947 SFTB_current; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2948 ) \
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 int SFTB_iii; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2951 int SFTB_empty = 1; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2952 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
2953 \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2954 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
2955 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2956 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
2957 \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2958 if (LRECORD_FREE_P (SFTB_victim)) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2959 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2960 num_free++; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2961 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
2962 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2963 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
2964 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2965 SFTB_empty = 0; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2966 num_used++; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2967 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2968 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
2969 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2970 num_free++; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2971 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2972 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2973 else \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2974 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2975 SFTB_empty = 0; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2976 num_used++; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2977 UNMARK_##typename (SFTB_victim); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2978 } \
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 if (!SFTB_empty) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2981 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2982 SFTB_prev = &(SFTB_current->prev); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2983 SFTB_current = SFTB_current->prev; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2984 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2985 else if (SFTB_current == current_##typename##_block \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2986 && !SFTB_current->prev) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2987 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2988 /* No real point in freeing sole allocation block */ \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2989 break; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2990 } \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2991 else \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2992 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2993 struct typename##_block *SFTB_victim_block = SFTB_current; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2994 if (SFTB_victim_block == current_##typename##_block) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2995 current_##typename##_block_index \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2996 = countof (current_##typename##_block->block); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2997 SFTB_current = SFTB_current->prev; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2998 { \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
2999 *SFTB_prev = SFTB_current; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3000 xfree (SFTB_victim_block); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3001 /* 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
3002 typename##_free_list = SFTB_old_free_list; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3003 num_free -= SFTB_limit; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3004 } \
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 SFTB_limit = countof (current_##typename##_block->block); \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3007 } \
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 gc_count_num_##typename##_in_use = num_used; \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3010 gc_count_num_##typename##_freelist = num_free; \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3011 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3012
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3013 #endif /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3014
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3015 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3016 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
3017
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3018
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3019
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3020
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3021 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3022 sweep_conses (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3023 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3024 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3025 #define ADDITIONAL_FREE_cons(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3026
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3027 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3028 }
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 /* Explicitly free a cons cell. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3031 void
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3032 free_cons (Lisp_Object cons)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3033 {
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3034 Lisp_Cons *ptr = XCONS (cons);
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3035
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3036 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3037 /* 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
3038 always be four-byte aligned. If this cons cell has already been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3039 placed on the free list, however, its car will probably contain
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3040 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
3041 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
3042 check to make sure we're not freeing something already freed. */
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3043 if (POINTER_TYPE_P (XTYPE (cons_car (ptr))))
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3044 ASSERT_VALID_POINTER (XPNTR (cons_car (ptr)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3045 #endif /* ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3046
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3047 #ifndef ALLOC_NO_POOLS
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3048 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3049 #endif /* ALLOC_NO_POOLS */
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3052 /* explicitly free a list. You **must make sure** that you have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3053 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
3054 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
3055 are, you will lose. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3056
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3057 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3058 free_list (Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3059 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3060 Lisp_Object rest, next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3061
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3062 for (rest = list; !NILP (rest); rest = next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3063 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3064 next = XCDR (rest);
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3065 free_cons (rest);
428
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3069 /* explicitly free an alist. You **must make sure** that you have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3070 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
3071 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
3072 are, you will lose. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3073
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3074 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3075 free_alist (Lisp_Object alist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3076 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3077 Lisp_Object rest, next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3078
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3079 for (rest = alist; !NILP (rest); rest = next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3080 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3081 next = XCDR (rest);
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3082 free_cons (XCAR (rest));
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3083 free_cons (rest);
428
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3087 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3088 sweep_compiled_functions (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3089 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3090 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3091 #define ADDITIONAL_FREE_compiled_function(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3092
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3093 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3097 #ifdef LISP_FLOAT_TYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3098 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3099 sweep_floats (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3100 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3101 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3102 #define ADDITIONAL_FREE_float(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3103
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3104 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3105 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3106 #endif /* LISP_FLOAT_TYPE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3107
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3108 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3109 sweep_symbols (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3110 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3111 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3112 #define ADDITIONAL_FREE_symbol(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3113
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3114 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
428
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3117 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3118 sweep_extents (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3119 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3120 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3121 #define ADDITIONAL_FREE_extent(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3122
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3123 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3126 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3127 sweep_events (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3128 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3129 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3130 #define ADDITIONAL_FREE_event(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3131
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3132 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
428
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3135 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3136 sweep_markers (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3137 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3138 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3139 #define ADDITIONAL_FREE_marker(ptr) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3140 do { Lisp_Object tem; \
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3141 tem = wrap_marker (ptr); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3142 unchain_marker (tem); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3143 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3144
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3145 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3146 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3147
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3148 /* Explicitly free a marker. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3149 void
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3150 free_marker (Lisp_Marker *ptr)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3151 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3152 /* Perhaps this will catch freeing an already-freed marker. */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3153 gc_checking_assert (ptr->lheader.type == lrecord_type_marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3154
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3155 #ifndef ALLOC_NO_POOLS
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3156 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3157 #endif /* ALLOC_NO_POOLS */
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3161 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3162
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3163 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3164 verify_string_chars_integrity (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3165 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3166 struct string_chars_block *sb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3167
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3168 /* Scan each existing string block sequentially, string by string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3169 for (sb = first_string_chars_block; sb; sb = sb->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3170 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3171 int pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3172 /* POS is the index of the next string in the block. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3173 while (pos < sb->pos)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3174 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3175 struct string_chars *s_chars =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3176 (struct string_chars *) &(sb->string_chars[pos]);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3177 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3178 int size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3179 int fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3180
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3181 /* 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
3182 STRING pointer is NULL) then this is an unused chunk of
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3183 string storage. (See below.) */
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3184
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3185 if (STRING_CHARS_FREE_P (s_chars))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3186 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3187 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3188 pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3189 continue;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3192 string = s_chars->string;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3193 /* Must be 32-bit aligned. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3194 assert ((((int) string) & 3) == 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3195
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3196 size = string->size_;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3197 fullsize = STRING_FULLSIZE (size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3198
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3199 assert (!BIG_STRING_FULLSIZE_P (fullsize));
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3200 assert (string->data_ == s_chars->chars);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3201 pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3202 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3203 assert (pos == sb->pos);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3207 #endif /* MULE && ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3208
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3209 /* Compactify string chars, relocating the reference to each --
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3210 free any empty string_chars_block we see. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3211 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3212 compact_string_chars (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3213 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3214 struct string_chars_block *to_sb = first_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3215 int to_pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3216 struct string_chars_block *from_sb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3217
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3218 /* Scan each existing string block sequentially, string by string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3219 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
3220 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3221 int from_pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3222 /* FROM_POS is the index of the next string in the block. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3223 while (from_pos < from_sb->pos)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3224 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3225 struct string_chars *from_s_chars =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3226 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3227 struct string_chars *to_s_chars;
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3228 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3229 int size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3230 int fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3231
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3232 /* 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
3233 STRING pointer is NULL) then this is an unused chunk of
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3234 string storage. This happens under Mule when a string's
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3235 size changes in such a way that its fullsize changes.
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3236 (Strings can change size because a different-length
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3237 character can be substituted for another character.)
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3238 In this case, after the bogus string pointer is the
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3239 "fullsize" of this entry, i.e. how many bytes to skip. */
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3240
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3241 if (STRING_CHARS_FREE_P (from_s_chars))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3242 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3243 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3244 from_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3245 continue;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3248 string = from_s_chars->string;
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
3249 assert (!(LRECORD_FREE_P (string)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3250
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3251 size = string->size_;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3252 fullsize = STRING_FULLSIZE (size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3253
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3254 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3255
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3256 /* 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
3257 if (! MARKED_RECORD_HEADER_P (&(string->u.lheader)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3258 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3259 from_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3260 continue;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3263 /* 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
3264 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
3265 cannot advance past FROM_SB here since FROM_SB is large enough
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3266 to currently contain this string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3267 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3268 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3269 to_sb->pos = to_pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3270 to_sb = to_sb->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3271 to_pos = 0;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3274 /* Compute new address of this string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3275 and update TO_POS for the space being used. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3276 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3277
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3278 /* Copy the string_chars to the new place. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3279 if (from_s_chars != to_s_chars)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3280 memmove (to_s_chars, from_s_chars, fullsize);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3281
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3282 /* Relocate FROM_S_CHARS's reference */
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
3283 set_lispstringp_data (string, &(to_s_chars->chars[0]));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3284
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3285 from_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3286 to_pos += fullsize;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3290 /* Set current to the last string chars block still used and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3291 free any that follow. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3292 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3293 struct string_chars_block *victim;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3294
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3295 for (victim = to_sb->next; victim; )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3296 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3297 struct string_chars_block *next = victim->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3298 xfree (victim);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3299 victim = next;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3302 current_string_chars_block = to_sb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3303 current_string_chars_block->pos = to_pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3304 current_string_chars_block->next = 0;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3308 #if 1 /* Hack to debug missing purecopy's */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3309 static int debug_string_purity;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3310
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3311 static void
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3312 debug_string_purity_print (Lisp_Object p)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3313 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3314 Charcount i;
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
3315 Charcount s = string_char_length (p);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3316 stderr_out ("\"");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3317 for (i = 0; i < s; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3318 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
3319 Ichar ch = string_ichar (p, i);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3320 if (ch < 32 || ch >= 126)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3321 stderr_out ("\\%03o", ch);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3322 else if (ch == '\\' || ch == '\"')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3323 stderr_out ("\\%c", ch);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3324 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3325 stderr_out ("%c", ch);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3326 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3327 stderr_out ("\"\n");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3328 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3329 #endif /* 1 */
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3332 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3333 sweep_strings (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3334 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
3335 int num_small_used = 0;
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
3336 Bytecount num_small_bytes = 0, num_bytes = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3337 int debug = debug_string_purity;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3338
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3339 #define UNMARK_string(ptr) do { \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3340 Lisp_String *p = (ptr); \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3341 Bytecount size = p->size_; \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3342 UNMARK_RECORD_HEADER (&(p->u.lheader)); \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3343 num_bytes += size; \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3344 if (!BIG_STRING_SIZE_P (size)) \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3345 { \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3346 num_small_bytes += size; \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3347 num_small_used++; \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3348 } \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3349 if (debug) \
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3350 debug_string_purity_print (wrap_string (p)); \
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3351 } while (0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3352 #define ADDITIONAL_FREE_string(ptr) do { \
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3353 Bytecount size = ptr->size_; \
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3354 if (BIG_STRING_SIZE_P (size)) \
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
3355 xfree (ptr->data_); \
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3356 } while (0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3357
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3358 SWEEP_FIXED_TYPE_BLOCK_1 (string, Lisp_String, u.lheader);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3359
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3360 gc_count_num_short_string_in_use = num_small_used;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3361 gc_count_string_total_size = num_bytes;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3362 gc_count_short_string_total_size = num_small_bytes;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3366 /* I hate duplicating all this crap! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3367 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3368 marked_p (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3369 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3370 /* Checks we used to perform. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3371 /* if (EQ (obj, Qnull_pointer)) return 1; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3372 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3373 /* if (PURIFIED (XPNTR (obj))) return 1; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3374
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3375 if (XTYPE (obj) == Lisp_Type_Record)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3376 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3377 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3378
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3379 GC_CHECK_LHEADER_INVARIANTS (lheader);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3380
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3381 return MARKED_RECORD_HEADER_P (lheader);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3382 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3383 return 1;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3386 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3387 gc_sweep (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3388 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3389 /* Free all unmarked records. Do this at the very beginning,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3390 before anything else, so that the finalize methods can safely
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3391 examine items in the objects. sweep_lcrecords_1() makes
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3392 sure to call all the finalize methods *before* freeing anything,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3393 to complete the safety. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3394 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3395 int ignored;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3396 sweep_lcrecords_1 (&all_lcrecords, &ignored);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3399 compact_string_chars ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3400
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3401 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3402 macros) must be *extremely* careful to make sure they're not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3403 referencing freed objects. The only two existing finalize
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3404 methods (for strings and markers) pass muster -- the string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3405 finalizer doesn't look at anything but its own specially-
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3406 created block, and the marker finalizer only looks at live
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3407 buffers (which will never be freed) and at the markers before
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3408 and after it in the chain (which, by induction, will never be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3409 freed because if so, they would have already removed themselves
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3410 from the chain). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3411
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3412 /* Put all unmarked strings on free list, free'ing the string chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3413 of large unmarked strings */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3414 sweep_strings ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3415
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3416 /* Put all unmarked conses on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3417 sweep_conses ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3418
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3419 /* Free all unmarked bit vectors */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3420 sweep_bit_vectors_1 (&all_bit_vectors,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3421 &gc_count_num_bit_vector_used,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3422 &gc_count_bit_vector_total_size,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3423 &gc_count_bit_vector_storage);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3424
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3425 /* Free all unmarked compiled-function objects */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3426 sweep_compiled_functions ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3427
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3428 #ifdef LISP_FLOAT_TYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3429 /* Put all unmarked floats on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3430 sweep_floats ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3431 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3432
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3433 /* Put all unmarked symbols on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3434 sweep_symbols ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3435
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3436 /* Put all unmarked extents on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3437 sweep_extents ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3438
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3439 /* Put all unmarked markers on free list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3440 Dechain each one first from the buffer into which it points. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3441 sweep_markers ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3442
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3443 sweep_events ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3444
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3445 #ifdef PDUMP
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3446 pdump_objects_unmark ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3447 #endif
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3450 /* Clearing for disksave. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3451
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3452 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3453 disksave_object_finalization (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3454 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3455 /* It's important that certain information from the environment not get
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3456 dumped with the executable (pathnames, environment variables, etc.).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3457 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
3458 clear some known-to-be-garbage blocks of memory, so that leftover
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3459 results of old evaluation don't look like potential problems.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3460 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
3461 to turn those strings into garbage.
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3462 */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3463
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3464 /* Yeah, this list is pretty ad-hoc... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3465 Vprocess_environment = Qnil;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3466 env_initted = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3467 Vexec_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3468 Vdata_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3469 Vsite_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3470 Vdoc_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3471 Vconfigure_info_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3472 Vexec_path = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3473 Vload_path = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3474 /* Vdump_load_path = Qnil; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3475 /* Release hash tables for locate_file */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3476 Flocate_file_clear_hashing (Qt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3477 uncache_home_directory ();
776
79940b592197 [xemacs-hg @ 2002-03-15 07:43:14 by ben]
ben
parents: 771
diff changeset
3478 zero_out_command_line_status_vars ();
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
3479 clear_default_devices ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3480
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3481 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3482 defined(LOADHIST_BUILTIN))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3483 Vload_history = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3484 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3485 Vshell_file_name = Qnil;
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 garbage_collect_1 ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3488
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3489 /* Run the disksave finalization methods of all live objects. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3490 disksave_object_finalization_1 ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3491
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3492 /* Zero out the uninitialized (really, unused) part of the containers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3493 for the live strings. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3494 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3495 struct string_chars_block *scb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3496 for (scb = first_string_chars_block; scb; scb = scb->next)
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 int count = sizeof (scb->string_chars) - scb->pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3499
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3500 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3501 if (count != 0)
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3502 {
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3503 /* from the block's fill ptr to the end */
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3504 memset ((scb->string_chars + scb->pos), 0, count);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3505 }
428
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 }
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 /* There, that ought to be enough... */
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3512
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3513
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3514 int
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3515 begin_gc_forbidden (void)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3516 {
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3517 return internal_bind_int (&gc_currently_forbidden, 1);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3518 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3519
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3520 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3521 end_gc_forbidden (int count)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3522 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3523 unbind_to (count);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3524 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3525
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3526 /* 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
3527 static int gc_hooks_inhibited;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3528
611
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3529 struct post_gc_action
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3530 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3531 void (*fun) (void *);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3532 void *arg;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3533 };
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3534
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3535 typedef struct post_gc_action post_gc_action;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3536
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3537 typedef struct
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 Dynarr_declare (post_gc_action);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3540 } post_gc_action_dynarr;
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 static post_gc_action_dynarr *post_gc_actions;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3543
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3544 /* 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
3545 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
3546 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
3547 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
3548
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3549 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
3550 And NEVER signal an error.
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
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3553 void
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3554 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
3555 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3556 post_gc_action action;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3557
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3558 if (!post_gc_actions)
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3559 post_gc_actions = Dynarr_new (post_gc_action);
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 action.fun = fun;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3562 action.arg = 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 Dynarr_add (post_gc_actions, 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
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3567 static void
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3568 run_post_gc_actions (void)
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3569 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3570 int i;
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 if (post_gc_actions)
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 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
3575 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3576 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
3577 (action.fun) (action.arg);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3578 }
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3579
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3580 Dynarr_reset (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 }
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3583
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3584
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3585 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3586 garbage_collect_1 (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3587 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3588 #if MAX_SAVE_STACK > 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3589 char stack_top_variable;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3590 extern char *stack_bottom;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3591 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3592 struct frame *f;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3593 int speccount;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3594 int cursor_changed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3595 Lisp_Object pre_gc_cursor;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3596 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3597
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3598 if (gc_in_progress
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3599 || gc_currently_forbidden
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3600 || in_display
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3601 || preparing_for_armageddon)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3602 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3603
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3604 /* We used to call selected_frame() here.
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 The following functions cannot be called inside GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3607 so we move to after the above tests. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3608 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3609 Lisp_Object frame;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3610 Lisp_Object device = Fselected_device (Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3611 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3612 return;
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
3613 frame = Fselected_frame (device);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3614 if (NILP (frame))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 551
diff changeset
3615 invalid_state ("No frames exist on device", device);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3616 f = XFRAME (frame);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3617 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3618
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3619 pre_gc_cursor = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3620 cursor_changed = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3621
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3622 GCPRO1 (pre_gc_cursor);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3623
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3624 /* Very important to prevent GC during any of the following
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3625 stuff that might run Lisp code; otherwise, we'll likely
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3626 have infinite GC recursion. */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3627 speccount = begin_gc_forbidden ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3628
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3629 if (!gc_hooks_inhibited)
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3630 run_hook_trapping_problems
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3631 ("Error in pre-gc-hook", Qpre_gc_hook,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3632 INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3633
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3634 /* Now show the GC cursor/message. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3635 if (!noninteractive)
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 (FRAME_WIN_P (f))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3638 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3639 Lisp_Object frame = wrap_frame (f);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3640 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3641 FRAME_SELECTED_WINDOW (f),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3642 ERROR_ME_NOT, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3643 pre_gc_cursor = f->pointer;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3644 if (POINTER_IMAGE_INSTANCEP (cursor)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3645 /* don't change if we don't know how to change back. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3646 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3647 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3648 cursor_changed = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3649 Fset_frame_pointer (frame, cursor);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3650 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3651 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3652
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3653 /* Don't print messages to the stream device. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3654 if (!cursor_changed && !FRAME_STREAM_P (f))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3655 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3656 Lisp_Object args[2], whole_msg;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3657 args[0] = (STRINGP (Vgc_message) ? Vgc_message :
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3658 build_msg_string (gc_default_message));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3659 args[1] = build_string ("...");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3660 whole_msg = Fconcat (2, args);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
3661 echo_area_message (f, (Ibyte *) 0, whole_msg, 0, -1,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3662 Qgarbage_collecting);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3663 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3664 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3665
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3666 /***** Now we actually start the garbage collection. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3667
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3668 gc_in_progress = 1;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3669 inhibit_non_essential_printing_operations = 1;
428
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 gc_generation_number[0]++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3672
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3673 #if MAX_SAVE_STACK > 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3674
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3675 /* Save a copy of the contents of the stack, for debugging. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3676 if (!purify_flag)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3677 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3678 /* 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
3679 static char *stack_copy;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3680 static Bytecount stack_copy_size;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3681
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3682 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
3683 Bytecount stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3684 if (stack_size < MAX_SAVE_STACK)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3685 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3686 if (stack_copy_size < stack_size)
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 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3689 stack_copy_size = stack_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3690 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3691
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3692 memcpy (stack_copy,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3693 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3694 stack_size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3695 }
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 #endif /* MAX_SAVE_STACK > 0 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3698
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3699 /* Do some totally ad-hoc resource clearing. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3700 /* #### generalize this? */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3701 clear_event_resource ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3702 cleanup_specifiers ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3703
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3704 /* Mark all the special slots that serve as the roots of accessibility. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3705
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3706 { /* staticpro() */
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3707 Lisp_Object **p = Dynarr_begin (staticpros);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3708 Elemcount count;
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3709 for (count = Dynarr_length (staticpros); count; count--)
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3710 mark_object (**p++);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3711 }
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3712
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3713 { /* staticpro_nodump() */
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3714 Lisp_Object **p = Dynarr_begin (staticpros_nodump);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3715 Elemcount count;
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3716 for (count = Dynarr_length (staticpros_nodump); count; count--)
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3717 mark_object (**p++);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3718 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3719
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3720 { /* GCPRO() */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3721 struct gcpro *tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3722 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3723 for (tail = gcprolist; tail; tail = tail->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3724 for (i = 0; i < tail->nvars; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3725 mark_object (tail->var[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3726 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3727
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3728 { /* specbind() */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3729 struct specbinding *bind;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3730 for (bind = specpdl; bind != specpdl_ptr; bind++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3731 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3732 mark_object (bind->symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3733 mark_object (bind->old_value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3734 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3735 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3736
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 struct catchtag *catch;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3739 for (catch = catchlist; catch; catch = catch->next)
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 mark_object (catch->tag);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3742 mark_object (catch->val);
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3743 mark_object (catch->actual_tag);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3744 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3745 }
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 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3748 struct backtrace *backlist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3749 for (backlist = backtrace_list; backlist; backlist = backlist->next)
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 int nargs = backlist->nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3752 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3753
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3754 mark_object (*backlist->function);
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3755 if (nargs < 0 /* nargs == UNEVALLED || nargs == MANY */)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3756 mark_object (backlist->args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3757 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3758 for (i = 0; i < nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3759 mark_object (backlist->args[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3760 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3761 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3762
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3763 mark_profiling_info ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3764
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3765 /* OK, now do the after-mark stuff. This is for things that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3766 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
3767 There may be complex dependencies between such objects -- e.g.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3768 a weak hash table might be unmarked, but after processing a later
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3769 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
3770 iterate until nothing more gets marked. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3771
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3772 while (finish_marking_weak_hash_tables () > 0 ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3773 finish_marking_weak_lists () > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3774 ;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3775
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3776 /* And prune (this needs to be called after everything else has been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3777 marked and before we do any sweeping). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3778 /* #### this is somewhat ad-hoc and should probably be an object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3779 method */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3780 prune_weak_hash_tables ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3781 prune_weak_lists ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3782 prune_specifiers ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3783 prune_syntax_tables ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3784
858
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 853
diff changeset
3785 prune_weak_boxes ();
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 853
diff changeset
3786
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3787 gc_sweep ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3788
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3789 consing_since_gc = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3790 #ifndef DEBUG_XEMACS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3791 /* Allow you to set it really fucking low if you really want ... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3792 if (gc_cons_threshold < 10000)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3793 gc_cons_threshold = 10000;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3794 #endif
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
3795 recompute_need_to_garbage_collect ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3796
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3797 inhibit_non_essential_printing_operations = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3798 gc_in_progress = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3799
611
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3800 run_post_gc_actions ();
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3801
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3802 /******* End of garbage collection ********/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3803
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3804 run_hook_trapping_problems
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3805 ("Error in post-gc-hook", Qpost_gc_hook,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3806 INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3807
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3808 /* Now remove the GC cursor/message */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3809 if (!noninteractive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3810 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3811 if (cursor_changed)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3812 Fset_frame_pointer (wrap_frame (f), pre_gc_cursor);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3813 else if (!FRAME_STREAM_P (f))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3814 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3815 /* Show "...done" only if the echo area would otherwise be empty. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3816 if (NILP (clear_echo_area (selected_frame (),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3817 Qgarbage_collecting, 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3818 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3819 Lisp_Object args[2], whole_msg;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3820 args[0] = (STRINGP (Vgc_message) ? Vgc_message :
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3821 build_msg_string (gc_default_message));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3822 args[1] = build_msg_string ("... done");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3823 whole_msg = Fconcat (2, args);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
3824 echo_area_message (selected_frame (), (Ibyte *) 0,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3825 whole_msg, 0, -1,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3826 Qgarbage_collecting);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3827 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3828 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3829 }
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 /* now stop inhibiting GC */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3832 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3833
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3834 if (!breathing_space)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3835 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3836 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3837 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3838
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3839 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3840 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3841 }
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 /* Debugging aids. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3844
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3845 static Lisp_Object
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
3846 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
3847 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3848 /* 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
3849 or portable numeric datatypes, or bit-vectors, or characters, or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3850 arrays, or exceptions, or ...) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3851 return cons3 (intern (name), make_int (value), tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3852 }
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 #define HACK_O_MATIC(type, name, pl) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3855 int s = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3856 struct type##_block *x = current_##type##_block; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3857 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3858 (pl) = gc_plist_hack ((name), s, (pl)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3859 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3860
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3861 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3862 Reclaim storage for Lisp objects no longer needed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3863 Return info on amount of space in use:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3864 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3865 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3866 PLIST)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3867 where `PLIST' is a list of alternating keyword/value pairs providing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3868 more detailed information.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3869 Garbage collection happens automatically if you cons more than
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3870 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3871 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3872 ())
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 Lisp_Object pl = Qnil;
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
3875 int i;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3876 int gc_count_vector_total_size = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3877
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3878 garbage_collect_1 ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3879
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3880 for (i = 0; i < lrecord_type_count; i++)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3881 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3882 if (lcrecord_stats[i].bytes_in_use != 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3883 || lcrecord_stats[i].bytes_freed != 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3884 || lcrecord_stats[i].instances_on_free_list != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3885 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3886 char buf [255];
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3887 const char *name = lrecord_implementations_table[i]->name;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3888 int len = strlen (name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3889 /* save this for the FSFmacs-compatible part of the summary */
460
223736d75acb Import from CVS: tag r21-2-45
cvs
parents: 458
diff changeset
3890 if (i == lrecord_type_vector)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3891 gc_count_vector_total_size =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3892 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3893
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3894 sprintf (buf, "%s-storage", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3895 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3896 /* Okay, simple pluralization check for `symbol-value-varalias' */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3897 if (name[len-1] == 's')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3898 sprintf (buf, "%ses-freed", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3899 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3900 sprintf (buf, "%ss-freed", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3901 if (lcrecord_stats[i].instances_freed != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3902 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3903 if (name[len-1] == 's')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3904 sprintf (buf, "%ses-on-free-list", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3905 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3906 sprintf (buf, "%ss-on-free-list", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3907 if (lcrecord_stats[i].instances_on_free_list != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3908 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3909 pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3910 if (name[len-1] == 's')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3911 sprintf (buf, "%ses-used", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3912 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3913 sprintf (buf, "%ss-used", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3914 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3915 }
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 HACK_O_MATIC (extent, "extent-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3919 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3920 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
3921 HACK_O_MATIC (event, "event-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3922 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3923 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
3924 HACK_O_MATIC (marker, "marker-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3925 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3926 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
3927 #ifdef LISP_FLOAT_TYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3928 HACK_O_MATIC (float, "float-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3929 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3930 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
3931 #endif /* LISP_FLOAT_TYPE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3932 HACK_O_MATIC (string, "string-header-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3933 pl = gc_plist_hack ("long-strings-total-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3934 gc_count_string_total_size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3935 - gc_count_short_string_total_size, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3936 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3937 pl = gc_plist_hack ("short-strings-total-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3938 gc_count_short_string_total_size, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3939 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3940 pl = gc_plist_hack ("long-strings-used",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3941 gc_count_num_string_in_use
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3942 - gc_count_num_short_string_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3943 pl = gc_plist_hack ("short-strings-used",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3944 gc_count_num_short_string_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3945
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3946 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3947 pl = gc_plist_hack ("compiled-functions-free",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3948 gc_count_num_compiled_function_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3949 pl = gc_plist_hack ("compiled-functions-used",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3950 gc_count_num_compiled_function_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3951
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3952 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
3953 pl = gc_plist_hack ("bit-vectors-total-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3954 gc_count_bit_vector_total_size, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3955 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
3956
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3957 HACK_O_MATIC (symbol, "symbol-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3958 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3959 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
3960
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3961 HACK_O_MATIC (cons, "cons-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3962 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3963 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
3964
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3965 /* The things we do for backwards-compatibility */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3966 return
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3967 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3968 make_int (gc_count_num_cons_freelist)),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3969 Fcons (make_int (gc_count_num_symbol_in_use),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3970 make_int (gc_count_num_symbol_freelist)),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3971 Fcons (make_int (gc_count_num_marker_in_use),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3972 make_int (gc_count_num_marker_freelist)),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3973 make_int (gc_count_string_total_size),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3974 make_int (gc_count_vector_total_size),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3975 pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3976 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3977 #undef HACK_O_MATIC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3978
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3979 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3980 Return the number of bytes consed since the last garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3981 \"Consed\" is a misnomer in that this actually counts allocation
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3982 of all different kinds of objects, not just conses.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3983
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3984 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3985 */
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 return make_int (consing_since_gc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3989 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3990
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3991 #if 0
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3992 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
3993 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
3994 This may be helpful in debugging XEmacs's memory usage.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3995 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
3996 */
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 return make_int ((EMACS_INT) sbrk (0) / 1024);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4000 }
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4001 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4002
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4003 DEFUN ("memory-usage", Fmemory_usage, 0, 0, 0, /*
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4004 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
4005 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
4006 */
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 return make_int (total_data_usage ());
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4010 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4011
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
4012 void
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
4013 recompute_funcall_allocation_flag (void)
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
4014 {
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
4015 funcall_allocation_flag = need_to_garbage_collect || need_to_check_c_alloca;
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
4016 }
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
4017
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4018 /* 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
4019 static void
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4020 recompute_need_to_garbage_collect (void)
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4021 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4022 if (always_gc)
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4023 need_to_garbage_collect = 1;
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4024 else
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4025 need_to_garbage_collect =
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4026 (consing_since_gc > gc_cons_threshold
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4027 #if 0 /* #### implement this better */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4028 &&
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4029 (100 * consing_since_gc) / total_data_usage () >=
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4030 gc_cons_percentage
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4031 #endif /* 0 */
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4032 );
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
4033 recompute_funcall_allocation_flag ();
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4034 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4035
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4036
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4037 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4038 object_dead_p (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4039 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4040 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4041 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4042 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4043 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4044 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4045 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4046 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4049 #ifdef MEMORY_USAGE_STATS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4050
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4051 /* Attempt to determine the actual amount of space that is used for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4052 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4053
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4054 It seems that the following holds:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4055
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4056 1. When using the old allocator (malloc.c):
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4057
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4058 -- blocks are always allocated in chunks of powers of two. For
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4059 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
4060 defined, 20 bytes if it is defined. In other words, a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4061 one-byte allocation needs 8 bytes of overhead for a total of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4062 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
4063 it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4064
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4065 2. When using the new allocator (gmalloc.c):
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4066
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4067 -- blocks are always allocated in chunks of powers of two up
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4068 to 4096 bytes. Larger blocks are allocated in chunks of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4069 an integral multiple of 4096 bytes. The minimum block
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4070 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4071 is defined. There is no per-block overhead, but there
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4072 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4073 allocated.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4074
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4075 3. When using the system malloc, anything goes, but they are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4076 generally slower and more space-efficient than the GNU
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4077 allocators. One possibly reasonable assumption to make
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4078 for want of better data is that sizeof (void *), or maybe
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4079 2 * sizeof (void *), is required as overhead and that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4080 blocks are allocated in the minimum required size except
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4081 that some minimum block size is imposed (e.g. 16 bytes). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4082
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4083 Bytecount
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4084 malloced_storage_size (void *ptr, Bytecount claimed_size,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4085 struct overhead_stats *stats)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4086 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4087 Bytecount orig_claimed_size = claimed_size;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4088
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4089 #ifdef GNU_MALLOC
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4090 if (claimed_size < (Bytecount) (2 * sizeof (void *)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4091 claimed_size = 2 * sizeof (void *);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4092 # ifdef SUNOS_LOCALTIME_BUG
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4093 if (claimed_size < 16)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4094 claimed_size = 16;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4095 # endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4096 if (claimed_size < 4096)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4097 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4098 int log = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4099
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4100 /* 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
4101 the block size needed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4102 claimed_size--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4103 /* It's big, it's heavy, it's wood! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4104 while ((claimed_size /= 2) != 0)
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 claimed_size = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4107 /* It's better than bad, it's good! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4108 while (log > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4109 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4110 claimed_size *= 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4111 log--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4112 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4113 /* We have to come up with some average about the amount of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4114 blocks used. */
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4115 if ((Bytecount) (rand () & 4095) < claimed_size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4116 claimed_size += 3 * sizeof (void *);
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 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4119 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4120 claimed_size += 4095;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4121 claimed_size &= ~4095;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4122 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4123 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4124
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4125 #elif defined (SYSTEM_MALLOC)
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 if (claimed_size < 16)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4128 claimed_size = 16;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4129 claimed_size += 2 * sizeof (void *);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4130
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4131 #else /* old GNU allocator */
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 # ifdef rcheck /* #### may not be defined here */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4134 claimed_size += 20;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4135 # else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4136 claimed_size += 8;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4137 # endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4138 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4139 int log = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4140
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4141 /* 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
4142 the block size needed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4143 claimed_size--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4144 /* It's big, it's heavy, it's wood! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4145 while ((claimed_size /= 2) != 0)
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 claimed_size = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4148 /* It's better than bad, it's good! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4149 while (log > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4150 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4151 claimed_size *= 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4152 log--;
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4155
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4156 #endif /* old GNU allocator */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4157
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4158 if (stats)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4159 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4160 stats->was_requested += orig_claimed_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4161 stats->malloc_overhead += claimed_size - orig_claimed_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4162 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4163 return claimed_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4164 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4165
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4166 Bytecount
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4167 fixed_type_block_overhead (Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4168 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4169 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
4170 Bytecount overhead = 0;
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4171 Bytecount storage_size = malloced_storage_size (0, per_block, 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4172 while (size >= per_block)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4173 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4174 size -= per_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4175 overhead += sizeof (void *) + per_block - storage_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4176 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4177 if (rand () % per_block < size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4178 overhead += sizeof (void *) + per_block - storage_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4179 return overhead;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4180 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4181
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4182 #endif /* MEMORY_USAGE_STATS */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4183
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4184
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4185 /* Initialization */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4186 static void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4187 common_init_alloc_once_early (void)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4188 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4189 #ifndef Qzero
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4190 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
4191 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4192
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4193 #ifndef Qnull_pointer
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4194 /* 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
4195 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
4196 Qnull_pointer = wrap_pointer_1 (0);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4197 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4198
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4199 gc_generation_number[0] = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4200 breathing_space = 0;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4201 all_bit_vectors = Qzero;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4202 Vgc_message = Qzero;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4203 all_lcrecords = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4204 ignore_malloc_warnings = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4205 #ifdef DOUG_LEA_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4206 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4207 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4208 #if 0 /* Moved to emacs.c */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4209 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4210 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4211 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4212 init_string_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4213 init_string_chars_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4214 init_cons_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4215 init_symbol_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4216 init_compiled_function_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4217 #ifdef LISP_FLOAT_TYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4218 init_float_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4219 #endif /* LISP_FLOAT_TYPE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4220 init_marker_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4221 init_extent_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4222 init_event_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4223
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4224 ignore_malloc_warnings = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4225
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4226 if (staticpros_nodump)
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4227 Dynarr_free (staticpros_nodump);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4228 staticpros_nodump = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4229 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
4230 #ifdef DEBUG_XEMACS
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4231 if (staticpro_nodump_names)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4232 Dynarr_free (staticpro_nodump_names);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4233 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
4234 Dynarr_resize (staticpro_nodump_names, 100); /* ditto */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4235 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4236
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4237 consing_since_gc = 0;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4238 need_to_garbage_collect = always_gc;
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
4239 need_to_check_c_alloca = 0;
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
4240 funcall_allocation_flag = 0;
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
4241 funcall_alloca_count = 0;
814
a634e3b7acc8 [xemacs-hg @ 2002-04-14 12:41:59 by ben]
ben
parents: 801
diff changeset
4242
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4243 #if 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4244 gc_cons_threshold = 500000; /* XEmacs change */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4245 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4246 gc_cons_threshold = 15000; /* debugging */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4247 #endif
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4248 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
4249 memory usage on Windows; not verified on other
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4250 systems */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4251 lrecord_uid_counter = 259;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4252 debug_string_purity = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4253 gcprolist = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4254
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4255 gc_currently_forbidden = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4256 gc_hooks_inhibited = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4257
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
4258 #ifdef ERROR_CHECK_TYPES
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4259 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
4260 666;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4261 ERROR_ME_NOT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4262 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4263 ERROR_ME_WARN.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4264 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4265 3333632;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4266 ERROR_ME_DEBUG_WARN.
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 776
diff changeset
4267 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
4268 8675309;
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
4269 #endif /* ERROR_CHECK_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4270 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4271
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4272 static void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4273 init_lcrecord_lists (void)
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 int i;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4276
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4277 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
4278 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4279 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
4280 staticpro_nodump (&all_lcrecord_lists[i]);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4281 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4282 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4283
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4284 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4285 reinit_alloc_once_early (void)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4286 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4287 common_init_alloc_once_early ();
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4288 init_lcrecord_lists ();
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4289 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4290
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4291 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4292 init_alloc_once_early (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4293 {
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4294 common_init_alloc_once_early ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4295
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4296 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4297 int i;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4298 for (i = 0; i < countof (lrecord_implementations_table); i++)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4299 lrecord_implementations_table[i] = 0;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4300 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4301
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4302 INIT_LRECORD_IMPLEMENTATION (cons);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4303 INIT_LRECORD_IMPLEMENTATION (vector);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4304 INIT_LRECORD_IMPLEMENTATION (string);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4305 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4306
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4307 staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4308 Dynarr_resize (staticpros, 1410); /* merely a small optimization */
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
4309 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
4310 #ifdef DEBUG_XEMACS
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4311 staticpro_names = Dynarr_new2 (char_ptr_dynarr, char *);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4312 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
4313 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
4314 #endif
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4315
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4316 init_lcrecord_lists ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4317 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4318
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4319 void
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 707
diff changeset
4320 init_alloc_early (void)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4321 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4322 gcprolist = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4323 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4324
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4325 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4326 syms_of_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4327 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4328 DEFSYMBOL (Qpre_gc_hook);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4329 DEFSYMBOL (Qpost_gc_hook);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4330 DEFSYMBOL (Qgarbage_collecting);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4331
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4332 DEFSUBR (Fcons);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4333 DEFSUBR (Flist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4334 DEFSUBR (Fvector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4335 DEFSUBR (Fbit_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4336 DEFSUBR (Fmake_byte_code);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4337 DEFSUBR (Fmake_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4338 DEFSUBR (Fmake_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4339 DEFSUBR (Fmake_bit_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4340 DEFSUBR (Fmake_string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4341 DEFSUBR (Fstring);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4342 DEFSUBR (Fmake_symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4343 DEFSUBR (Fmake_marker);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4344 DEFSUBR (Fpurecopy);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4345 DEFSUBR (Fgarbage_collect);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4346 #if 0
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4347 DEFSUBR (Fmemory_limit);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
4348 #endif
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4349 DEFSUBR (Fmemory_usage);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4350 DEFSUBR (Fconsing_since_gc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4351 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4352
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4353 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4354 vars_of_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4355 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4356 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4357 *Number of bytes of consing between garbage collections.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4358 \"Consing\" is a misnomer in that this actually counts allocation
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4359 of all different kinds of objects, not just conses.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4360 Garbage collection can happen automatically once this many bytes have been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4361 allocated since the last garbage collection. All data types count.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4362
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4363 Garbage collection happens automatically when `eval' or `funcall' are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4364 called. (Note that `funcall' is called implicitly as part of evaluation.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4365 By binding this temporarily to a large number, you can effectively
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4366 prevent garbage collection during a part of the program.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4367
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4368 Normally, you cannot set this value less than 10,000 (if you do, it is
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4369 automatically reset during the next garbage collection). However, if
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4370 XEmacs was compiled with DEBUG_XEMACS, this does not happen, allowing
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4371 you to set this value very low to track down problems with insufficient
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4372 GCPRO'ing. If you set this to a negative number, garbage collection will
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4373 happen at *EVERY* call to `eval' or `funcall'. This is an extremely
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4374 effective way to check GCPRO problems, but be warned that your XEmacs
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4375 will be unusable! You almost certainly won't have the patience to wait
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4376 long enough to be able to set it back.
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
4377
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4378 See also `consing-since-gc'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4379 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4380
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4381 DEFVAR_INT ("gc-cons-percentage", &gc_cons_percentage /*
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4382 *Percentage of memory allocated between garbage collections.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4383
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4384 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
4385 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
4386 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
4387 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
4388 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
4389 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
4390 been allocated, regardless of current memory usage.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4391
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4392 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
4393 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
4394 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
4395 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
4396
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4397 See also `consing-since-gc'.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4398 */ );
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
4399
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4400 #ifdef DEBUG_XEMACS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4401 DEFVAR_INT ("debug-allocation", &debug_allocation /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4402 If non-zero, print out information to stderr about all objects allocated.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4403 See also `debug-allocation-backtrace-length'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4404 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4405 debug_allocation = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4406
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4407 DEFVAR_INT ("debug-allocation-backtrace-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4408 &debug_allocation_backtrace_length /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4409 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4410 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4411 debug_allocation_backtrace_length = 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4412 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4413
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4414 DEFVAR_BOOL ("purify-flag", &purify_flag /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4415 Non-nil means loading Lisp code in order to dump an executable.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4416 This means that certain objects should be allocated in readonly space.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4417 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4418
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4419 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4420 Function or functions to be run just before each garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4421 Interrupts, garbage collection, and errors are inhibited while this hook
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4422 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
4423 consing, and do not interact with the user.
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 Vpre_gc_hook = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4426
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4427 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4428 Function or functions to be run just after each garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4429 Interrupts, garbage collection, and errors are inhibited while this hook
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4430 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
4431 consing, and do not interact with the user.
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 Vpost_gc_hook = Qnil;
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 DEFVAR_LISP ("gc-message", &Vgc_message /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4436 String to print to indicate that a garbage collection is in progress.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4437 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
4438 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
4439 image instance) in the domain of the selected frame, the mouse pointer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4440 will change instead of this message being printed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4441 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4442 Vgc_message = build_string (gc_default_message);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4443
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4444 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4445 Pointer glyph used to indicate that a garbage collection is in progress.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4446 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
4447 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
4448 window, the pointer will be changed as specified during garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4449 Otherwise, a message will be printed in the echo area, as controlled
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4450 by `gc-message'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4451 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4452 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4453
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4454 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4455 complex_vars_of_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4456 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4457 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4458 }