annotate src/alloc.c @ 665:fdefd0186b75

[xemacs-hg @ 2001-09-20 06:28:42 by ben] The great integral types renaming. The purpose of this is to rationalize the names used for various integral types, so that they match their intended uses and follow consist conventions, and eliminate types that were not semantically different from each other. The conventions are: -- All integral types that measure quantities of anything are signed. Some people disagree vociferously with this, but their arguments are mostly theoretical, and are vastly outweighed by the practical headaches of mixing signed and unsigned values, and more importantly by the far increased likelihood of inadvertent bugs: Because of the broken "viral" nature of unsigned quantities in C (operations involving mixed signed/unsigned are done unsigned, when exactly the opposite is nearly always wanted), even a single error in declaring a quantity unsigned that should be signed, or even the even more subtle error of comparing signed and unsigned values and forgetting the necessary cast, can be catastrophic, as comparisons will yield wrong results. -Wsign-compare is turned on specifically to catch this, but this tends to result in a great number of warnings when mixing signed and unsigned, and the casts are annoying. More has been written on this elsewhere. -- All such quantity types just mentioned boil down to EMACS_INT, which is 32 bits on 32-bit machines and 64 bits on 64-bit machines. This is guaranteed to be the same size as Lisp objects of type `int', and (as far as I can tell) of size_t (unsigned!) and ssize_t. The only type below that is not an EMACS_INT is Hashcode, which is an unsigned value of the same size as EMACS_INT. -- Type names should be relatively short (no more than 10 characters or so), with the first letter capitalized and no underscores if they can at all be avoided. -- "count" == a zero-based measurement of some quantity. Includes sizes, offsets, and indexes. -- "bpos" == a one-based measurement of a position in a buffer. "Charbpos" and "Bytebpos" count text in the buffer, rather than bytes in memory; thus Bytebpos does not directly correspond to the memory representation. Use "Membpos" for this. -- "Char" refers to internal-format characters, not to the C type "char", which is really a byte. -- For the actual name changes, see the script below. I ran the following script to do the conversion. (NOTE: This script is idempotent. You can safely run it multiple times and it will not screw up previous results -- in fact, it will do nothing if nothing has changed. Thus, it can be run repeatedly as necessary to handle patches coming in from old workspaces, or old branches.) There are two tags, just before and just after the change: `pre-integral-type-rename' and `post-integral-type-rename'. When merging code from the main trunk into a branch, the best thing to do is first merge up to `pre-integral-type-rename', then apply the script and associated changes, then merge from `post-integral-type-change' to the present. (Alternatively, just do the merging in one operation; but you may then have a lot of conflicts needing to be resolved by hand.) Script `fixtypes.sh' follows: ----------------------------------- cut ------------------------------------ files="*.[ch] s/*.h m/*.h config.h.in ../configure.in Makefile.in.in ../lib-src/*.[ch] ../lwlib/*.[ch]" gr Memory_Count Bytecount $files gr Lstream_Data_Count Bytecount $files gr Element_Count Elemcount $files gr Hash_Code Hashcode $files gr extcount bytecount $files gr bufpos charbpos $files gr bytind bytebpos $files gr memind membpos $files gr bufbyte intbyte $files gr Extcount Bytecount $files gr Bufpos Charbpos $files gr Bytind Bytebpos $files gr Memind Membpos $files gr Bufbyte Intbyte $files gr EXTCOUNT BYTECOUNT $files gr BUFPOS CHARBPOS $files gr BYTIND BYTEBPOS $files gr MEMIND MEMBPOS $files gr BUFBYTE INTBYTE $files gr MEMORY_COUNT BYTECOUNT $files gr LSTREAM_DATA_COUNT BYTECOUNT $files gr ELEMENT_COUNT ELEMCOUNT $files gr HASH_CODE HASHCODE $files ----------------------------------- cut ------------------------------------ `fixtypes.sh' is a Bourne-shell script; it uses 'gr': ----------------------------------- cut ------------------------------------ #!/bin/sh # Usage is like this: # gr FROM TO FILES ... # globally replace FROM with TO in FILES. FROM and TO are regular expressions. # backup files are stored in the `backup' directory. from="$1" to="$2" shift 2 echo ${1+"$@"} | xargs global-replace "s/$from/$to/g" ----------------------------------- cut ------------------------------------ `gr' in turn uses a Perl script to do its real work, `global-replace', which follows: ----------------------------------- cut ------------------------------------ : #-*- Perl -*- ### global-modify --- modify the contents of a file by a Perl expression ## Copyright (C) 1999 Martin Buchholz. ## Copyright (C) 2001 Ben Wing. ## Authors: Martin Buchholz <martin@xemacs.org>, Ben Wing <ben@xemacs.org> ## Maintainer: Ben Wing <ben@xemacs.org> ## Current Version: 1.0, May 5, 2001 # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with XEmacs; see the file COPYING. If not, write to the Free # Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA # 02111-1307, USA. eval 'exec perl -w -S $0 ${1+"$@"}' if 0; use strict; use FileHandle; use Carp; use Getopt::Long; use File::Basename; (my $myName = $0) =~ s@.*/@@; my $usage=" Usage: $myName [--help] [--backup-dir=DIR] [--line-mode] [--hunk-mode] PERLEXPR FILE ... Globally modify a file, either line by line or in one big hunk. Typical usage is like this: [with GNU print, GNU xargs: guaranteed to handle spaces, quotes, etc. in file names] find . -name '*.[ch]' -print0 | xargs -0 $0 's/\bCONST\b/const/g'\n [with non-GNU print, xargs] find . -name '*.[ch]' -print | xargs $0 's/\bCONST\b/const/g'\n The file is read in, either line by line (with --line-mode specified) or in one big hunk (with --hunk-mode specified; it's the default), and the Perl expression is then evalled with \$_ set to the line or hunk of text, including the terminating newline if there is one. It should destructively modify the value there, storing the changed result in \$_. Files in which any modifications are made are backed up to the directory specified using --backup-dir, or to `backup' by default. To disable this, use --backup-dir= with no argument. Hunk mode is the default because it is MUCH MUCH faster than line-by-line. Use line-by-line only when it matters, e.g. you want to do a replacement only once per line (the default without the `g' argument). Conversely, when using hunk mode, *ALWAYS* use `g'; otherwise, you will only make one replacement in the entire file! "; my %options = (); $Getopt::Long::ignorecase = 0; &GetOptions ( \%options, 'help', 'backup-dir=s', 'line-mode', 'hunk-mode', ); die $usage if $options{"help"} or @ARGV <= 1; my $code = shift; die $usage if grep (-d || ! -w, @ARGV); sub SafeOpen { open ((my $fh = new FileHandle), $_[0]); confess "Can't open $_[0]: $!" if ! defined $fh; return $fh; } sub SafeClose { close $_[0] or confess "Can't close $_[0]: $!"; } sub FileContents { my $fh = SafeOpen ("< $_[0]"); my $olddollarslash = $/; local $/ = undef; my $contents = <$fh>; $/ = $olddollarslash; return $contents; } sub WriteStringToFile { my $fh = SafeOpen ("> $_[0]"); binmode $fh; print $fh $_[1] or confess "$_[0]: $!\n"; SafeClose $fh; } foreach my $file (@ARGV) { my $changed_p = 0; my $new_contents = ""; if ($options{"line-mode"}) { my $fh = SafeOpen $file; while (<$fh>) { my $save_line = $_; eval $code; $changed_p = 1 if $save_line ne $_; $new_contents .= $_; } } else { my $orig_contents = $_ = FileContents $file; eval $code; if ($_ ne $orig_contents) { $changed_p = 1; $new_contents = $_; } } if ($changed_p) { my $backdir = $options{"backup-dir"}; $backdir = "backup" if !defined ($backdir); if ($backdir) { my ($name, $path, $suffix) = fileparse ($file, ""); my $backfulldir = $path . $backdir; my $backfile = "$backfulldir/$name"; mkdir $backfulldir, 0755 unless -d $backfulldir; print "modifying $file (original saved in $backfile)\n"; rename $file, $backfile; } WriteStringToFile ($file, $new_contents); } } ----------------------------------- cut ------------------------------------ In addition to those programs, I needed to fix up a few other things, particularly relating to the duplicate definitions of types, now that some types merged with others. Specifically: 1. in lisp.h, removed duplicate declarations of Bytecount. The changed code should now look like this: (In each code snippet below, the first and last lines are the same as the original, as are all lines outside of those lines. That allows you to locate the section to be replaced, and replace the stuff in that section, verifying that there isn't anything new added that would need to be kept.) --------------------------------- snip ------------------------------------- /* Counts of bytes or chars */ typedef EMACS_INT Bytecount; typedef EMACS_INT Charcount; /* Counts of elements */ typedef EMACS_INT Elemcount; /* Hash codes */ typedef unsigned long Hashcode; /* ------------------------ dynamic arrays ------------------- */ --------------------------------- snip ------------------------------------- 2. in lstream.h, removed duplicate declaration of Bytecount. Rewrote the comment about this type. The changed code should now look like this: --------------------------------- snip ------------------------------------- #endif /* The have been some arguments over the what the type should be that specifies a count of bytes in a data block to be written out or read in, using Lstream_read(), Lstream_write(), and related functions. Originally it was long, which worked fine; Martin "corrected" these to size_t and ssize_t on the grounds that this is theoretically cleaner and is in keeping with the C standards. Unfortunately, this practice is horribly error-prone due to design flaws in the way that mixed signed/unsigned arithmetic happens. In fact, by doing this change, Martin introduced a subtle but fatal error that caused the operation of sending large mail messages to the SMTP server under Windows to fail. By putting all values back to be signed, avoiding any signed/unsigned mixing, the bug immediately went away. The type then in use was Lstream_Data_Count, so that it be reverted cleanly if a vote came to that. Now it is Bytecount. Some earlier comments about why the type must be signed: This MUST BE SIGNED, since it also is used in functions that return the number of bytes actually read to or written from in an operation, and these functions can return -1 to signal error. Note that the standard Unix read() and write() functions define the count going in as a size_t, which is UNSIGNED, and the count going out as an ssize_t, which is SIGNED. This is a horrible design flaw. Not only is it highly likely to lead to logic errors when a -1 gets interpreted as a large positive number, but operations are bound to fail in all sorts of horrible ways when a number in the upper-half of the size_t range is passed in -- this number is unrepresentable as an ssize_t, so code that checks to see how many bytes are actually written (which is mandatory if you are dealing with certain types of devices) will get completely screwed up. --ben */ typedef enum lstream_buffering --------------------------------- snip ------------------------------------- 3. in dumper.c, there are four places, all inside of switch() statements, where XD_BYTECOUNT appears twice as a case tag. In each case, the two case blocks contain identical code, and you should *REMOVE THE SECOND* and leave the first.
author ben
date Thu, 20 Sep 2001 06:31:11 +0000
parents b39c14581166
children a307f9a2021d
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.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4 Copyright (C) 1995, 1996 Ben Wing.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6 This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8 XEmacs is free software; you can redistribute it and/or modify it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9 under the terms of the GNU General Public License as published by the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10 Free Software Foundation; either version 2, or (at your option) any
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11 later version.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
12
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
16 for more details.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
17
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
18 You should have received a copy of the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
19 along with XEmacs; see the file COPYING. If not, write to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21 Boston, MA 02111-1307, USA. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
23 /* Synched up with: FSF 19.28, Mule 2.0. Substantially different from
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
24 FSF. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
25
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
26 /* Authorship:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
27
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
28 FSF: Original version; a long time ago.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
29 Mly: Significantly rewritten to use new 3-bit tags and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
30 nicely abstracted object definitions, for 19.8.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31 JWZ: Improved code to keep track of purespace usage and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
32 issue nice purespace and GC stats.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
33 Ben Wing: Cleaned up frob-block lrecord code, added error-checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
34 and various changes for Mule, for 19.12.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
35 Added bit vectors for 19.13.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
36 Added lcrecord lists for 19.14.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
37 slb: Lots of work on the purification and dump time code.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
38 Synched Doug Lea malloc support from Emacs 20.2.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
39 og: Killed the purespace. Portable dumper (moved to dumper.c)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
40 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
41
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
42 #include <config.h>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
43 #include "lisp.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
44
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
45 #include "backtrace.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
46 #include "buffer.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
47 #include "bytecode.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
48 #include "chartab.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
49 #include "device.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
50 #include "elhash.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
51 #include "events.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
52 #include "extents.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
53 #include "frame.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
54 #include "glyphs.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
55 #include "opaque.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
56 #include "redisplay.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
57 #include "specifier.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58 #include "sysfile.h"
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
59 #include "sysdep.h"
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60 #include "window.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61 #include "console-stream.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63 #ifdef DOUG_LEA_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
64 #include <malloc.h>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
66
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
67 #ifdef PDUMP
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
68 #include "dumper.h"
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
69 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71 EXFUN (Fgarbage_collect, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
72
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
73 #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
74 #if defined(DEBUG_XEMACS) && defined(MULE)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
75 #define VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
76 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
77 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
78
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
79 /* Define this to use malloc/free with no freelist for all datatypes,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
80 the hope being that some debugging tools may help detect
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
81 freed memory references */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
82 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
83 #include <dmalloc.h>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
84 #define ALLOC_NO_POOLS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
85 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 #ifdef DEBUG_XEMACS
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
88 static Fixnum debug_allocation;
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
89 static Fixnum debug_allocation_backtrace_length;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
91
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
92 /* Number of bytes of consing done since the last gc */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
93 EMACS_INT consing_since_gc;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
95
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
96 #define debug_allocation_backtrace() \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
97 do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
98 if (debug_allocation_backtrace_length > 0) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
99 debug_short_backtrace (debug_allocation_backtrace_length); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
100 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
101
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
102 #ifdef DEBUG_XEMACS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
103 #define INCREMENT_CONS_COUNTER(foosize, type) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
104 do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
105 if (debug_allocation) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
106 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
107 stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
108 debug_allocation_backtrace (); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
109 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110 INCREMENT_CONS_COUNTER_1 (foosize); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
111 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
112 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
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 > 1) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
115 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116 stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
117 debug_allocation_backtrace (); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
118 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
119 INCREMENT_CONS_COUNTER_1 (foosize); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
120 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
121 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
122 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
123 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
124 INCREMENT_CONS_COUNTER_1 (size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
125 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
126
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
127 #define DECREMENT_CONS_COUNTER(size) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
128 consing_since_gc -= (size); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
129 if (consing_since_gc < 0) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 consing_since_gc = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
132
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
133 /* Number of bytes of consing since gc before another gc should be done. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
134 EMACS_INT gc_cons_threshold;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
135
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
136 /* Nonzero during gc */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137 int gc_in_progress;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139 /* Number of times GC has happened at this level or below.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
140 * Level 0 is most volatile, contrary to usual convention.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
141 * (Of course, there's only one level at present) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
142 EMACS_INT gc_generation_number[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
144 /* 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
145 static int lrecord_uid_counter;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147 /* Nonzero when calling certain hooks or doing other things where
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148 a GC would be bad */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
149 int gc_currently_forbidden;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151 /* Hooks. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
152 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
153 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
154
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
155 /* "Garbage collecting" */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
156 Lisp_Object Vgc_message;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
157 Lisp_Object Vgc_pointer_glyph;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
158 static const char gc_default_message[] = "Garbage collecting";
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
159 Lisp_Object Qgarbage_collecting;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
161 /* Non-zero means we're in the process of doing the dump */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
162 int purify_flag;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164 #ifdef ERROR_CHECK_TYPECHECK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
165
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 563
diff changeset
166 Error_Behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
428
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 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
169
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
170 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
171 c_readonly (Lisp_Object obj)
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 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
174 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
175
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
177 lisp_readonly (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
180 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
181
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
183 /* Maximum amount of C stack to save when a GC happens. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
184
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
185 #ifndef MAX_SAVE_STACK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
186 #define MAX_SAVE_STACK 0 /* 16000 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
187 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
188
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
189 /* Non-zero means ignore malloc warnings. Set during initialization. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
190 int ignore_malloc_warnings;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
192
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
193 static void *breathing_space;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
195 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
196 release_breathing_space (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
197 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
198 if (breathing_space)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
199 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
200 void *tmp = breathing_space;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
201 breathing_space = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
202 xfree (tmp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
203 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
204 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
206 /* malloc calls this if it finds we are near exhausting storage */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
207 void
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
208 malloc_warning (const char *str)
428
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 if (ignore_malloc_warnings)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
211 return;
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 warn_when_safe
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
214 (Qmemory, Qcritical,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
215 "%s\n"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
216 "Killing some buffers may delay running out of memory.\n"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
217 "However, certainly by the time you receive the 95%% warning,\n"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
218 "you should clean up, kill this Emacs, and start a new one.",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
219 str);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
220 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
221
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
222 /* Called if malloc returns zero */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
223 DOESNT_RETURN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
224 memory_full (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
225 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
226 /* Force a GC next time eval is called.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
227 It's better to loop garbage-collecting (we might reclaim enough
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
228 to win) than to loop beeping and barfing "Memory exhausted"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230 consing_since_gc = gc_cons_threshold + 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
231 release_breathing_space ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
232
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
233 /* Flush some histories which might conceivably contain garbalogical
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
234 inhibitors. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
235 if (!NILP (Fboundp (Qvalues)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
236 Fset (Qvalues, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
237 Vcommand_history = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
238
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 551
diff changeset
239 out_of_memory ("Memory exhausted", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
240 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
241
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
242 /* like malloc and realloc but check for no memory left, and block input. */
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 #undef xmalloc
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245 void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
246 xmalloc (Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
247 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
248 void *val = malloc (size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
249
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
250 if (!val && (size != 0)) memory_full ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
251 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254 #undef xcalloc
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
255 static void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
256 xcalloc (Elemcount nelem, Bytecount elsize)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
257 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
258 void *val = calloc (nelem, elsize);
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 if (!val && (nelem != 0)) memory_full ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
261 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
262 }
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 void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
265 xmalloc_and_zero (Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
266 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
267 return xcalloc (size, sizeof (char));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
268 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
269
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
270 #undef xrealloc
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
271 void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
272 xrealloc (void *block, Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
273 {
551
e9a3f8b4de53 [xemacs-hg @ 2001-05-21 05:26:06 by martinb]
martinb
parents: 460
diff changeset
274 block = realloc (block, size);
e9a3f8b4de53 [xemacs-hg @ 2001-05-21 05:26:06 by martinb]
martinb
parents: 460
diff changeset
275
e9a3f8b4de53 [xemacs-hg @ 2001-05-21 05:26:06 by martinb]
martinb
parents: 460
diff changeset
276 if (!block && (size != 0)) memory_full ();
e9a3f8b4de53 [xemacs-hg @ 2001-05-21 05:26:06 by martinb]
martinb
parents: 460
diff changeset
277 return block;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
278 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
279
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
280 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
281 #ifdef ERROR_CHECK_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
282 xfree_1 (void *block)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
283 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
284 xfree (void *block)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
285 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
286 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
287 #ifdef ERROR_CHECK_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
288 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
289 error until much later on for many system mallocs, such as
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
290 the one that comes with Solaris 2.3. FMH!! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
291 assert (block != (void *) 0xDEADBEEF);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
292 assert (block);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
293 #endif /* ERROR_CHECK_MALLOC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
294 free (block);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
295 }
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 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
298
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
299 #if SIZEOF_INT == 4
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
300 typedef unsigned int four_byte_t;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
301 #elif SIZEOF_LONG == 4
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
302 typedef unsigned long four_byte_t;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
303 #elif SIZEOF_SHORT == 4
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
304 typedef unsigned short four_byte_t;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
305 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
306 What kind of strange-ass system are we running on?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
307 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
308
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
309 static void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
310 deadbeef_memory (void *ptr, Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
311 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
312 four_byte_t *ptr4 = (four_byte_t *) ptr;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
313 Bytecount beefs = size >> 2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
314
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
315 /* In practice, size will always be a multiple of four. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
316 while (beefs--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
317 (*ptr4++) = 0xDEADBEEF;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
318 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
319
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
320 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
321
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 #define deadbeef_memory(ptr, size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
324
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
325 #endif /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
326
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
327 #undef xstrdup
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
328 char *
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
329 xstrdup (const char *str)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
330 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
331 int len = strlen (str) + 1; /* for stupid terminating 0 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
332
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
333 void *val = xmalloc (len);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
334 if (val == 0) return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
335 return (char *) memcpy (val, str, len);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
336 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
337
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
338 #ifdef NEED_STRDUP
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
339 char *
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
340 strdup (const char *s)
428
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 return xstrdup (s);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
343 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
344 #endif /* NEED_STRDUP */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
345
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
346
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
347 static void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
348 allocate_lisp_storage (Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
349 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
350 return xmalloc (size);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
353
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
354 /* lcrecords are chained together through their "next" field.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
355 After doing the mark phase, GC will walk this linked list
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
356 and free any lcrecord which hasn't been marked. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
357 static struct lcrecord_header *all_lcrecords;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
358
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
359 void *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
360 alloc_lcrecord (Bytecount size, const struct lrecord_implementation *implementation)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
361 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
362 struct lcrecord_header *lcheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
363
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
364 type_checking_assert
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
365 ((implementation->static_size == 0 ?
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
366 implementation->size_in_bytes_method != NULL :
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
367 implementation->static_size == size)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
368 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
369 (! implementation->basic_p)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
370 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
371 (! (implementation->hash == NULL && implementation->equal != NULL)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
372
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
374 set_lheader_implementation (&lcheader->lheader, implementation);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
375 lcheader->next = all_lcrecords;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
376 #if 1 /* mly prefers to see small ID numbers */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
377 lcheader->uid = lrecord_uid_counter++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
378 #else /* jwz prefers to see real addrs */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
379 lcheader->uid = (int) &lcheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381 lcheader->free = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
382 all_lcrecords = lcheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383 INCREMENT_CONS_COUNTER (size, implementation->name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
384 return lcheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
385 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
386
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
387 #if 0 /* Presently unused */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
388 /* Very, very poor man's EGC?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
389 * This may be slow and thrash pages all over the place.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
390 * Only call it if you really feel you must (and if the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
391 * lrecord was fairly recently allocated).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
392 * 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
393 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
394 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
395 free_lcrecord (struct lcrecord_header *lcrecord)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
396 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
397 if (all_lcrecords == lcrecord)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
398 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
399 all_lcrecords = lcrecord->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
400 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
401 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
402 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
403 struct lrecord_header *header = all_lcrecords;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
404 for (;;)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
405 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
406 struct lrecord_header *next = header->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407 if (next == lcrecord)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
408 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
409 header->next = lrecord->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
410 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
412 else if (next == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
413 abort ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
414 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
415 header = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
416 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
417 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
418 if (lrecord->implementation->finalizer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
419 lrecord->implementation->finalizer (lrecord, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
420 xfree (lrecord);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
421 return;
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 #endif /* Unused */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
424
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
425
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
426 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427 disksave_object_finalization_1 (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
428 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
429 struct lcrecord_header *header;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
430
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
431 for (header = all_lcrecords; header; header = header->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
432 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
433 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
434 !header->free)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
435 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
436 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
439
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
440 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
441 /* Debugger support */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
442 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
443 /* Give gdb/dbx enough information to decode Lisp Objects. We make
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
444 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
445 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
446 to see how this is used. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
447
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
448 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
449 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
428
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 #ifdef USE_UNION_TYPE
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
452 unsigned char dbg_USE_UNION_TYPE = 1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
453 #else
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
454 unsigned char dbg_USE_UNION_TYPE = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
455 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
456
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
457 unsigned char dbg_valbits = VALBITS;
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
458 unsigned char dbg_gctypebits = GCTYPEBITS;
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
459
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
460 /* On some systems, the above definitions will be optimized away by
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
461 the compiler or linker unless they are referenced in some function. */
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
462 long dbg_inhibit_dbg_symbol_deletion (void);
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
463 long
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
464 dbg_inhibit_dbg_symbol_deletion (void)
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
465 {
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
466 return
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
467 (dbg_valmask +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
468 dbg_typemask +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
469 dbg_USE_UNION_TYPE +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
470 dbg_valbits +
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
471 dbg_gctypebits);
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
472 }
428
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 /* Macros turned into functions for ease of debugging.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
475 Debuggers don't know about macros! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
476 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
477 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
478 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
479 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
480 return EQ (obj1, obj2);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
484 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
485 /* Fixed-size type macros */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
486 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
487
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
488 /* For fixed-size types that are commonly used, we malloc() large blocks
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
489 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
490 size for an object of that type. This is more efficient than
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
491 malloc()ing each object separately because we save on malloc() time
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
492 and overhead due to the fewer number of malloc()ed blocks, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
493 also because we don't need any extra pointers within each object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
494 to keep them threaded together for GC purposes. For less common
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
495 (and frequently large-size) types, we use lcrecords, which are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
496 malloc()ed individually and chained together through a pointer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
497 in the lcrecord header. lcrecords do not need to be fixed-size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
498 (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
499 however, the size of a particular object cannot vary dynamically).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
500 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
501 additional code needs to be added to alloc.c. Finally, lcrecords
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
502 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
503
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
504 The types that are stored in these large blocks (or "frob blocks")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
505 are cons, float, compiled-function, symbol, marker, extent, event,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
506 and string.
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 Note that strings are special in that they are actually stored in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
509 two parts: a structure containing information about the string, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
510 the actual data associated with the string. The former structure
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
511 (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
512 same way as all the other such types. This structure contains a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
513 pointer to the actual string data, which is stored in structures of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
514 type struct string_chars_block. Each string_chars_block consists
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
515 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
516 string, followed by another pointer to a Lisp_String, followed by
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
517 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
518 blocks is compacted by searching sequentially through all the
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
519 blocks and compressing out any holes created by unmarked strings.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
520 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
521 a string_chars_block, although something like half as big might
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
522 make more sense) are malloc()ed separately and not stored in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
523 string_chars_blocks. Furthermore, no one string stretches across
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
524 two string_chars_blocks.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
525
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
526 Vectors are each malloc()ed separately, similar to lcrecords.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
527
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
528 In the following discussion, we use conses, but it applies equally
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
529 well to the other fixed-size types.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
530
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
531 We store cons cells inside of cons_blocks, allocating a new
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
532 cons_block with malloc() whenever necessary. Cons cells reclaimed
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
533 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
534 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
535 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
536 the versions in malloc.c and gmalloc.c) really allocates in units
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
537 of powers of two and uses 4 bytes for its own overhead.
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 What GC actually does is to search through all the cons_blocks,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
540 from the most recently allocated to the oldest, and put all
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
541 cons cells that are not marked (whether or not they're already
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
542 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
543 so the cons cells in the oldest-allocated cons_block end up
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
544 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
545 If any cons_block is entirely free, it is freed with free()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
546 and its cons cells removed from the cons_free_list. Because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
547 the cons_free_list ends up basically in memory order, we have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
548 a high locality of reference (assuming a reasonable turnover
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
549 of allocating and freeing) and have a reasonable probability
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
550 of entirely freeing up cons_blocks that have been more recently
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
551 allocated. This stage is called the "sweep stage" of GC, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
552 is executed after the "mark stage", which involves starting
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
553 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
554 (e.g. the obarray, where are all symbols are stored; the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
555 current catches and condition-cases; the backtrace list of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
556 currently executing functions; the gcpro list; etc.) and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
557 recursively marking all objects that are accessible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
558
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
559 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
560 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
561 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
562 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
563 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
564 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
565 macro. This uses a special lrecord type `lrecord_type_free',
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
566 which is never associated with any valid object.
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
567
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
568 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
569 in the conses themselves. Because the cons is still in a
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
570 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
571 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
572 indicator and the chaining pointer. So this pointer is stored
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
573 after the lrecord header (actually where C places a pointer after
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
574 the lrecord header; they are not necessarily contiguous). This
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
575 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
576 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
577 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
578 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
579 ensure adequate space for the free list chain pointer.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
580
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
581 Some types of objects need additional "finalization" done
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
582 when an object is converted from in use to not in use;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
583 this is the purpose of the ADDITIONAL_FREE_type macro.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
584 For example, markers need to be removed from the chain
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
585 of markers that is kept in each buffer. This is because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
586 markers in a buffer automatically disappear if the marker
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
587 is no longer referenced anywhere (the same does not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
588 apply to extents, however).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
589
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
590 WARNING: Things are in an extremely bizarre state when
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
591 the ADDITIONAL_FREE_type macros are called, so beware!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
592
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
593 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
594 maximize our chances of catching places where there is insufficient
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
595 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
596 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
597 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
598 something seemingly unrelated getting trashed, and is extremely
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
599 difficult to track down. If the object gets freed but not
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
600 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
601 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
602 to the invalid type `lrecord_type_free', however, and a pointer
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
603 used to chain freed objects together is stored after the lrecord
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
604 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
605 bogus, so crashes are more likely to occur right away.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
606
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
607 We want freed objects to stay free as long as possible,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
608 so instead of doing what we do above, we maintain the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
609 free objects in a first-in first-out queue. We also
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
610 don't recompute the free list each GC, unlike above;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
611 this ensures that the queue ordering is preserved.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
612 [This means that we are likely to have worse locality
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
613 of reference, and that we can never free a frob block
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
614 once it's allocated. (Even if we know that all cells
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
615 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
616 cells from the free list because the objects on the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
617 free list are unlikely to be in memory order.)]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
618 Furthermore, we never take objects off the free list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
619 unless there's a large number (usually 1000, but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
620 varies depending on type) of them already on the list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
621 This way, we ensure that an object that gets freed will
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
622 remain free for the next 1000 (or whatever) times that
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
623 an object of that type is allocated. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
624
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
625 #ifndef MALLOC_OVERHEAD
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
626 #ifdef GNU_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
627 #define MALLOC_OVERHEAD 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
628 #elif defined (rcheck)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
629 #define MALLOC_OVERHEAD 20
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
630 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
631 #define MALLOC_OVERHEAD 8
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
632 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
633 #endif /* MALLOC_OVERHEAD */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
634
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
635 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
636 /* If we released our reserve (due to running out of memory),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
637 and we have a fair amount free once again,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
638 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
639
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
640 This is called when a relocatable block is freed in ralloc.c. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
641 void refill_memory_reserve (void);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
642 void
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
643 refill_memory_reserve (void)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
644 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
645 if (breathing_space == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
646 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
647 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
649
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
650 #ifdef ALLOC_NO_POOLS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
651 # define TYPE_ALLOC_SIZE(type, structtype) 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
652 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
653 # define TYPE_ALLOC_SIZE(type, structtype) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
654 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
655 / sizeof (structtype))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
656 #endif /* ALLOC_NO_POOLS */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
657
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
658 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
659 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
660 struct type##_block \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
661 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
662 struct type##_block *prev; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
663 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
664 }; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
665 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
666 static struct type##_block *current_##type##_block; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
667 static int current_##type##_block_index; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
668 \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
669 static Lisp_Free *type##_free_list; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
670 static Lisp_Free *type##_free_list_tail; \
428
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 static void \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
673 init_##type##_alloc (void) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
674 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
675 current_##type##_block = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
676 current_##type##_block_index = \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
677 countof (current_##type##_block->block); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
678 type##_free_list = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
679 type##_free_list_tail = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
680 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
681 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
682 static int gc_count_num_##type##_in_use; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
683 static int gc_count_num_##type##_freelist
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
684
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
685 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
686 if (current_##type##_block_index \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
687 == countof (current_##type##_block->block)) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
688 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
689 struct type##_block *AFTFB_new = (struct type##_block *) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
690 allocate_lisp_storage (sizeof (struct type##_block)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
691 AFTFB_new->prev = current_##type##_block; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
692 current_##type##_block = AFTFB_new; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
693 current_##type##_block_index = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
694 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
695 (result) = \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
696 &(current_##type##_block->block[current_##type##_block_index++]); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
697 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
698
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
699 /* Allocate an instance of a type that is stored in blocks.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
700 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
701 structure type. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
702
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
703 #ifdef ERROR_CHECK_GC
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 /* Note: if you get crashes in this function, suspect incorrect calls
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
706 to free_cons() and friends. This happened once because the cons
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
707 cell was not GC-protected and was getting collected before
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
708 free_cons() was called. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
709
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
710 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
711 if (gc_count_num_##type##_freelist > \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
712 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
713 { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
714 result = (structtype *) type##_free_list; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
715 /* Before actually using the chain pointer, \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
716 we complement all its bits; see FREE_FIXED_TYPE(). */ \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
717 type##_free_list = (Lisp_Free *) \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
718 (~ (EMACS_UINT) (type##_free_list->chain)); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
719 gc_count_num_##type##_freelist--; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
720 } \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
721 else \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
722 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
723 MARK_LRECORD_AS_NOT_FREE (result); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
724 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
725
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
726 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
727
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
728 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
729 if (type##_free_list) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
730 { \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
731 result = (structtype *) type##_free_list; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
732 type##_free_list = type##_free_list->chain; \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
733 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
734 else \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
735 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
736 MARK_LRECORD_AS_NOT_FREE (result); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
737 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
738
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
739 #endif /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
740
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
741
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
742 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
743 do \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
744 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
745 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
746 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
747 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
748
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
749 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
750 do \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
751 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
752 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
753 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
754 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
755
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
756
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
757 /* 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
758 block of any lisp object type. */
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
759 typedef struct Lisp_Free
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
760 {
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
761 struct lrecord_header lheader;
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
762 struct Lisp_Free *chain;
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
763 } Lisp_Free;
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
764
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
765 #define LRECORD_FREE_P(ptr) \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
766 ((ptr)->lheader.type == lrecord_type_free)
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
767
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
768 #define MARK_LRECORD_AS_FREE(ptr) \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
769 ((void) ((ptr)->lheader.type = lrecord_type_free))
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
770
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
771 #ifdef ERROR_CHECK_GC
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
772 #define MARK_LRECORD_AS_NOT_FREE(ptr) \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
773 ((void) ((ptr)->lheader.type = lrecord_type_undefined))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
774 #else
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
775 #define MARK_LRECORD_AS_NOT_FREE(ptr) DO_NOTHING
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
776 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
777
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
778 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
779
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
780 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
781 if (type##_free_list_tail) \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
782 { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
783 /* When we store the chain pointer, we complement all \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
784 its bits; this should significantly increase its \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
785 bogosity in case someone tries to use the value, and \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
786 should make us crash faster if someone overwrites the \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
787 pointer because when it gets un-complemented in \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
788 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
789 extremely bogus. */ \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
790 type##_free_list_tail->chain = \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
791 (Lisp_Free *) ~ (EMACS_UINT) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
792 } \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
793 else \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
794 type##_free_list = (Lisp_Free *) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
795 type##_free_list_tail = (Lisp_Free *) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
796 } while (0)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
797
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
798 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
799
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
800 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
801 ((Lisp_Free *) (ptr))->chain = type##_free_list; \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
802 type##_free_list = (Lisp_Free *) (ptr); \
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
803 } while (0) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
804
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
805 #endif /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
806
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
807 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
808
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
809 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
810 structtype *FFT_ptr = (ptr); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
811 ADDITIONAL_FREE_##type (FFT_ptr); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
812 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
813 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
814 MARK_LRECORD_AS_FREE (FFT_ptr); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
815 } while (0)
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 /* Like FREE_FIXED_TYPE() but used when we are explicitly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
818 freeing a structure through free_cons(), free_marker(), etc.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
819 rather than through the normal process of sweeping.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
820 We attempt to undo the changes made to the allocation counters
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
821 as a result of this structure being allocated. This is not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
822 completely necessary but helps keep things saner: e.g. this way,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
823 repeatedly allocating and freeing a cons will not result in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
824 the consing-since-gc counter advancing, which would cause a GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
825 and somewhat defeat the purpose of explicitly freeing. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
826
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
827 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
828 do { FREE_FIXED_TYPE (type, structtype, ptr); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
829 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
830 gc_count_num_##type##_freelist++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
831 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
832
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
833
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
834
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
835 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
836 /* Cons allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
837 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
838
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
839 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
840 /* 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
841 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
842 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
843
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
844 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
845 mark_cons (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
846 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
847 if (NILP (XCDR (obj)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
848 return XCAR (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
849
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
850 mark_object (XCAR (obj));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
851 return XCDR (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
852 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
853
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
854 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
855 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
856 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
857 depth++;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
858 while (internal_equal (XCAR (ob1), XCAR (ob2), depth))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
859 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
860 ob1 = XCDR (ob1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
861 ob2 = XCDR (ob2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
862 if (! CONSP (ob1) || ! CONSP (ob2))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
863 return internal_equal (ob1, ob2, depth);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
864 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
865 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
866 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
867
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
868 static const struct lrecord_description cons_description[] = {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
869 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car) },
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
870 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr) },
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
871 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
872 };
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_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
875 mark_cons, print_cons, 0,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
876 cons_equal,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
877 /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
878 * No `hash' method needed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
879 * internal_hash knows how to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
880 * handle conses.
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 0,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
883 cons_description,
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
884 Lisp_Cons);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
885
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
886 DEFUN ("cons", Fcons, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
887 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
888 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
889 (car, cdr))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
890 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
891 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
892 Lisp_Object val;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
893 Lisp_Cons *c;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
894
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
895 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
896 set_lheader_implementation (&c->lheader, &lrecord_cons);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
897 XSETCONS (val, c);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
898 c->car = car;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
899 c->cdr = cdr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
900 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
901 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
902
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
903 /* 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
904 going to free later, and is useful when trying to track down
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
905 "real" consing. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
906 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
907 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
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 Lisp_Object val;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
910 Lisp_Cons *c;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
911
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
912 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
913 set_lheader_implementation (&c->lheader, &lrecord_cons);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
914 XSETCONS (val, c);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
915 XCAR (val) = car;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
916 XCDR (val) = cdr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
917 return val;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
920 DEFUN ("list", Flist, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
921 Return a newly created list with specified arguments as elements.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
922 Any number of arguments, even zero arguments, are allowed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
923 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
924 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
925 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
926 Lisp_Object val = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
927 Lisp_Object *argp = args + nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
928
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
929 while (argp > args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
930 val = Fcons (*--argp, val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
931 return val;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
934 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
935 list1 (Lisp_Object obj0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
936 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
937 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
938 return Fcons (obj0, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
939 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
940
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
941 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
942 list2 (Lisp_Object obj0, Lisp_Object obj1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
943 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
944 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
945 return Fcons (obj0, Fcons (obj1, Qnil));
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
948 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
949 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
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 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
952 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
955 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
956 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
957 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
958 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
959 return Fcons (obj0, Fcons (obj1, obj2));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
960 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
961
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
962 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
963 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
964 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
965 return Fcons (Fcons (key, value), alist);
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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
969 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
970 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
971 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
972 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
973 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
974
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
975 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
976 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
977 Lisp_Object obj4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
978 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
979 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
980 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
981 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
982
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
983 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
984 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
985 Lisp_Object obj4, Lisp_Object obj5)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
986 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
987 /* This cannot GC. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
988 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
989 }
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 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
992 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
993 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
994 (length, object))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
995 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
996 CHECK_NATNUM (length);
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 val = Qnil;
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
1000 EMACS_INT size = XINT (length);
428
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 while (size--)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1003 val = Fcons (object, val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1004 return val;
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1007
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1008
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1009 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1010 /* Float allocation */
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 #ifdef LISP_FLOAT_TYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1014
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1015 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1016 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1017
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1018 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1019 make_float (double float_value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1020 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1021 Lisp_Object val;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1022 Lisp_Float *f;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1023
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1024 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1025
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1026 /* Avoid dump-time `uninitialized memory read' purify warnings. */
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1027 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1028 xzero (*f);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1029
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1030 set_lheader_implementation (&f->lheader, &lrecord_float);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1031 float_data (f) = float_value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1032 XSETFLOAT (val, f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1033 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1034 }
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 #endif /* LISP_FLOAT_TYPE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1037
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1038
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 /* Vector allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1041 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1042
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1043 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1044 mark_vector (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1045 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1046 Lisp_Vector *ptr = XVECTOR (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1047 int len = vector_length (ptr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1048 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1049
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1050 for (i = 0; i < len - 1; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1051 mark_object (ptr->contents[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1052 return (len > 0) ? ptr->contents[len - 1] : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1053 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1054
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1055 static Bytecount
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1056 size_vector (const void *lheader)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1057 {
456
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 454
diff changeset
1058 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, contents,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1059 ((Lisp_Vector *) lheader)->size);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1062 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1063 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1064 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1065 int len = XVECTOR_LENGTH (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1066 if (len != XVECTOR_LENGTH (obj2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1067 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1068
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1069 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1070 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1071 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1072 while (len--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1073 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1074 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1075 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1076 return 1;
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
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1079 static Hashcode
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1080 vector_hash (Lisp_Object obj, int depth)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1081 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1082 return HASH2 (XVECTOR_LENGTH (obj),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1083 internal_array_hash (XVECTOR_DATA (obj),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1084 XVECTOR_LENGTH (obj),
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1085 depth + 1));
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1086 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1087
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1088 static const struct lrecord_description vector_description[] = {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1089 { XD_LONG, offsetof (Lisp_Vector, size) },
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1090 { 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
1091 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1092 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1093
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1094 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1095 mark_vector, print_vector, 0,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1096 vector_equal,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1097 vector_hash,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1098 vector_description,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1099 size_vector, Lisp_Vector);
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 /* #### should allocate `small' vectors from a frob-block */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1102 static Lisp_Vector *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1103 make_vector_internal (Elemcount sizei)
428
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 /* no vector_next */
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1106 Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object,
456
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 454
diff changeset
1107 contents, sizei);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1108 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1109
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1110 p->size = sizei;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1111 return p;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1114 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1115 make_vector (Elemcount length, Lisp_Object object)
428
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 Lisp_Vector *vecp = make_vector_internal (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1118 Lisp_Object *p = vector_data (vecp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1119
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1120 while (length--)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1121 *p++ = object;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1122
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1123 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1124 Lisp_Object vector;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1125 XSETVECTOR (vector, vecp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1126 return vector;
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1129
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1130 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1131 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
1132 See also the function `vector'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1133 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1134 (length, object))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1135 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1136 CONCHECK_NATNUM (length);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1137 return make_vector (XINT (length), object);
428
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1140 DEFUN ("vector", Fvector, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1141 Return a newly created vector with specified arguments as elements.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1142 Any number of arguments, even zero arguments, are allowed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1143 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1144 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1145 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1146 Lisp_Vector *vecp = make_vector_internal (nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1147 Lisp_Object *p = vector_data (vecp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1148
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1149 while (nargs--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1150 *p++ = *args++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1151
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1152 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1153 Lisp_Object vector;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1154 XSETVECTOR (vector, vecp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1155 return vector;
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1158
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1159 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1160 vector1 (Lisp_Object obj0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1161 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1162 return Fvector (1, &obj0);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1165 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1166 vector2 (Lisp_Object obj0, Lisp_Object obj1)
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 Lisp_Object args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1169 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1170 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1171 return Fvector (2, args);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1174 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1175 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
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 args[3];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1178 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1179 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1180 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1181 return Fvector (3, args);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1184 #if 0 /* currently unused */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1185
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1186 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1187 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1188 Lisp_Object obj3)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1189 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1190 Lisp_Object args[4];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1191 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1192 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1193 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1194 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1195 return Fvector (4, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1196 }
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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1199 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1200 Lisp_Object obj3, Lisp_Object obj4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1201 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1202 Lisp_Object args[5];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1203 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1204 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1205 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1206 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1207 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1208 return Fvector (5, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1209 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1210
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1211 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1212 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1213 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1214 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1215 Lisp_Object args[6];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1216 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1217 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1218 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1219 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1220 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1221 args[5] = obj5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1222 return Fvector (6, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1223 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1224
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1225 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1226 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1227 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1228 Lisp_Object obj6)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1229 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1230 Lisp_Object args[7];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1231 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1232 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1233 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1234 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1235 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1236 args[5] = obj5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1237 args[6] = obj6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1238 return Fvector (7, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1239 }
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 vector8 (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, Lisp_Object obj4, Lisp_Object obj5,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1244 Lisp_Object obj6, Lisp_Object obj7)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1245 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1246 Lisp_Object args[8];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1247 args[0] = obj0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1248 args[1] = obj1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1249 args[2] = obj2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1250 args[3] = obj3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1251 args[4] = obj4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1252 args[5] = obj5;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1253 args[6] = obj6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1254 args[7] = obj7;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1255 return Fvector (8, args);
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 #endif /* unused */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1258
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1259 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1260 /* Bit Vector allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1261 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1262
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1263 static Lisp_Object all_bit_vectors;
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 /* #### should allocate `small' bit vectors from a frob-block */
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1266 static Lisp_Bit_Vector *
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1267 make_bit_vector_internal (Elemcount sizei)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1268 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1269 Elemcount num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1270 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
1271 unsigned long,
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
1272 bits, num_longs);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1273 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
1274 set_lheader_implementation (&p->lheader, &lrecord_bit_vector);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1275
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1276 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1277
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1278 bit_vector_length (p) = sizei;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1279 bit_vector_next (p) = all_bit_vectors;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1280 /* 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
1281 functions might not set them. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1282 p->bits[num_longs - 1] = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1283 XSETBIT_VECTOR (all_bit_vectors, p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1284 return p;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1285 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1286
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1287 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1288 make_bit_vector (Elemcount length, Lisp_Object bit)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1289 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1290 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
1291 Elemcount num_longs = BIT_VECTOR_LONG_STORAGE (length);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1292
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1293 CHECK_BIT (bit);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1294
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1295 if (ZEROP (bit))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1296 memset (p->bits, 0, num_longs * sizeof (long));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1297 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1298 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1299 Elemcount bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1300 memset (p->bits, ~0, num_longs * sizeof (long));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1301 /* But we have to make sure that the unused bits in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1302 last long are 0, so that equal/hash is easy. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1303 if (bits_in_last)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1304 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1305 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1306
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1307 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1308 Lisp_Object bit_vector;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1309 XSETBIT_VECTOR (bit_vector, p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1310 return bit_vector;
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 }
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 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1315 make_bit_vector_from_byte_vector (unsigned char *bytevec, Elemcount length)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1316 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1317 Elemcount i;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1318 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
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 for (i = 0; i < length; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1321 set_bit_vector_bit (p, i, bytevec[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1322
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1323 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1324 Lisp_Object bit_vector;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1325 XSETBIT_VECTOR (bit_vector, p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1326 return bit_vector;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1327 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1328 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1329
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1330 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1331 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
1332 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
1333 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1334 (length, bit))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1335 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1336 CONCHECK_NATNUM (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1337
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1338 return make_bit_vector (XINT (length), bit);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1339 }
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 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1342 Return a newly created bit vector with specified arguments as elements.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1343 Any number of arguments, even zero arguments, are allowed.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1344 Each argument must be one of the integers 0 or 1.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1345 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1346 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1347 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1348 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1349 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1350
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1351 for (i = 0; i < nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1352 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1353 CHECK_BIT (args[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1354 set_bit_vector_bit (p, i, !ZEROP (args[i]));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1355 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1356
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1357 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1358 Lisp_Object bit_vector;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1359 XSETBIT_VECTOR (bit_vector, p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1360 return bit_vector;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1361 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1362 }
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 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1366 /* Compiled-function allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1367 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1368
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1369 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1370 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1371
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1372 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1373 make_compiled_function (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1374 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1375 Lisp_Compiled_Function *f;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1376 Lisp_Object fun;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1377
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1378 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1379 set_lheader_implementation (&f->lheader, &lrecord_compiled_function);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1380
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1381 f->stack_depth = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1382 f->specpdl_depth = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1383 f->flags.documentationp = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1384 f->flags.interactivep = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1385 f->flags.domainp = 0; /* I18N3 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1386 f->instructions = Qzero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1387 f->constants = Qzero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1388 f->arglist = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1389 f->doc_and_interactive = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1390 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1391 f->annotated = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1392 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1393 XSETCOMPILED_FUNCTION (fun, f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1394 return fun;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1395 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1396
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1397 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1398 Return a new compiled-function object.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1399 Usage: (arglist instructions constants stack-depth
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1400 &optional doc-string interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1401 Note that, unlike all other emacs-lisp functions, calling this with five
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1402 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
1403 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
1404 that this function was defined with `(interactive)'. If the arg is not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1405 specified, then that means the function is not interactive.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1406 This is terrible behavior which is retained for compatibility with old
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1407 `.elc' files which expect these semantics.
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 (int nargs, Lisp_Object *args))
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 /* In a non-insane world this function would have this arglist...
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1412 (arglist instructions constants stack_depth &optional doc_string interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1413 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1414 Lisp_Object fun = make_compiled_function ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1415 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1416
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1417 Lisp_Object arglist = args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1418 Lisp_Object instructions = args[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1419 Lisp_Object constants = args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1420 Lisp_Object stack_depth = args[3];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1421 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1422 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1423
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1424 if (nargs < 4 || nargs > 6)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1425 return Fsignal (Qwrong_number_of_arguments,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1426 list2 (intern ("make-byte-code"), make_int (nargs)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1427
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1428 /* Check for valid formal parameter list now, to allow us to use
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1429 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1430 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1431 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1432 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1433 CHECK_SYMBOL (symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1434 if (EQ (symbol, Qt) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1435 EQ (symbol, Qnil) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1436 SYMBOL_IS_KEYWORD (symbol))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 551
diff changeset
1437 invalid_constant_2
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1438 ("Invalid constant symbol in formal parameter list",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1439 symbol, arglist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1440 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1441 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1442 f->arglist = arglist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1443
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1444 /* `instructions' is a string or a cons (string . int) for a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1445 lazy-loaded function. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1446 if (CONSP (instructions))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1447 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1448 CHECK_STRING (XCAR (instructions));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1449 CHECK_INT (XCDR (instructions));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1450 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1451 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1452 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1453 CHECK_STRING (instructions);
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 f->instructions = instructions;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1456
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1457 if (!NILP (constants))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1458 CHECK_VECTOR (constants);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1459 f->constants = constants;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1460
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1461 CHECK_NATNUM (stack_depth);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1462 f->stack_depth = (unsigned short) XINT (stack_depth);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1463
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1464 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1465 if (!NILP (Vcurrent_compiled_function_annotation))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1466 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1467 else if (!NILP (Vload_file_name_internal_the_purecopy))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1468 f->annotated = Vload_file_name_internal_the_purecopy;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1469 else if (!NILP (Vload_file_name_internal))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1470 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1471 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1472 GCPRO1 (fun); /* don't let fun get reaped */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1473 Vload_file_name_internal_the_purecopy =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1474 Ffile_name_nondirectory (Vload_file_name_internal);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1475 f->annotated = Vload_file_name_internal_the_purecopy;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1476 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1477 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1478 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1479
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1480 /* doc_string may be nil, string, int, or a cons (string . int).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1481 interactive may be list or string (or unbound). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1482 f->doc_and_interactive = Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1483 #ifdef I18N3
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1484 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1485 f->doc_and_interactive = Vfile_domain;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1486 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1487 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1488 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1489 f->doc_and_interactive
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1490 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1491 Fcons (interactive, f->doc_and_interactive));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1492 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1493 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1494 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1495 f->doc_and_interactive
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1496 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1497 Fcons (doc_string, f->doc_and_interactive));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1498 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1499 if (UNBOUNDP (f->doc_and_interactive))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1500 f->doc_and_interactive = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1501
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1502 return fun;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1503 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1504
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1505
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1506 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1507 /* Symbol allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1508 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1509
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1510 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1511 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1512
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1513 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1514 Return a newly allocated uninterned symbol whose name is NAME.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1515 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
1516 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1517 (name))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1518 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1519 Lisp_Object val;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1520 Lisp_Symbol *p;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1521
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1522 CHECK_STRING (name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1523
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1524 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1525 set_lheader_implementation (&p->lheader, &lrecord_symbol);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1526 p->name = XSTRING (name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1527 p->plist = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1528 p->value = Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1529 p->function = Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1530 symbol_next (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1531 XSETSYMBOL (val, p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1532 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1533 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1534
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1535
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1536 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1537 /* Extent allocation */
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1540 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1541 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1542
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1543 struct extent *
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1544 allocate_extent (void)
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 struct extent *e;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1547
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1548 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1549 set_lheader_implementation (&e->lheader, &lrecord_extent);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1550 extent_object (e) = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1551 set_extent_start (e, -1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1552 set_extent_end (e, -1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1553 e->plist = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1554
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1555 xzero (e->flags);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1556
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1557 extent_face (e) = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1558 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
1559 e->flags.detachable = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1560
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1561 return e;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1562 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1563
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1564
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1565 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1566 /* Event allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1567 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1568
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1569 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1570 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1571
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1572 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1573 allocate_event (void)
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 Lisp_Object val;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1576 Lisp_Event *e;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1577
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1578 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1579 set_lheader_implementation (&e->lheader, &lrecord_event);
428
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 XSETEVENT (val, e);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1582 return val;
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
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 /* Marker allocation */
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
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1590 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1591 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1592
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1593 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1594 Return a new marker which does not point at any place.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1595 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1596 ())
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1597 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1598 Lisp_Object val;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1599 Lisp_Marker *p;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1600
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1601 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1602 set_lheader_implementation (&p->lheader, &lrecord_marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1603 p->buffer = 0;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1604 p->membpos = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1605 marker_next (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1606 marker_prev (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1607 p->insertion_type = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1608 XSETMARKER (val, p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1609 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1610 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1611
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1612 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1613 noseeum_make_marker (void)
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 Lisp_Object val;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1616 Lisp_Marker *p;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1617
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1618 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1619 set_lheader_implementation (&p->lheader, &lrecord_marker);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1620 p->buffer = 0;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1621 p->membpos = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1622 marker_next (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1623 marker_prev (p) = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1624 p->insertion_type = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1625 XSETMARKER (val, p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1626 return val;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1629
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1630 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1631 /* String allocation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1632 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1633
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1634 /* The data for "short" strings generally resides inside of structs of type
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1635 string_chars_block. The Lisp_String structure is allocated just like any
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1636 other Lisp object (except for vectors), and these are freelisted when
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1637 they get garbage collected. The data for short strings get compacted,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1638 but the data for large strings do not.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1639
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1640 Previously Lisp_String structures were relocated, but this caused a lot
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1641 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
1642 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
1643 that the reference would get relocated).
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 This new method makes things somewhat bigger, but it is MUCH safer. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1646
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1647 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1648 /* strings are used and freed quite often */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1649 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1650 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 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 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1653 mark_string (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1654 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1655 Lisp_String *ptr = XSTRING (obj);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1656
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1657 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1658 flush_cached_extent_info (XCAR (ptr->plist));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1659 return ptr->plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1660 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1661
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1662 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1663 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
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 Bytecount len;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1666 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1667 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1668 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1669
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1670 static const struct lrecord_description string_description[] = {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1671 { XD_BYTECOUNT, offsetof (Lisp_String, size) },
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1672 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1673 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1674 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1675 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1676
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1677 /* 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
1678 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
1679 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
1680 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
1681 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
1682 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
1683 extent info.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1684
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1685 #### 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
1686
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1687 static Lisp_Object *
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1688 string_plist_ptr (Lisp_Object string)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1689 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1690 Lisp_Object *ptr = &XSTRING (string)->plist;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1691
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1692 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1693 ptr = &XCDR (*ptr);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1694 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1695 ptr = &XCDR (*ptr);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1696 return ptr;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1697 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1698
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1699 static Lisp_Object
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1700 string_getprop (Lisp_Object string, Lisp_Object property)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1701 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1702 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
1703 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1704
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1705 static int
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1706 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1707 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1708 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
1709 return 1;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1710 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1711
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1712 static int
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1713 string_remprop (Lisp_Object string, Lisp_Object property)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1714 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1715 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1716 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1717
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1718 static Lisp_Object
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1719 string_plist (Lisp_Object string)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1720 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1721 return *string_plist_ptr (string);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1722 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1723
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1724 /* No `finalize', or `hash' methods.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1725 internal_hash() already knows how to hash strings and finalization
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1726 is done with the ADDITIONAL_FREE_string macro, which is the
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1727 standard way to do finalization when using
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1728 SWEEP_FIXED_TYPE_BLOCK(). */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1729 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1730 mark_string, print_string,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1731 0, string_equal, 0,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1732 string_description,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1733 string_getprop,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1734 string_putprop,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1735 string_remprop,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1736 string_plist,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1737 Lisp_String);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1738
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1739 /* String blocks contain this many useful bytes. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1740 #define STRING_CHARS_BLOCK_SIZE \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1741 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1742 ((2 * sizeof (struct string_chars_block *)) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1743 + sizeof (EMACS_INT))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1744 /* Block header for small strings. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1745 struct string_chars_block
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1746 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1747 EMACS_INT pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1748 struct string_chars_block *next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1749 struct string_chars_block *prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1750 /* Contents of string_chars_block->string_chars are interleaved
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1751 string_chars structures (see below) and the actual string data */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1752 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1753 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1754
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1755 static struct string_chars_block *first_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1756 static struct string_chars_block *current_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1757
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1758 /* 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
1759 * the string occupies in string_chars_block->string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1760 * (including alignment padding).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1761 */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1762 #define STRING_FULLSIZE(size) \
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1763 ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1764 ALIGNOF (Lisp_String *))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1765
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1766 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1767 #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
1768
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1769 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL)
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1770 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL))
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1771
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1772 struct string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1773 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1774 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1775 unsigned char chars[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1776 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1777
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1778 struct unused_string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1779 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1780 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1781 EMACS_INT fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1782 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1783
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1784 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1785 init_string_chars_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1786 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1787 first_string_chars_block = xnew (struct string_chars_block);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1788 first_string_chars_block->prev = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1789 first_string_chars_block->next = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1790 first_string_chars_block->pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1791 current_string_chars_block = first_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1792 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1793
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1794 static struct string_chars *
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1795 allocate_string_chars_struct (Lisp_String *string_it_goes_with,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1796 EMACS_INT fullsize)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1797 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1798 struct string_chars *s_chars;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1799
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1800 if (fullsize <=
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1801 (countof (current_string_chars_block->string_chars)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1802 - current_string_chars_block->pos))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1803 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1804 /* This string can fit in the current string chars block */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1805 s_chars = (struct string_chars *)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1806 (current_string_chars_block->string_chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1807 + current_string_chars_block->pos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1808 current_string_chars_block->pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1809 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1810 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1811 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1812 /* Make a new current string chars block */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1813 struct string_chars_block *new_scb = xnew (struct string_chars_block);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1814
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1815 current_string_chars_block->next = new_scb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1816 new_scb->prev = current_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1817 new_scb->next = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1818 current_string_chars_block = new_scb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1819 new_scb->pos = fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1820 s_chars = (struct string_chars *)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1821 current_string_chars_block->string_chars;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1822 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1823
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1824 s_chars->string = string_it_goes_with;
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 INCREMENT_CONS_COUNTER (fullsize, "string chars");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1827
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1828 return s_chars;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1831 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1832 make_uninit_string (Bytecount length)
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 Lisp_String *s;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1835 EMACS_INT fullsize = STRING_FULLSIZE (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1836 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1837
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1838 assert (length >= 0 && fullsize > 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1839
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1840 /* Allocate the string header */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1841 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1842 set_lheader_implementation (&s->lheader, &lrecord_string);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1843
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1844 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1845 ? xnew_array (Intbyte, length + 1)
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1846 : allocate_string_chars_struct (s, fullsize)->chars);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1847
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1848 set_string_length (s, length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1849 s->plist = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1850
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1851 set_string_byte (s, length, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1852
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1853 XSETSTRING (val, s);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1854 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1855 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1856
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1857 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1858 static void verify_string_chars_integrity (void);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1859 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1860
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1861 /* Resize the string S so that DELTA bytes can be inserted starting
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1862 at POS. If DELTA < 0, it means deletion starting at POS. If
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1863 POS < 0, resize the string but don't copy any characters. Use
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1864 this if you're planning on completely overwriting the string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1865 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1866
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1867 void
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1868 resize_string (Lisp_String *s, Bytecount pos, Bytecount delta)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1869 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1870 Bytecount oldfullsize, newfullsize;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1871 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1872 verify_string_chars_integrity ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1873 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1874
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1875 #ifdef ERROR_CHECK_CHARBPOS
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1876 if (pos >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1877 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1878 assert (pos <= string_length (s));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1879 if (delta < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1880 assert (pos + (-delta) <= string_length (s));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1881 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1882 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1883 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1884 if (delta < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1885 assert ((-delta) <= string_length (s));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1886 }
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1887 #endif /* ERROR_CHECK_CHARBPOS */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1888
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1889 if (delta == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1890 /* simplest case: no size change. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1891 return;
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1892
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1893 if (pos >= 0 && delta < 0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1894 /* If DELTA < 0, the functions below will delete the characters
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1895 before POS. We want to delete characters *after* POS, however,
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1896 so convert this to the appropriate form. */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1897 pos += -delta;
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1898
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1899 oldfullsize = STRING_FULLSIZE (string_length (s));
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1900 newfullsize = STRING_FULLSIZE (string_length (s) + delta);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1901
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1902 if (BIG_STRING_FULLSIZE_P (oldfullsize))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1903 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1904 if (BIG_STRING_FULLSIZE_P (newfullsize))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1905 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1906 /* Both strings are big. We can just realloc().
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1907 But careful! If the string is shrinking, we have to
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1908 memmove() _before_ realloc(), and if growing, we have to
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1909 memmove() _after_ realloc() - otherwise the access is
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1910 illegal, and we might crash. */
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1911 Bytecount len = string_length (s) + 1 - pos;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1912
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1913 if (delta < 0 && pos >= 0)
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1914 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1915 set_string_data (s, (Intbyte *) xrealloc (string_data (s),
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1916 string_length (s) + delta + 1));
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1917 if (delta > 0 && pos >= 0)
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
1918 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1919 }
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1920 else /* String has been demoted from BIG_STRING. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1921 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1922 Intbyte *new_data =
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1923 allocate_string_chars_struct (s, newfullsize)->chars;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1924 Intbyte *old_data = string_data (s);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1925
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1926 if (pos >= 0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1927 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1928 memcpy (new_data, old_data, pos);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1929 memcpy (new_data + pos + delta, old_data + pos,
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1930 string_length (s) + 1 - pos);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1931 }
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1932 set_string_data (s, new_data);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1933 xfree (old_data);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1934 }
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1935 }
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1936 else /* old string is small */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1937 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1938 if (oldfullsize == newfullsize)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1939 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1940 /* special case; size change but the necessary
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1941 allocation size won't change (up or down; code
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1942 somewhere depends on there not being any unused
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1943 allocation space, modulo any alignment
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1944 constraints). */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1945 if (pos >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1946 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1947 Intbyte *addroff = pos + string_data (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 memmove (addroff + delta, addroff,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1950 /* +1 due to zero-termination. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1951 string_length (s) + 1 - pos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1952 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1953 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1954 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1955 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1956 Intbyte *old_data = string_data (s);
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1957 Intbyte *new_data =
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1958 BIG_STRING_FULLSIZE_P (newfullsize)
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
1959 ? xnew_array (Intbyte, string_length (s) + delta + 1)
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1960 : allocate_string_chars_struct (s, newfullsize)->chars;
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1961
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1962 if (pos >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1963 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1964 memcpy (new_data, old_data, pos);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1965 memcpy (new_data + pos + delta, old_data + pos,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1966 string_length (s) + 1 - pos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1967 }
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1968 set_string_data (s, new_data);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1969
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1970 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1971 /* We need to mark this chunk of the string_chars_block
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1972 as unused so that compact_string_chars() doesn't
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1973 freak. */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1974 struct string_chars *old_s_chars = (struct string_chars *)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1975 ((char *) old_data - offsetof (struct string_chars, chars));
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1976 /* Sanity check to make sure we aren't hosed by strange
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1977 alignment/padding. */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1978 assert (old_s_chars->string == s);
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
1979 MARK_STRING_CHARS_AS_FREE (old_s_chars);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1980 ((struct unused_string_chars *) old_s_chars)->fullsize =
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1981 oldfullsize;
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1982 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1983 }
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1984 }
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1985
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1986 set_string_length (s, string_length (s) + delta);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1987 /* If pos < 0, the string won't be zero-terminated.
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1988 Terminate now just to make sure. */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1989 string_data (s)[string_length (s)] = '\0';
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1990
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1991 if (pos >= 0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1992 {
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1993 Lisp_Object string;
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 XSETSTRING (string, s);
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1996 /* We also have to adjust all of the extent indices after the
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1997 place we did the change. We say "pos - 1" because
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1998 adjust_extents() is exclusive of the starting position
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
1999 passed to it. */
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2000 adjust_extents (string, pos - 1, string_length (s),
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2001 delta);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2002 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2003
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2004 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2005 verify_string_chars_integrity ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2006 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2007 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2008
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2009 #ifdef MULE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2010
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2011 void
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2012 set_string_char (Lisp_String *s, Charcount i, Emchar c)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2013 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2014 Intbyte newstr[MAX_EMCHAR_LEN];
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2015 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2016 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2017 Bytecount newlen = set_charptr_emchar (newstr, c);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2018
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2019 if (oldlen != newlen)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2020 resize_string (s, bytoff, newlen - oldlen);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2021 /* Remember, string_data (s) might have changed so we can't cache it. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2022 memcpy (string_data (s) + bytoff, newstr, newlen);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2023 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2024
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2025 #endif /* MULE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2026
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2027 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2028 Return a new string consisting of LENGTH copies of CHARACTER.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2029 LENGTH must be a non-negative integer.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2030 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2031 (length, character))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2032 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2033 CHECK_NATNUM (length);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2034 CHECK_CHAR_COERCE_INT (character);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2035 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2036 Intbyte init_str[MAX_EMCHAR_LEN];
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2037 int len = set_charptr_emchar (init_str, XCHAR (character));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2038 Lisp_Object val = make_uninit_string (len * XINT (length));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2039
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2040 if (len == 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2041 /* Optimize the single-byte case */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2042 memset (XSTRING_DATA (val), XCHAR (character), XSTRING_LENGTH (val));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2043 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2044 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
2045 EMACS_INT i;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2046 Intbyte *ptr = XSTRING_DATA (val);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2047
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2048 for (i = XINT (length); i; i--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2049 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2050 Intbyte *init_ptr = init_str;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2051 switch (len)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2052 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2053 case 4: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2054 case 3: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2055 case 2: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2056 case 1: *ptr++ = *init_ptr++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2057 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2058 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2059 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2060 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2061 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2062 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2063
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2064 DEFUN ("string", Fstring, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2065 Concatenate all the argument characters and make the result a string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2066 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2067 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2068 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2069 Intbyte *storage = alloca_array (Intbyte, nargs * MAX_EMCHAR_LEN);
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2070 Intbyte *p = storage;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2071
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2072 for (; nargs; nargs--, args++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2073 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2074 Lisp_Object lisp_char = *args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2075 CHECK_CHAR_COERCE_INT (lisp_char);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2076 p += set_charptr_emchar (p, XCHAR (lisp_char));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2077 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2078 return make_string (storage, p - storage);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2079 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2080
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2081
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2082 /* Take some raw memory, which MUST already be in internal format,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2083 and package it up into a Lisp string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2084 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2085 make_string (const Intbyte *contents, Bytecount length)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2086 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2087 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2088
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2089 /* Make sure we find out about bad make_string's when they happen */
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2090 #if defined (ERROR_CHECK_CHARBPOS) && defined (MULE)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2091 bytecount_to_charcount (contents, length); /* Just for the assertions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2092 #endif
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 val = make_uninit_string (length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2095 memcpy (XSTRING_DATA (val), contents, length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2096 return val;
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 /* Take some raw memory, encoded in some external data format,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2100 and convert it into a Lisp string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2101 Lisp_Object
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2102 make_ext_string (const Extbyte *contents, EMACS_INT length,
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2103 Lisp_Object coding_system)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2104 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2105 Lisp_Object string;
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2106 TO_INTERNAL_FORMAT (DATA, (contents, length),
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2107 LISP_STRING, string,
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2108 coding_system);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2109 return string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2110 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2111
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2112 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2113 build_string (const CIntbyte *str)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2114 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2115 /* Some strlen's crash and burn if passed null. */
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2116 return make_string ((const Intbyte *) str, (str ? strlen(str) : 0));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2117 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2118
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2119 Lisp_Object
593
5fd7ba8b56e7 [xemacs-hg @ 2001-05-31 12:45:27 by ben]
ben
parents: 578
diff changeset
2120 build_ext_string (const Extbyte *str, Lisp_Object coding_system)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2121 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2122 /* Some strlen's crash and burn if passed null. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2123 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
2124 coding_system);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2125 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2126
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2127 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2128 build_translated_string (const CIntbyte *str)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2129 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2130 return build_string (GETTEXT (str));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2131 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2132
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2133 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2134 make_string_nocopy (const Intbyte *contents, Bytecount length)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2135 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2136 Lisp_String *s;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2137 Lisp_Object val;
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 /* Make sure we find out about bad make_string_nocopy's when they happen */
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2140 #if defined (ERROR_CHECK_CHARBPOS) && defined (MULE)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2141 bytecount_to_charcount (contents, length); /* Just for the assertions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2142 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2143
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2144 /* Allocate the string header */
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2145 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2146 set_lheader_implementation (&s->lheader, &lrecord_string);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2147 SET_C_READONLY_RECORD_HEADER (&s->lheader);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2148 s->plist = Qnil;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2149 set_string_data (s, (Intbyte *)contents);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2150 set_string_length (s, 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 XSETSTRING (val, s);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2153 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2154 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2155
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2156
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2157 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2158 /* lcrecord lists */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2159 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2160
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2161 /* Lcrecord lists are used to manage the allocation of particular
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2162 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2163 malloc() and garbage-collection junk) as much as possible.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2164 It is similar to the Blocktype class.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2165
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2166 It works like this:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2167
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2168 1) Create an lcrecord-list object using make_lcrecord_list().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2169 This is often done at initialization. Remember to staticpro_nodump
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2170 this object! The arguments to make_lcrecord_list() are the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2171 same as would be passed to alloc_lcrecord().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2172 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2173 and pass the lcrecord-list earlier created.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2174 3) When done with the lcrecord, call free_managed_lcrecord().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2175 The standard freeing caveats apply: ** make sure there are no
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2176 pointers to the object anywhere! **
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2177 4) Calling free_managed_lcrecord() is just like kissing the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2178 lcrecord goodbye as if it were garbage-collected. This means:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2179 -- the contents of the freed lcrecord are undefined, and the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2180 contents of something produced by allocate_managed_lcrecord()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2181 are undefined, just like for alloc_lcrecord().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2182 -- the mark method for the lcrecord's type will *NEVER* be called
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2183 on freed lcrecords.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2184 -- the finalize method for the lcrecord's type will be called
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2185 at the time that free_managed_lcrecord() is called.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2186
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2187 */
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 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2190 mark_lcrecord_list (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2191 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2192 struct lcrecord_list *list = XLCRECORD_LIST (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2193 Lisp_Object chain = list->free;
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 while (!NILP (chain))
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 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2198 struct free_lcrecord_header *free_header =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2199 (struct free_lcrecord_header *) lheader;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2200
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2201 gc_checking_assert
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2202 (/* There should be no other pointers to the free list. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2203 ! MARKED_RECORD_HEADER_P (lheader)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2204 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2205 /* Only lcrecords should be here. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2206 ! LHEADER_IMPLEMENTATION (lheader)->basic_p
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2207 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2208 /* Only free lcrecords should be here. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2209 free_header->lcheader.free
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2210 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2211 /* The type of the lcrecord must be right. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2212 LHEADER_IMPLEMENTATION (lheader) == list->implementation
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2213 &&
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2214 /* So must the size. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2215 (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2216 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2217 );
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2218
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2219 MARK_RECORD_HEADER (lheader);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2220 chain = free_header->chain;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2221 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2222
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2223 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2224 }
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 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2227 mark_lcrecord_list, internal_object_printer,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2228 0, 0, 0, 0, struct lcrecord_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2229 Lisp_Object
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2230 make_lcrecord_list (Elemcount size,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2231 const struct lrecord_implementation *implementation)
428
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 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2234 &lrecord_lcrecord_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2235 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2236
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2237 p->implementation = implementation;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2238 p->size = size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2239 p->free = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2240 XSETLCRECORD_LIST (val, p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2241 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2242 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2243
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2244 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2245 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2246 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2247 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2248 if (!NILP (list->free))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2249 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2250 Lisp_Object val = list->free;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2251 struct free_lcrecord_header *free_header =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2252 (struct free_lcrecord_header *) XPNTR (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2253
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2254 #ifdef ERROR_CHECK_GC
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2255 struct lrecord_header *lheader = &free_header->lcheader.lheader;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2256
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2257 /* There should be no other pointers to the free list. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2258 assert (! MARKED_RECORD_HEADER_P (lheader));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2259 /* Only lcrecords should be here. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2260 assert (! LHEADER_IMPLEMENTATION (lheader)->basic_p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2261 /* Only free lcrecords should be here. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2262 assert (free_header->lcheader.free);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2263 /* The type of the lcrecord must be right. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2264 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2265 /* So must the size. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2266 assert (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2267 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2268 #endif /* ERROR_CHECK_GC */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2269
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2270 list->free = free_header->chain;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2271 free_header->lcheader.free = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2272 return val;
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 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2275 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2276 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2277
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2278 XSETOBJ (val, alloc_lcrecord (list->size, list->implementation));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2279 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2280 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2281 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2282
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2283 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2284 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
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 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2287 struct free_lcrecord_header *free_header =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2288 (struct free_lcrecord_header *) XPNTR (lcrecord);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2289 struct lrecord_header *lheader = &free_header->lcheader.lheader;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2290 const struct lrecord_implementation *implementation
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2291 = LHEADER_IMPLEMENTATION (lheader);
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 the size is correct. This will catch, for example,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2294 putting a window configuration on the wrong free list. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2295 gc_checking_assert ((implementation->size_in_bytes_method ?
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2296 implementation->size_in_bytes_method (lheader) :
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2297 implementation->static_size)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2298 == list->size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2299
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2300 if (implementation->finalizer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2301 implementation->finalizer (lheader, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2302 free_header->chain = list->free;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2303 free_header->lcheader.free = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2304 list->free = lcrecord;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2305 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2306
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2307
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2308
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2309
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2310 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2311 Kept for compatibility, returns its argument.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2312 Old:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2313 Make a copy of OBJECT in pure storage.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2314 Recursively copies contents of vectors and cons cells.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2315 Does not copy symbols.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2316 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2317 (object))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2318 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2319 return object;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2320 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2321
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2322
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2323 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2324 /* Garbage Collection */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2325 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2326
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2327 /* 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
2328 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
2329 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
2330 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
2331 int lrecord_type_count = lrecord_type_last_built_in_type;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2332 /* Object marker functions are in the lrecord_implementation structure.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2333 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
2334 This hack speeds up (garbage-collect) by about 5%. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2335 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2336
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2337 struct gcpro *gcprolist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2338
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2339 /* We want the staticpros relocated, but not the pointers found therein.
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2340 Hence we use a trivial description, as for pointerless objects. */
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2341 static const struct lrecord_description staticpro_description_1[] = {
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2342 { XD_END }
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2343 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2344
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2345 static const struct struct_description staticpro_description = {
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2346 sizeof (Lisp_Object *),
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2347 staticpro_description_1
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2348 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2349
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2350 static const struct lrecord_description staticpros_description_1[] = {
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2351 XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description),
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2352 { XD_END }
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2353 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2354
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2355 static const struct struct_description staticpros_description = {
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2356 sizeof (Lisp_Object_ptr_dynarr),
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2357 staticpros_description_1
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2358 };
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2359
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2360 Lisp_Object_ptr_dynarr *staticpros;
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2361
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2362 /* 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
2363 garbage collection, and for dumping. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2364 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2365 staticpro (Lisp_Object *varaddress)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2366 {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2367 Dynarr_add (staticpros, varaddress);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2368 dump_add_root_object (varaddress);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2369 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2370
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2371
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2372 Lisp_Object_ptr_dynarr *staticpros_nodump;
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2373
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2374 /* 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
2375 garbage collection, but not for dumping. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2376 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2377 staticpro_nodump (Lisp_Object *varaddress)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2378 {
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
2379 Dynarr_add (staticpros_nodump, varaddress);
428
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
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2382 #ifdef ERROR_CHECK_GC
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2383 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2384 struct lrecord_header * GCLI_lh = (lheader); \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2385 assert (GCLI_lh != 0); \
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
2386 assert (GCLI_lh->type < (unsigned int) lrecord_type_count); \
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2387 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2388 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2389 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2390 } while (0)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2391 #else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2392 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2393 #endif
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2394
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2395
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2396 /* 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
2397 seen yet, recursively mark all the references contained in it. */
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 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2400 mark_object (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2401 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2402 tail_recurse:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2403
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2404 /* Checks we used to perform */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2405 /* if (EQ (obj, Qnull_pointer)) return; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2406 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2407 /* if (PURIFIED (XPNTR (obj))) return; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2408
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2409 if (XTYPE (obj) == Lisp_Type_Record)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2410 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2411 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2412
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2413 GC_CHECK_LHEADER_INVARIANTS (lheader);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2414
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2415 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2416 ! ((struct lcrecord_header *) lheader)->free);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2417
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2418 /* All c_readonly objects have their mark bit set,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2419 so that we only need to check the mark bit here. */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2420 if (! MARKED_RECORD_HEADER_P (lheader))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2421 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2422 MARK_RECORD_HEADER (lheader);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2423
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2424 if (RECORD_MARKER (lheader))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2425 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2426 obj = RECORD_MARKER (lheader) (obj);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2427 if (!NILP (obj)) goto tail_recurse;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2428 }
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2431 }
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 /* 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
2434 DO NOT mark the cars.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2435
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2436 Use only for internal lists! There should never be other pointers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2437 to the cons cells, because if so, the cars will remain unmarked
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2438 even when they maybe should be marked. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2439 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2440 mark_conses_in_list (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2441 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2442 Lisp_Object rest;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2443
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2444 for (rest = obj; CONSP (rest); rest = XCDR (rest))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2445 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2446 if (CONS_MARKED_P (XCONS (rest)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2447 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2448 MARK_CONS (XCONS (rest));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2449 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2450
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2451 mark_object (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2452 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2453
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2454
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2455 /* Find all structures not marked, and free them. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2456
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2457 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
2458 static int gc_count_bit_vector_storage;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2459 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
2460 static Bytecount gc_count_string_total_size;
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
2461 static Bytecount gc_count_short_string_total_size;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2462
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2463 /* static int gc_count_total_records_used, gc_count_records_total_size; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2464
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2465
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2466 /* stats on lcrecords in use - kinda kludgy */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2467
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2468 static struct
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2469 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2470 int instances_in_use;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2471 int bytes_in_use;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2472 int instances_freed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2473 int bytes_freed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2474 int instances_on_free_list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2475 } lcrecord_stats [countof (lrecord_implementations_table)];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2476
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2477 static void
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2478 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2479 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
2480 int type_index = h->type;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2481
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2482 if (((struct lcrecord_header *) h)->free)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2483 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2484 gc_checking_assert (!free_p);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2485 lcrecord_stats[type_index].instances_on_free_list++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2486 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2487 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2488 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2489 const struct lrecord_implementation *implementation =
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2490 LHEADER_IMPLEMENTATION (h);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2491
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2492 Bytecount sz = (implementation->size_in_bytes_method ?
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2493 implementation->size_in_bytes_method (h) :
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2494 implementation->static_size);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2495 if (free_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2496 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2497 lcrecord_stats[type_index].instances_freed++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2498 lcrecord_stats[type_index].bytes_freed += sz;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2499 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2500 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2501 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2502 lcrecord_stats[type_index].instances_in_use++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2503 lcrecord_stats[type_index].bytes_in_use += sz;
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2507
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2508
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2509 /* Free all unmarked records */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2510 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2511 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2512 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2513 struct lcrecord_header *header;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2514 int num_used = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2515 /* int total_size = 0; */
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 xzero (lcrecord_stats); /* Reset all statistics to 0. */
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 /* First go through and call all the finalize methods.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2520 Then go through and free the objects. There used to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2521 be only one loop here, with the call to the finalizer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2522 occurring directly before the xfree() below. That
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2523 is marginally faster but much less safe -- if the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2524 finalize method for an object needs to reference any
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2525 other objects contained within it (and many do),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2526 we could easily be screwed by having already freed that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2527 other object. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2528
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2529 for (header = *prev; header; header = header->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2530 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2531 struct lrecord_header *h = &(header->lheader);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2532
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2533 GC_CHECK_LHEADER_INVARIANTS (h);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2534
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2535 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2536 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2537 if (LHEADER_IMPLEMENTATION (h)->finalizer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2538 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2539 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2540 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2541
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2542 for (header = *prev; header; )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2543 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2544 struct lrecord_header *h = &(header->lheader);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2545 if (MARKED_RECORD_HEADER_P (h))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2546 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2547 if (! C_READONLY_RECORD_HEADER_P (h))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2548 UNMARK_RECORD_HEADER (h);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2549 num_used++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2550 /* total_size += n->implementation->size_in_bytes (h);*/
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2551 /* #### May modify header->next on a C_READONLY lcrecord */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2552 prev = &(header->next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2553 header = *prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2554 tick_lcrecord_stats (h, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2555 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2556 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2557 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2558 struct lcrecord_header *next = header->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2559 *prev = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2560 tick_lcrecord_stats (h, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2561 /* used to call finalizer right here. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2562 xfree (header);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2563 header = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2564 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2565 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2566 *used = num_used;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2567 /* *total = total_size; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2568 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2569
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2570
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2571 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2572 sweep_bit_vectors_1 (Lisp_Object *prev,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2573 int *used, int *total, int *storage)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2574 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2575 Lisp_Object bit_vector;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2576 int num_used = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2577 int total_size = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2578 int total_storage = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2579
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2580 /* BIT_VECTORP fails because the objects are marked, which changes
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2581 their implementation */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2582 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2583 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2584 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2585 int len = v->size;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2586 if (MARKED_RECORD_P (bit_vector))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2587 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2588 if (! C_READONLY_RECORD_HEADER_P(&(v->lheader)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2589 UNMARK_RECORD_HEADER (&(v->lheader));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2590 total_size += len;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2591 total_storage +=
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2592 MALLOC_OVERHEAD +
456
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 454
diff changeset
2593 FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long,
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 454
diff changeset
2594 bits, BIT_VECTOR_LONG_STORAGE (len));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2595 num_used++;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2596 /* #### May modify next on a C_READONLY bitvector */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2597 prev = &(bit_vector_next (v));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2598 bit_vector = *prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2599 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2600 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2601 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2602 Lisp_Object next = bit_vector_next (v);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2603 *prev = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2604 xfree (v);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2605 bit_vector = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2606 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2607 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2608 *used = num_used;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2609 *total = total_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2610 *storage = total_storage;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2611 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2612
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2613 /* And the Lord said: Thou shalt use the `c-backslash-region' command
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2614 to make macros prettier. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2615
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2616 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2617
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2618 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2619 do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2620 struct typename##_block *SFTB_current; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2621 int SFTB_limit; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2622 int num_free = 0, num_used = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2623 \
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2624 for (SFTB_current = current_##typename##_block, \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2625 SFTB_limit = current_##typename##_block_index; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2626 SFTB_current; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2627 ) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2628 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2629 int SFTB_iii; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2630 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2631 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2632 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2633 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2634 \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2635 if (LRECORD_FREE_P (SFTB_victim)) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2636 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2637 num_free++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2638 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2639 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2640 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2641 num_used++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2642 } \
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2643 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2644 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2645 num_free++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2646 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2647 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2648 else \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2649 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2650 num_used++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2651 UNMARK_##typename (SFTB_victim); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2652 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2653 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2654 SFTB_current = SFTB_current->prev; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2655 SFTB_limit = countof (current_##typename##_block->block); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2656 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2657 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2658 gc_count_num_##typename##_in_use = num_used; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2659 gc_count_num_##typename##_freelist = num_free; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2660 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2661
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2662 #else /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2663
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2664 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2665 do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2666 struct typename##_block *SFTB_current; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2667 struct typename##_block **SFTB_prev; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2668 int SFTB_limit; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2669 int num_free = 0, num_used = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2670 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2671 typename##_free_list = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2672 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2673 for (SFTB_prev = &current_##typename##_block, \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2674 SFTB_current = current_##typename##_block, \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2675 SFTB_limit = current_##typename##_block_index; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2676 SFTB_current; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2677 ) \
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 int SFTB_iii; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2680 int SFTB_empty = 1; \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2681 Lisp_Free *SFTB_old_free_list = typename##_free_list; \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2682 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2683 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2684 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2685 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2686 \
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2687 if (LRECORD_FREE_P (SFTB_victim)) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2688 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2689 num_free++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2690 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
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 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2693 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2694 SFTB_empty = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2695 num_used++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2696 } \
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2697 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
428
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 num_free++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2700 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
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 else \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2703 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2704 SFTB_empty = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2705 num_used++; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2706 UNMARK_##typename (SFTB_victim); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2707 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2708 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2709 if (!SFTB_empty) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2710 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2711 SFTB_prev = &(SFTB_current->prev); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2712 SFTB_current = SFTB_current->prev; \
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 else if (SFTB_current == current_##typename##_block \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2715 && !SFTB_current->prev) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2716 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2717 /* No real point in freeing sole allocation block */ \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2718 break; \
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 else \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2721 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2722 struct typename##_block *SFTB_victim_block = SFTB_current; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2723 if (SFTB_victim_block == current_##typename##_block) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2724 current_##typename##_block_index \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2725 = countof (current_##typename##_block->block); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2726 SFTB_current = SFTB_current->prev; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2727 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2728 *SFTB_prev = SFTB_current; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2729 xfree (SFTB_victim_block); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2730 /* Restore free list to what it was before victim was swept */ \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2731 typename##_free_list = SFTB_old_free_list; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2732 num_free -= SFTB_limit; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2733 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2734 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2735 SFTB_limit = countof (current_##typename##_block->block); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2736 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2737 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2738 gc_count_num_##typename##_in_use = num_used; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2739 gc_count_num_##typename##_freelist = num_free; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2740 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2741
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2742 #endif /* !ERROR_CHECK_GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2743
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2744
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2745
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2746
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2747 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2748 sweep_conses (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2749 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2750 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2751 #define ADDITIONAL_FREE_cons(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2752
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2753 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2754 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2755
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2756 /* Explicitly free a cons cell. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2757 void
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2758 free_cons (Lisp_Cons *ptr)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2759 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2760 #ifdef ERROR_CHECK_GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2761 /* 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
2762 always be four-byte aligned. If this cons cell has already been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2763 placed on the free list, however, its car will probably contain
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2764 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
2765 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
2766 check to make sure we're not freeing something already freed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2767 if (POINTER_TYPE_P (XTYPE (ptr->car)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2768 ASSERT_VALID_POINTER (XPNTR (ptr->car));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2769 #endif /* ERROR_CHECK_GC */
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 #ifndef ALLOC_NO_POOLS
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2772 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2773 #endif /* ALLOC_NO_POOLS */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2774 }
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 /* explicitly free a list. You **must make sure** that you have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2777 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
2778 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
2779 are, you will lose. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2780
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2781 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2782 free_list (Lisp_Object list)
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 Lisp_Object rest, next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2785
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2786 for (rest = list; !NILP (rest); rest = next)
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 next = XCDR (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2789 free_cons (XCONS (rest));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2790 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2791 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2792
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2793 /* explicitly free an alist. You **must make sure** that you have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2794 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
2795 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
2796 are, you will lose. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2797
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2798 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2799 free_alist (Lisp_Object alist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2800 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2801 Lisp_Object rest, next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2802
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2803 for (rest = alist; !NILP (rest); rest = next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2804 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2805 next = XCDR (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2806 free_cons (XCONS (XCAR (rest)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2807 free_cons (XCONS (rest));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2808 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2809 }
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 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2812 sweep_compiled_functions (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2813 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2814 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2815 #define ADDITIONAL_FREE_compiled_function(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2816
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2817 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2818 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2819
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2820
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2821 #ifdef LISP_FLOAT_TYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2822 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2823 sweep_floats (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2824 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2825 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2826 #define ADDITIONAL_FREE_float(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2827
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2828 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2829 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2830 #endif /* LISP_FLOAT_TYPE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2831
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2832 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2833 sweep_symbols (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2834 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2835 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2836 #define ADDITIONAL_FREE_symbol(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2837
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2838 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
428
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 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2842 sweep_extents (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2843 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2844 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2845 #define ADDITIONAL_FREE_extent(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2846
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2847 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2848 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2849
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2850 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2851 sweep_events (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2852 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2853 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2854 #define ADDITIONAL_FREE_event(ptr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2855
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2856 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2857 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2858
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2859 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2860 sweep_markers (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2861 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2862 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2863 #define ADDITIONAL_FREE_marker(ptr) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2864 do { Lisp_Object tem; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2865 XSETMARKER (tem, ptr); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2866 unchain_marker (tem); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2867 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2868
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2869 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
428
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2872 /* Explicitly free a marker. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2873 void
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2874 free_marker (Lisp_Marker *ptr)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2875 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2876 /* Perhaps this will catch freeing an already-freed marker. */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2877 gc_checking_assert (ptr->lheader.type == lrecord_type_marker);
428
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 #ifndef ALLOC_NO_POOLS
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2880 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2881 #endif /* ALLOC_NO_POOLS */
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2885 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
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 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2888 verify_string_chars_integrity (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2889 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2890 struct string_chars_block *sb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2891
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2892 /* Scan each existing string block sequentially, string by string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2893 for (sb = first_string_chars_block; sb; sb = sb->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2894 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2895 int pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2896 /* POS is the index of the next string in the block. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2897 while (pos < sb->pos)
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 struct string_chars *s_chars =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2900 (struct string_chars *) &(sb->string_chars[pos]);
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2901 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2902 int size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2903 int fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2904
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2905 /* 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
2906 STRING pointer is NULL) then this is an unused chunk of
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2907 string storage. (See below.) */
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2908
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2909 if (STRING_CHARS_FREE_P (s_chars))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2910 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2911 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2912 pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2913 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2914 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2915
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2916 string = s_chars->string;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2917 /* Must be 32-bit aligned. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2918 assert ((((int) string) & 3) == 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2919
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2920 size = string_length (string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2921 fullsize = STRING_FULLSIZE (size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2922
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2923 assert (!BIG_STRING_FULLSIZE_P (fullsize));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2924 assert (string_data (string) == s_chars->chars);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2925 pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2926 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2927 assert (pos == sb->pos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2928 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2929 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2930
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2931 #endif /* MULE && ERROR_CHECK_GC */
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 /* Compactify string chars, relocating the reference to each --
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2934 free any empty string_chars_block we see. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2935 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2936 compact_string_chars (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2937 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2938 struct string_chars_block *to_sb = first_string_chars_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2939 int to_pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2940 struct string_chars_block *from_sb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2941
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2942 /* Scan each existing string block sequentially, string by string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2943 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
2944 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2945 int from_pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2946 /* FROM_POS is the index of the next string in the block. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2947 while (from_pos < from_sb->pos)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2948 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2949 struct string_chars *from_s_chars =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2950 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2951 struct string_chars *to_s_chars;
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
2952 Lisp_String *string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2953 int size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2954 int fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2955
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2956 /* 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
2957 STRING pointer is NULL) then this is an unused chunk of
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2958 string storage. This happens under Mule when a string's
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2959 size changes in such a way that its fullsize changes.
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2960 (Strings can change size because a different-length
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2961 character can be substituted for another character.)
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2962 In this case, after the bogus string pointer is the
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2963 "fullsize" of this entry, i.e. how many bytes to skip. */
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2964
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2965 if (STRING_CHARS_FREE_P (from_s_chars))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2966 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2967 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2968 from_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2969 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2970 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2971
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2972 string = from_s_chars->string;
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 452
diff changeset
2973 assert (!(LRECORD_FREE_P (string)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2974
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2975 size = string_length (string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2976 fullsize = STRING_FULLSIZE (size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2977
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2978 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2979
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2980 /* Just skip it if it isn't marked. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2981 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2982 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2983 from_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2984 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2985 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2986
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2987 /* 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
2988 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
2989 cannot advance past FROM_SB here since FROM_SB is large enough
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2990 to currently contain this string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2991 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2992 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2993 to_sb->pos = to_pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2994 to_sb = to_sb->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2995 to_pos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2996 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2997
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2998 /* Compute new address of this string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2999 and update TO_POS for the space being used. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3000 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3001
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3002 /* Copy the string_chars to the new place. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3003 if (from_s_chars != to_s_chars)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3004 memmove (to_s_chars, from_s_chars, fullsize);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3005
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3006 /* Relocate FROM_S_CHARS's reference */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3007 set_string_data (string, &(to_s_chars->chars[0]));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3008
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3009 from_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3010 to_pos += fullsize;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3011 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3014 /* Set current to the last string chars block still used and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3015 free any that follow. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3016 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3017 struct string_chars_block *victim;
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 for (victim = to_sb->next; victim; )
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 struct string_chars_block *next = victim->next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3022 xfree (victim);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3023 victim = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3024 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3025
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3026 current_string_chars_block = to_sb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3027 current_string_chars_block->pos = to_pos;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3028 current_string_chars_block->next = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3029 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3030 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3031
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3032 #if 1 /* Hack to debug missing purecopy's */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3033 static int debug_string_purity;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3034
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3035 static void
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3036 debug_string_purity_print (Lisp_String *p)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3037 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3038 Charcount i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3039 Charcount s = string_char_length (p);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3040 stderr_out ("\"");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3041 for (i = 0; i < s; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3042 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3043 Emchar ch = string_char (p, i);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3044 if (ch < 32 || ch >= 126)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3045 stderr_out ("\\%03o", ch);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3046 else if (ch == '\\' || ch == '\"')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3047 stderr_out ("\\%c", ch);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3048 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3049 stderr_out ("%c", ch);
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 stderr_out ("\"\n");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3052 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3053 #endif /* 1 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3054
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3055
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3056 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3057 sweep_strings (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3058 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
3059 int num_small_used = 0;
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
3060 Bytecount num_small_bytes = 0, num_bytes = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3061 int debug = debug_string_purity;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3062
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3063 #define UNMARK_string(ptr) do { \
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3064 Lisp_String *p = (ptr); \
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
3065 Bytecount size = string_length (p); \
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3066 UNMARK_RECORD_HEADER (&(p->lheader)); \
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3067 num_bytes += size; \
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3068 if (!BIG_STRING_SIZE_P (size)) \
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3069 { \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3070 num_small_bytes += size; \
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3071 num_small_used++; \
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3072 } \
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3073 if (debug) \
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3074 debug_string_purity_print (p); \
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3075 } while (0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3076 #define ADDITIONAL_FREE_string(ptr) do { \
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
3077 Bytecount size = string_length (ptr); \
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3078 if (BIG_STRING_SIZE_P (size)) \
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3079 xfree (ptr->data); \
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3080 } while (0)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3081
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 428
diff changeset
3082 SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3083
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3084 gc_count_num_short_string_in_use = num_small_used;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3085 gc_count_string_total_size = num_bytes;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3086 gc_count_short_string_total_size = num_small_bytes;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3087 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3088
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3089
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3090 /* I hate duplicating all this crap! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3091 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3092 marked_p (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3093 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3094 /* Checks we used to perform. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3095 /* if (EQ (obj, Qnull_pointer)) return 1; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3096 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3097 /* if (PURIFIED (XPNTR (obj))) return 1; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3098
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3099 if (XTYPE (obj) == Lisp_Type_Record)
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 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3102
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3103 GC_CHECK_LHEADER_INVARIANTS (lheader);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3104
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3105 return MARKED_RECORD_HEADER_P (lheader);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3106 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3107 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3108 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3109
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3110 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3111 gc_sweep (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3112 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3113 /* Free all unmarked records. Do this at the very beginning,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3114 before anything else, so that the finalize methods can safely
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3115 examine items in the objects. sweep_lcrecords_1() makes
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3116 sure to call all the finalize methods *before* freeing anything,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3117 to complete the safety. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3118 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3119 int ignored;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3120 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3121 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3122
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3123 compact_string_chars ();
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 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3126 macros) must be *extremely* careful to make sure they're not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3127 referencing freed objects. The only two existing finalize
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3128 methods (for strings and markers) pass muster -- the string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3129 finalizer doesn't look at anything but its own specially-
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3130 created block, and the marker finalizer only looks at live
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3131 buffers (which will never be freed) and at the markers before
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3132 and after it in the chain (which, by induction, will never be
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3133 freed because if so, they would have already removed themselves
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3134 from the chain). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3135
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3136 /* Put all unmarked strings on free list, free'ing the string chars
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3137 of large unmarked strings */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3138 sweep_strings ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3139
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3140 /* Put all unmarked conses on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3141 sweep_conses ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3142
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3143 /* Free all unmarked bit vectors */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3144 sweep_bit_vectors_1 (&all_bit_vectors,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3145 &gc_count_num_bit_vector_used,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3146 &gc_count_bit_vector_total_size,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3147 &gc_count_bit_vector_storage);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3148
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3149 /* Free all unmarked compiled-function objects */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3150 sweep_compiled_functions ();
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 #ifdef LISP_FLOAT_TYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3153 /* Put all unmarked floats on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3154 sweep_floats ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3155 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3156
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3157 /* Put all unmarked symbols on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3158 sweep_symbols ();
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 /* Put all unmarked extents on free list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3161 sweep_extents ();
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 /* Put all unmarked markers on free list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3164 Dechain each one first from the buffer into which it points. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3165 sweep_markers ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3166
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3167 sweep_events ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3168
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3169 #ifdef PDUMP
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3170 pdump_objects_unmark ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3171 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3172 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3173
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3174 /* Clearing for disksave. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3175
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3176 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3177 disksave_object_finalization (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3178 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3179 /* It's important that certain information from the environment not get
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3180 dumped with the executable (pathnames, environment variables, etc.).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3181 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
3182 clear some known-to-be-garbage blocks of memory, so that leftover
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3183 results of old evaluation don't look like potential problems.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3184 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
3185 to turn those strings into garbage.
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3186 */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3187
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3188 /* Yeah, this list is pretty ad-hoc... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3189 Vprocess_environment = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3190 Vexec_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3191 Vdata_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3192 Vsite_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3193 Vdoc_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3194 Vconfigure_info_directory = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3195 Vexec_path = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3196 Vload_path = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3197 /* Vdump_load_path = Qnil; */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3198 /* Release hash tables for locate_file */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3199 Flocate_file_clear_hashing (Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3200 uncache_home_directory();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3201
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3202 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3203 defined(LOADHIST_BUILTIN))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3204 Vload_history = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3205 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3206 Vshell_file_name = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3207
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3208 garbage_collect_1 ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3209
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3210 /* Run the disksave finalization methods of all live objects. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3211 disksave_object_finalization_1 ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3212
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3213 /* Zero out the uninitialized (really, unused) part of the containers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3214 for the live strings. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3215 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3216 struct string_chars_block *scb;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3217 for (scb = first_string_chars_block; scb; scb = scb->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3218 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3219 int count = sizeof (scb->string_chars) - scb->pos;
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 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3222 if (count != 0)
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3223 {
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3224 /* from the block's fill ptr to the end */
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3225 memset ((scb->string_chars + scb->pos), 0, count);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3226 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3227 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3228 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3229
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3230 /* There, that ought to be enough... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3231
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3232 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3233
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3234
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3235 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3236 restore_gc_inhibit (Lisp_Object val)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3237 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3238 gc_currently_forbidden = XINT (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3239 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3240 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3241
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3242 /* 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
3243 static int gc_hooks_inhibited;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3244
611
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3245 struct post_gc_action
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3246 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3247 void (*fun) (void *);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3248 void *arg;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3249 };
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3250
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3251 typedef struct post_gc_action post_gc_action;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3252
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3253 typedef struct
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3254 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3255 Dynarr_declare (post_gc_action);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3256 } post_gc_action_dynarr;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3257
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3258 static post_gc_action_dynarr *post_gc_actions;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3259
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3260 /* 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
3261 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
3262 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
3263 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
3264
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3265 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
3266 And NEVER signal an error.
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3267 */
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3268
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3269 void
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3270 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
3271 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3272 post_gc_action action;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3273
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3274 if (!post_gc_actions)
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3275 post_gc_actions = Dynarr_new (post_gc_action);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3276
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3277 action.fun = fun;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3278 action.arg = arg;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3279
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3280 Dynarr_add (post_gc_actions, action);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3281 }
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3282
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3283 static void
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3284 run_post_gc_actions (void)
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3285 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3286 int i;
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3287
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3288 if (post_gc_actions)
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3289 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3290 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
3291 {
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3292 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
3293 (action.fun) (action.arg);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3294 }
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3295
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3296 Dynarr_reset (post_gc_actions);
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3297 }
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3298 }
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3299
428
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 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3302 garbage_collect_1 (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3303 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3304 #if MAX_SAVE_STACK > 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3305 char stack_top_variable;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3306 extern char *stack_bottom;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3307 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3308 struct frame *f;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3309 int speccount;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3310 int cursor_changed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3311 Lisp_Object pre_gc_cursor;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3312 struct gcpro gcpro1;
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 if (gc_in_progress
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3315 || gc_currently_forbidden
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3316 || in_display
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3317 || preparing_for_armageddon)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3318 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3319
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3320 /* We used to call selected_frame() here.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3321
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3322 The following functions cannot be called inside GC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3323 so we move to after the above tests. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3324 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3325 Lisp_Object frame;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3326 Lisp_Object device = Fselected_device (Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3327 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3328 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3329 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3330 if (NILP (frame))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 551
diff changeset
3331 invalid_state ("No frames exist on device", device);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3332 f = XFRAME (frame);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3333 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3334
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3335 pre_gc_cursor = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3336 cursor_changed = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3337
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3338 GCPRO1 (pre_gc_cursor);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3339
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3340 /* Very important to prevent GC during any of the following
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3341 stuff that might run Lisp code; otherwise, we'll likely
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3342 have infinite GC recursion. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3343 speccount = specpdl_depth ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3344 record_unwind_protect (restore_gc_inhibit,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3345 make_int (gc_currently_forbidden));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3346 gc_currently_forbidden = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3347
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3348 if (!gc_hooks_inhibited)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3349 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3350
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3351 /* Now show the GC cursor/message. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3352 if (!noninteractive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3353 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3354 if (FRAME_WIN_P (f))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3355 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3356 Lisp_Object frame = make_frame (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3357 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3358 FRAME_SELECTED_WINDOW (f),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3359 ERROR_ME_NOT, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3360 pre_gc_cursor = f->pointer;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3361 if (POINTER_IMAGE_INSTANCEP (cursor)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3362 /* don't change if we don't know how to change back. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3363 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
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 cursor_changed = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3366 Fset_frame_pointer (frame, cursor);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3367 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3368 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3369
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3370 /* Don't print messages to the stream device. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3371 if (!cursor_changed && !FRAME_STREAM_P (f))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3372 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3373 char *msg = (STRINGP (Vgc_message)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3374 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3375 : 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3376 Lisp_Object args[2], whole_msg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3377 args[0] = build_string (msg ? msg :
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3378 GETTEXT ((const char *) gc_default_message));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3379 args[1] = build_string ("...");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3380 whole_msg = Fconcat (2, args);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3381 echo_area_message (f, (Intbyte *) 0, whole_msg, 0, -1,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3382 Qgarbage_collecting);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3383 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3384 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3385
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3386 /***** Now we actually start the garbage collection. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3387
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3388 gc_in_progress = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3389
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3390 gc_generation_number[0]++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3391
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3392 #if MAX_SAVE_STACK > 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3393
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3394 /* Save a copy of the contents of the stack, for debugging. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3395 if (!purify_flag)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3396 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3397 /* 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
3398 static char *stack_copy;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3399 static Bytecount stack_copy_size;
428
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 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
3402 Bytecount stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3403 if (stack_size < MAX_SAVE_STACK)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3404 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3405 if (stack_copy_size < stack_size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3406 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3407 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3408 stack_copy_size = stack_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3409 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3410
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3411 memcpy (stack_copy,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3412 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3413 stack_size);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3414 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3415 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3416 #endif /* MAX_SAVE_STACK > 0 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3417
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3418 /* Do some totally ad-hoc resource clearing. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3419 /* #### generalize this? */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3420 clear_event_resource ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3421 cleanup_specifiers ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3422
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3423 /* Mark all the special slots that serve as the roots of accessibility. */
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 { /* staticpro() */
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3426 Lisp_Object **p = Dynarr_begin (staticpros);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3427 Elemcount count;
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3428 for (count = Dynarr_length (staticpros); count; count--)
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3429 mark_object (**p++);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3430 }
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3431
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3432 { /* staticpro_nodump() */
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3433 Lisp_Object **p = Dynarr_begin (staticpros_nodump);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3434 Elemcount count;
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3435 for (count = Dynarr_length (staticpros_nodump); count; count--)
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3436 mark_object (**p++);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3437 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3438
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3439 { /* GCPRO() */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3440 struct gcpro *tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3441 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3442 for (tail = gcprolist; tail; tail = tail->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3443 for (i = 0; i < tail->nvars; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3444 mark_object (tail->var[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3445 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3446
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3447 { /* specbind() */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3448 struct specbinding *bind;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3449 for (bind = specpdl; bind != specpdl_ptr; bind++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3450 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3451 mark_object (bind->symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3452 mark_object (bind->old_value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3453 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3454 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3455
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3456 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3457 struct catchtag *catch;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3458 for (catch = catchlist; catch; catch = catch->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3459 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3460 mark_object (catch->tag);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3461 mark_object (catch->val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3462 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3463 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3464
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3465 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3466 struct backtrace *backlist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3467 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3468 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3469 int nargs = backlist->nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3470 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3471
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3472 mark_object (*backlist->function);
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3473 if (nargs < 0 /* nargs == UNEVALLED || nargs == MANY */)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3474 mark_object (backlist->args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3475 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3476 for (i = 0; i < nargs; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3477 mark_object (backlist->args[i]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3478 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3479 }
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 mark_profiling_info ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3482
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3483 /* OK, now do the after-mark stuff. This is for things that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3484 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
3485 There may be complex dependencies between such objects -- e.g.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3486 a weak hash table might be unmarked, but after processing a later
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3487 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
3488 iterate until nothing more gets marked. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3489
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3490 while (finish_marking_weak_hash_tables () > 0 ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3491 finish_marking_weak_lists () > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3492 ;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3493
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3494 /* And prune (this needs to be called after everything else has been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3495 marked and before we do any sweeping). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3496 /* #### this is somewhat ad-hoc and should probably be an object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3497 method */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3498 prune_weak_hash_tables ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3499 prune_weak_lists ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3500 prune_specifiers ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3501 prune_syntax_tables ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3502
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3503 gc_sweep ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3504
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3505 consing_since_gc = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3506 #ifndef DEBUG_XEMACS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3507 /* Allow you to set it really fucking low if you really want ... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3508 if (gc_cons_threshold < 10000)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3509 gc_cons_threshold = 10000;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3510 #endif
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 gc_in_progress = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3513
611
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3514 run_post_gc_actions ();
38db05db9cb5 [xemacs-hg @ 2001-06-08 12:21:09 by ben]
ben
parents: 593
diff changeset
3515
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3516 /******* End of garbage collection ********/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3517
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3518 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3519
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3520 /* Now remove the GC cursor/message */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3521 if (!noninteractive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3522 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3523 if (cursor_changed)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3524 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3525 else if (!FRAME_STREAM_P (f))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3526 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3527 char *msg = (STRINGP (Vgc_message)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3528 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3529 : 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3530
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3531 /* Show "...done" only if the echo area would otherwise be empty. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3532 if (NILP (clear_echo_area (selected_frame (),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3533 Qgarbage_collecting, 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3534 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3535 Lisp_Object args[2], whole_msg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3536 args[0] = build_string (msg ? msg :
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3537 GETTEXT ((const char *)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3538 gc_default_message));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3539 args[1] = build_string ("... done");
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3540 whole_msg = Fconcat (2, args);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3541 echo_area_message (selected_frame (), (Intbyte *) 0,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3542 whole_msg, 0, -1,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3543 Qgarbage_collecting);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3544 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3545 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3546 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3547
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3548 /* now stop inhibiting GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3549 unbind_to (speccount, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3550
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3551 if (!breathing_space)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3552 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3553 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3554 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3555
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3556 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3557 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3558 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3559
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3560 /* Debugging aids. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3561
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3562 static Lisp_Object
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3563 gc_plist_hack (const char *name, int value, Lisp_Object tail)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3564 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3565 /* 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
3566 or portable numeric datatypes, or bit-vectors, or characters, or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3567 arrays, or exceptions, or ...) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3568 return cons3 (intern (name), make_int (value), tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3569 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3570
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3571 #define HACK_O_MATIC(type, name, pl) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3572 int s = 0; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3573 struct type##_block *x = current_##type##_block; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3574 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3575 (pl) = gc_plist_hack ((name), s, (pl)); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3576 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3577
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3578 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3579 Reclaim storage for Lisp objects no longer needed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3580 Return info on amount of space in use:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3581 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3582 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3583 PLIST)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3584 where `PLIST' is a list of alternating keyword/value pairs providing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3585 more detailed information.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3586 Garbage collection happens automatically if you cons more than
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3587 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3588 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3589 ())
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3590 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3591 Lisp_Object pl = Qnil;
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 617
diff changeset
3592 int i;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3593 int gc_count_vector_total_size = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3594
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3595 garbage_collect_1 ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3596
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3597 for (i = 0; i < lrecord_type_count; i++)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3598 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3599 if (lcrecord_stats[i].bytes_in_use != 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3600 || lcrecord_stats[i].bytes_freed != 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3601 || lcrecord_stats[i].instances_on_free_list != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3602 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3603 char buf [255];
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3604 const char *name = lrecord_implementations_table[i]->name;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3605 int len = strlen (name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3606 /* save this for the FSFmacs-compatible part of the summary */
460
223736d75acb Import from CVS: tag r21-2-45
cvs
parents: 458
diff changeset
3607 if (i == lrecord_type_vector)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3608 gc_count_vector_total_size =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3609 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3610
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3611 sprintf (buf, "%s-storage", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3612 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3613 /* Okay, simple pluralization check for `symbol-value-varalias' */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3614 if (name[len-1] == 's')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3615 sprintf (buf, "%ses-freed", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3616 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3617 sprintf (buf, "%ss-freed", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3618 if (lcrecord_stats[i].instances_freed != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3619 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3620 if (name[len-1] == 's')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3621 sprintf (buf, "%ses-on-free-list", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3622 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3623 sprintf (buf, "%ss-on-free-list", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3624 if (lcrecord_stats[i].instances_on_free_list != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3625 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3626 pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3627 if (name[len-1] == 's')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3628 sprintf (buf, "%ses-used", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3629 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3630 sprintf (buf, "%ss-used", name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3631 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3632 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3635 HACK_O_MATIC (extent, "extent-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3636 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3637 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
3638 HACK_O_MATIC (event, "event-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3639 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3640 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
3641 HACK_O_MATIC (marker, "marker-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3642 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3643 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
3644 #ifdef LISP_FLOAT_TYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3645 HACK_O_MATIC (float, "float-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3646 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3647 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
3648 #endif /* LISP_FLOAT_TYPE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3649 HACK_O_MATIC (string, "string-header-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3650 pl = gc_plist_hack ("long-strings-total-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3651 gc_count_string_total_size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3652 - gc_count_short_string_total_size, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3653 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3654 pl = gc_plist_hack ("short-strings-total-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3655 gc_count_short_string_total_size, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3656 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3657 pl = gc_plist_hack ("long-strings-used",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3658 gc_count_num_string_in_use
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3659 - gc_count_num_short_string_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3660 pl = gc_plist_hack ("short-strings-used",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3661 gc_count_num_short_string_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3662
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3663 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3664 pl = gc_plist_hack ("compiled-functions-free",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3665 gc_count_num_compiled_function_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3666 pl = gc_plist_hack ("compiled-functions-used",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3667 gc_count_num_compiled_function_in_use, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3668
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3669 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
3670 pl = gc_plist_hack ("bit-vectors-total-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3671 gc_count_bit_vector_total_size, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3672 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
3673
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3674 HACK_O_MATIC (symbol, "symbol-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3675 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3676 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
3677
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3678 HACK_O_MATIC (cons, "cons-storage", pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3679 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3680 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
3681
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3682 /* The things we do for backwards-compatibility */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3683 return
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3684 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3685 make_int (gc_count_num_cons_freelist)),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3686 Fcons (make_int (gc_count_num_symbol_in_use),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3687 make_int (gc_count_num_symbol_freelist)),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3688 Fcons (make_int (gc_count_num_marker_in_use),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3689 make_int (gc_count_num_marker_freelist)),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3690 make_int (gc_count_string_total_size),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3691 make_int (gc_count_vector_total_size),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3692 pl);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3693 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3694 #undef HACK_O_MATIC
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 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3697 Return the number of bytes consed since the last garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3698 \"Consed\" is a misnomer in that this actually counts allocation
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3699 of all different kinds of objects, not just conses.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3700
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3701 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3702 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3703 ())
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3704 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3705 return make_int (consing_since_gc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3706 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3707
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3708 #if 0
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3709 DEFUN ("memory-limit", Fmemory_limit, 0, 0, 0, /*
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3710 Return the address of the last byte Emacs has allocated, divided by 1024.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3711 This may be helpful in debugging Emacs's memory usage.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3712 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
3713 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3714 ())
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3715 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3716 return make_int ((EMACS_INT) sbrk (0) / 1024);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3717 }
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3718 #endif
428
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3721 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3722 object_dead_p (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3723 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3724 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3725 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3726 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3727 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3728 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3729 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3730 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3731 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3732
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3733 #ifdef MEMORY_USAGE_STATS
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 /* Attempt to determine the actual amount of space that is used for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3736 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
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 It seems that the following holds:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3739
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3740 1. When using the old allocator (malloc.c):
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3741
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3742 -- blocks are always allocated in chunks of powers of two. For
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3743 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
3744 defined, 20 bytes if it is defined. In other words, a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3745 one-byte allocation needs 8 bytes of overhead for a total of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3746 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
3747 it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3748
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3749 2. When using the new allocator (gmalloc.c):
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 -- blocks are always allocated in chunks of powers of two up
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3752 to 4096 bytes. Larger blocks are allocated in chunks of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3753 an integral multiple of 4096 bytes. The minimum block
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3754 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3755 is defined. There is no per-block overhead, but there
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3756 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3757 allocated.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3758
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3759 3. When using the system malloc, anything goes, but they are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3760 generally slower and more space-efficient than the GNU
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3761 allocators. One possibly reasonable assumption to make
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3762 for want of better data is that sizeof (void *), or maybe
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3763 2 * sizeof (void *), is required as overhead and that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3764 blocks are allocated in the minimum required size except
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3765 that some minimum block size is imposed (e.g. 16 bytes). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3766
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3767 Bytecount
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3768 malloced_storage_size (void *ptr, Bytecount claimed_size,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3769 struct overhead_stats *stats)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3770 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3771 Bytecount orig_claimed_size = claimed_size;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3772
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3773 #ifdef GNU_MALLOC
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3774 if (claimed_size < (Bytecount) (2 * sizeof (void *)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3775 claimed_size = 2 * sizeof (void *);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3776 # ifdef SUNOS_LOCALTIME_BUG
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3777 if (claimed_size < 16)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3778 claimed_size = 16;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3779 # endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3780 if (claimed_size < 4096)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3781 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3782 int log = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3783
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3784 /* 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
3785 the block size needed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3786 claimed_size--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3787 /* It's big, it's heavy, it's wood! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3788 while ((claimed_size /= 2) != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3789 ++log;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3790 claimed_size = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3791 /* It's better than bad, it's good! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3792 while (log > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3793 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3794 claimed_size *= 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3795 log--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3796 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3797 /* We have to come up with some average about the amount of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3798 blocks used. */
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3799 if ((Bytecount) (rand () & 4095) < claimed_size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3800 claimed_size += 3 * sizeof (void *);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3801 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3802 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3803 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3804 claimed_size += 4095;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3805 claimed_size &= ~4095;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3806 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3809 #elif defined (SYSTEM_MALLOC)
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 (claimed_size < 16)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3812 claimed_size = 16;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3813 claimed_size += 2 * sizeof (void *);
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 #else /* old GNU allocator */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3816
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3817 # ifdef rcheck /* #### may not be defined here */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3818 claimed_size += 20;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3819 # else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3820 claimed_size += 8;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3821 # endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3822 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3823 int log = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3824
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3825 /* 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
3826 the block size needed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3827 claimed_size--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3828 /* It's big, it's heavy, it's wood! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3829 while ((claimed_size /= 2) != 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3830 ++log;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3831 claimed_size = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3832 /* It's better than bad, it's good! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3833 while (log > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3834 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3835 claimed_size *= 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3836 log--;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3840 #endif /* old GNU allocator */
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 if (stats)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3843 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3844 stats->was_requested += orig_claimed_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3845 stats->malloc_overhead += claimed_size - orig_claimed_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3846 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3847 return claimed_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3848 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3849
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3850 Bytecount
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3851 fixed_type_block_overhead (Bytecount size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3852 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3853 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
3854 Bytecount overhead = 0;
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3855 Bytecount storage_size = malloced_storage_size (0, per_block, 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3856 while (size >= per_block)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3857 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3858 size -= per_block;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3859 overhead += sizeof (void *) + per_block - storage_size;
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 if (rand () % per_block < size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3862 overhead += sizeof (void *) + per_block - storage_size;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3863 return overhead;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3864 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3865
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3866 #endif /* MEMORY_USAGE_STATS */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3867
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3868
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3869 /* Initialization */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3870 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3871 reinit_alloc_once_early (void)
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 gc_generation_number[0] = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3874 breathing_space = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3875 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3876 XSETINT (Vgc_message, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3877 all_lcrecords = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3878 ignore_malloc_warnings = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3879 #ifdef DOUG_LEA_MALLOC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3880 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3881 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3882 #if 0 /* Moved to emacs.c */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3883 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3884 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3885 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3886 init_string_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3887 init_string_chars_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3888 init_cons_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3889 init_symbol_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3890 init_compiled_function_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3891 #ifdef LISP_FLOAT_TYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3892 init_float_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3893 #endif /* LISP_FLOAT_TYPE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3894 init_marker_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3895 init_extent_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3896 init_event_alloc ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3897
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3898 ignore_malloc_warnings = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3899
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3900 if (staticpros_nodump)
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3901 Dynarr_free (staticpros_nodump);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3902 staticpros_nodump = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3903 Dynarr_resize (staticpros_nodump, 100); /* merely a small optimization */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3904
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3905 consing_since_gc = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3906 #if 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3907 gc_cons_threshold = 500000; /* XEmacs change */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3908 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3909 gc_cons_threshold = 15000; /* debugging */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3910 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3911 lrecord_uid_counter = 259;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3912 debug_string_purity = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3913 gcprolist = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3914
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3915 gc_currently_forbidden = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3916 gc_hooks_inhibited = 0;
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 #ifdef ERROR_CHECK_TYPECHECK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3919 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
3920 666;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3921 ERROR_ME_NOT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3922 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3923 ERROR_ME_WARN.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3924 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3925 3333632;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3926 #endif /* ERROR_CHECK_TYPECHECK */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3927 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3928
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3929 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3930 init_alloc_once_early (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3931 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3932 reinit_alloc_once_early ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3933
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3934 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3935 int i;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3936 for (i = 0; i < countof (lrecord_implementations_table); i++)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3937 lrecord_implementations_table[i] = 0;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3938 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3939
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3940 INIT_LRECORD_IMPLEMENTATION (cons);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3941 INIT_LRECORD_IMPLEMENTATION (vector);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3942 INIT_LRECORD_IMPLEMENTATION (string);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3943 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3944
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3945 staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3946 Dynarr_resize (staticpros, 1410); /* merely a small optimization */
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 450
diff changeset
3947 dump_add_root_struct_ptr (&staticpros, &staticpros_description);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3948 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3949
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3950 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3951 reinit_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3952 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3953 gcprolist = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3954 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3955
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3956 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3957 syms_of_alloc (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3958 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3959 DEFSYMBOL (Qpre_gc_hook);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3960 DEFSYMBOL (Qpost_gc_hook);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3961 DEFSYMBOL (Qgarbage_collecting);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3962
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3963 DEFSUBR (Fcons);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3964 DEFSUBR (Flist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3965 DEFSUBR (Fvector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3966 DEFSUBR (Fbit_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3967 DEFSUBR (Fmake_byte_code);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3968 DEFSUBR (Fmake_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3969 DEFSUBR (Fmake_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3970 DEFSUBR (Fmake_bit_vector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3971 DEFSUBR (Fmake_string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3972 DEFSUBR (Fstring);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3973 DEFSUBR (Fmake_symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3974 DEFSUBR (Fmake_marker);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3975 DEFSUBR (Fpurecopy);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3976 DEFSUBR (Fgarbage_collect);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3977 #if 0
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3978 DEFSUBR (Fmemory_limit);
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3979 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3980 DEFSUBR (Fconsing_since_gc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3981 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3982
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3983 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3984 vars_of_alloc (void)
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 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3987 *Number of bytes of consing between garbage collections.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3988 \"Consing\" is a misnomer in that this actually counts allocation
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3989 of all different kinds of objects, not just conses.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3990 Garbage collection can happen automatically once this many bytes have been
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3991 allocated since the last garbage collection. All data types count.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3992
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3993 Garbage collection happens automatically when `eval' or `funcall' are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3994 called. (Note that `funcall' is called implicitly as part of evaluation.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3995 By binding this temporarily to a large number, you can effectively
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3996 prevent garbage collection during a part of the program.
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 See also `consing-since-gc'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3999 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4000
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4001 #ifdef DEBUG_XEMACS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4002 DEFVAR_INT ("debug-allocation", &debug_allocation /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4003 If non-zero, print out information to stderr about all objects allocated.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4004 See also `debug-allocation-backtrace-length'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4005 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4006 debug_allocation = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4007
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4008 DEFVAR_INT ("debug-allocation-backtrace-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4009 &debug_allocation_backtrace_length /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4010 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4011 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4012 debug_allocation_backtrace_length = 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4013 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4014
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4015 DEFVAR_BOOL ("purify-flag", &purify_flag /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4016 Non-nil means loading Lisp code in order to dump an executable.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4017 This means that certain objects should be allocated in readonly space.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4018 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4019
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4020 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4021 Function or functions to be run just before each garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4022 Interrupts, garbage collection, and errors are inhibited while this hook
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4023 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
4024 consing, and do not interact with the user.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4025 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4026 Vpre_gc_hook = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4027
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4028 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4029 Function or functions to be run just after each garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4030 Interrupts, garbage collection, and errors are inhibited while this hook
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4031 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
4032 consing, and do not interact with the user.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4033 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4034 Vpost_gc_hook = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4035
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4036 DEFVAR_LISP ("gc-message", &Vgc_message /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4037 String to print to indicate that a garbage collection is in progress.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4038 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
4039 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
4040 image instance) in the domain of the selected frame, the mouse pointer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4041 will change instead of this message being printed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4042 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4043 Vgc_message = build_string (gc_default_message);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4044
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4045 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4046 Pointer glyph used to indicate that a garbage collection is in progress.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4047 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
4048 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
4049 window, the pointer will be changed as specified during garbage collection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4050 Otherwise, a message will be printed in the echo area, as controlled
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4051 by `gc-message'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4052 */ );
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4055 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4056 complex_vars_of_alloc (void)
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 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4059 }