Mercurial > hg > xemacs-beta

comparison src/alloc.c @ 793:e38acbeb1cae

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2002-03-29 04:46:17 by ben] lots o' fixes etc/ChangeLog: New file. Separated out all entries for etc/ into their own ChangeLog. Includes entries for the following files: etc/BABYL, etc/BETA, etc/CHARSETS, etc/DISTRIB, etc/Emacs.ad, etc/FTP, etc/GNUS-NEWS, etc/GOATS, etc/HELLO, etc/INSTALL, etc/MACHINES, etc/MAILINGLISTS, etc/MSDOS, etc/MYTHOLOGY, etc/NEWS, etc/OXYMORONS, etc/PACKAGES, etc/README, etc/TUTORIAL, etc/TUTORIAL.de, etc/TUTORIAL.ja, etc/TUTORIAL.ko, etc/TUTORIAL.se, etc/aliases.ksh, etc/altrasoft-logo.xpm, etc/check_cygwin_setup.sh, etc/custom/example-themes/europe-theme.el, etc/custom/example-themes/ex-custom-file, etc/custom/example-themes/example-theme.el, etc/e/eterm.ti, etc/edt-user.doc, etc/enriched.doc, etc/etags.1, etc/gnuserv.1, etc/gnuserv.README, etc/package-index.LATEST.gpg, etc/package-index.LATEST.pgp, etc/photos/jan.png, etc/recycle.xpm, etc/refcard.tex, etc/sample.Xdefaults, etc/sample.emacs, etc/sgml/CATALOG, etc/sgml/HTML32.dtd, etc/skk/SKK.tut.E, etc/smilies/Face_ase.xbm, etc/smilies/Face_ase2.xbm, etc/smilies/Face_ase3.xbm, etc/smilies/Face_smile.xbm, etc/smilies/Face_weep.xbm, etc/sounds, etc/toolbar, etc/toolbar/workshop-cap-up.xpm, etc/xemacs-ja.1, etc/xemacs.1, etc/yow.lines, etc\BETA, etc\NEWS, etc\README, etc\TUTORIAL, etc\TUTORIAL.de, etc\check_cygwin_setup.sh, etc\sample.init.el, etc\unicode\README, etc\unicode\mule-ucs\*, etc\unicode\other\* unicode/unicode-consortium/8859-16.TXT: New file. mule/english.el: Define this charset now, since a bug was fixed that formerly prevented it. mule/ethio-util.el: Fix compile errors involving Unicode `characters', which should be integers. Makefile.in.in: Always include gui.c, to fix compile error when TTY-only. EmacsFrame.c, abbrev.c, alloc.c, buffer.c, buffer.h, bytecode.c, bytecode.h, callint.c, callproc.c, casetab.c, casetab.h, charset.h, chartab.c, chartab.h, cmds.c, console-msw.c, console-msw.h, console-tty.c, console-x.c, console-x.h, console.c, console.h, data.c, database.c, device-gtk.c, device-msw.c, device-x.c, device.c, device.h, dialog-msw.c, doc.c, doprnt.c, dumper.c, dynarr.c, editfns.c, eldap.c, eldap.h, elhash.c, elhash.h, emacs.c, eval.c, event-Xt.c, event-gtk.c, event-msw.c, event-stream.c, event-tty.c, event-unixoid.c, events.c, events.h, extents.c, extents.h, faces.c, faces.h, file-coding.c, file-coding.h, fileio.c, filelock.c, fns.c, frame-gtk.c, frame-msw.c, frame-tty.c, frame-x.c, frame.c, frame.h, free-hook.c, general-slots.h, glyphs-eimage.c, glyphs-gtk.c, glyphs-msw.c, glyphs-widget.c, glyphs-x.c, glyphs.c, glyphs.h, gpmevent.c, gtk-xemacs.c, gui-msw.c, gui-x.c, gui-x.h, gui.c, gui.h, gutter.c, gutter.h, indent.c, input-method-xlib.c, insdel.c, keymap.c, keymap.h, lisp-disunion.h, lisp-union.h, lisp.h, lread.c, lrecord.h, lstream.c, lstream.h, marker.c, menubar-gtk.c, menubar-msw.c, menubar-x.c, menubar.c, minibuf.c, mule-canna.c, mule-ccl.c, mule-charset.c, mule-wnnfns.c, native-gtk-toolbar.c, objects-msw.c, objects-tty.c, objects-x.c, objects.c, objects.h, opaque.c, opaque.h, postgresql.c, postgresql.h, print.c, process-unix.c, process.c, process.h, rangetab.c, rangetab.h, redisplay-gtk.c, redisplay-msw.c, redisplay-output.c, redisplay-tty.c, redisplay-x.c, redisplay.c, scrollbar-gtk.c, scrollbar-msw.c, scrollbar-x.c, scrollbar.c, scrollbar.h, search.c, select-gtk.c, select-x.c, sound.c, specifier.c, specifier.h, strftime.c, symbols.c, symeval.h, syntax.h, text.c, text.h, toolbar-common.c, toolbar-msw.c, toolbar.c, toolbar.h, tooltalk.c, tooltalk.h, ui-gtk.c, ui-gtk.h, undo.c, vm-limit.c, window.c, window.h: Eliminate XSETFOO. Replace all usages with wrap_foo(). Make symbol->name a Lisp_Object, not Lisp_String *. Eliminate nearly all uses of Lisp_String * in favor of Lisp_Object, and correct macros so most of them favor Lisp_Object. Create new error-behavior ERROR_ME_DEBUG_WARN -- output warnings, but at level `debug' (usually ignored). Use it when instantiating specifiers, so problems can be debugged. Move log-warning-minimum-level into C so that we can optimize ERROR_ME_DEBUG_WARN. Fix warning levels consistent with new definitions. Add default_ and parent fields to char table; not yet implemented. New fun Dynarr_verify(); use for further error checking on Dynarrs. Rearrange code at top of lisp.h in conjunction with dynarr changes. Fix eifree(). Use Eistrings in various places (format_event_object(), where_is_to_char(), and callers thereof) to avoid fixed-size strings buffers. New fun write_eistring(). Reindent and fix GPM code to follow standards. Set default MS Windows font to Lucida Console (same size as Courier New but less interline spacing, so more lines fit). Increase default frame size on Windows to 50 lines. (If that's too big for the workspace, the frame will be shrunk as necessary.) Fix problem with text files with no newlines (). (Change `convert-eol' coding system to use `nil' for autodetect, consistent with make-coding-system.) Correct compile warnings in vm-limit.c. Fix handling of reverse-direction charsets to avoid errors when opening (e.g.) mule-ucs/lisp/reldata/uiso8859-6.el. Recode some object printing methods to use write_fmt_string() instead of a fixed buffer and sprintf. Turn on display of png comments as warnings (level `info'), now that they're unobtrusive. Revamped the sound documentation. Fixed bug in redisplay w.r.t. hscroll/truncation/continuation glyphs causing jumping up and down of the lines, since they're bigger than the line size. (It was seen most obviously when there's a horizontal scroll bar, e.g. do C-h a glyph or something like that.) The problem was that the glyph-contrib-p setting on glyphs was ignored even if it was set properly, which it wasn't until now.
author ben
date Fri, 29 Mar 2002 04:49:13 +0000
parents 79940b592197
children a5954632b187
comparison
equal deleted inserted replaced
792:4e83fdb13eb9 793:e38acbeb1cae
161 /* Non-zero means we're in the process of doing the dump */ 161 /* Non-zero means we're in the process of doing the dump */
162 int purify_flag; 162 int purify_flag;
163 163
164 #ifdef ERROR_CHECK_TYPECHECK 164 #ifdef ERROR_CHECK_TYPECHECK
165 165
166 Error_Behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN; 166 Error_Behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN, ERROR_ME_DEBUG_WARN;
167 167
168 #endif 168 #endif
169 169
170 int 170 int
171 c_readonly (Lisp_Object obj) 171 c_readonly (Lisp_Object obj)
209 { 209 {
210 if (ignore_malloc_warnings) 210 if (ignore_malloc_warnings)
211 return; 211 return;
212 212
213 warn_when_safe 213 warn_when_safe
214 (Qmemory, Qcritical, 214 (Qmemory, Qemergency,
215 "%s\n" 215 "%s\n"
216 "Killing some buffers may delay running out of memory.\n" 216 "Killing some buffers may delay running out of memory.\n"
217 "However, certainly by the time you receive the 95%% warning,\n" 217 "However, certainly by the time you receive the 95%% warning,\n"
218 "you should clean up, kill this Emacs, and start a new one.", 218 "you should clean up, kill this Emacs, and start a new one.",
219 str); 219 str);
345 345
346 346
347 static void * 347 static void *
348 allocate_lisp_storage (Bytecount size) 348 allocate_lisp_storage (Bytecount size)
349 { 349 {
350 return xmalloc (size); 350 void *val = xmalloc (size);
351 /* We don't increment the cons counter anymore. Calling functions do
352 that now because we have two different kinds of cons counters -- one
353 for normal objects, and one for no-see-um conses (and possibly others
354 similar) where the conses are used totally internally, never escape,
355 and are created and then freed and shouldn't logically increment the
356 cons counting. #### (Or perhaps, we should decrement it when an object
357 get freed?) */
358
359 /* But we do now (as of 3-27-02) go and zero out the memory. This is a
360 good thing, as it will guarantee we won't get any intermittent bugs
361 coming from an uninitiated field. The speed loss if unnoticeable,
362 esp. as the object are not large -- large stuff like buffer text and
363 redisplay structures and allocated separately. */
364 memset (val, 0, size);
365 return val;
351 } 366 }
352 367
353 368
354 /* lcrecords are chained together through their "next" field. 369 /* lcrecords are chained together through their "next" field.
355 After doing the mark phase, GC will walk this linked list 370 After doing the mark phase, GC will walk this linked list
893 Lisp_Object val; 908 Lisp_Object val;
894 Lisp_Cons *c; 909 Lisp_Cons *c;
895 910
896 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c); 911 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
897 set_lheader_implementation (&c->lheader, &lrecord_cons); 912 set_lheader_implementation (&c->lheader, &lrecord_cons);
898 XSETCONS (val, c); 913 val = wrap_cons (c);
899 c->car = car; 914 c->car = car;
900 c->cdr = cdr; 915 c->cdr = cdr;
901 return val; 916 return val;
902 } 917 }
903 918
910 Lisp_Object val; 925 Lisp_Object val;
911 Lisp_Cons *c; 926 Lisp_Cons *c;
912 927
913 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c); 928 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
914 set_lheader_implementation (&c->lheader, &lrecord_cons); 929 set_lheader_implementation (&c->lheader, &lrecord_cons);
915 XSETCONS (val, c); 930 val = wrap_cons (c);
916 XCAR (val) = car; 931 XCAR (val) = car;
917 XCDR (val) = cdr; 932 XCDR (val) = cdr;
918 return val; 933 return val;
919 } 934 }
920 935
1017 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000 1032 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1018 1033
1019 Lisp_Object 1034 Lisp_Object
1020 make_float (double float_value) 1035 make_float (double float_value)
1021 { 1036 {
1022 Lisp_Object val;
1023 Lisp_Float *f; 1037 Lisp_Float *f;
1024 1038
1025 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f); 1039 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f);
1026 1040
1027 /* Avoid dump-time `uninitialized memory read' purify warnings. */ 1041 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1028 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f)) 1042 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
1029 xzero (*f); 1043 xzero (*f);
1030 1044
1031 set_lheader_implementation (&f->lheader, &lrecord_float); 1045 set_lheader_implementation (&f->lheader, &lrecord_float);
1032 float_data (f) = float_value; 1046 float_data (f) = float_value;
1033 XSETFLOAT (val, f); 1047 return wrap_float (f);
1034 return val;
1035 } 1048 }
1036 1049
1037 #endif /* LISP_FLOAT_TYPE */ 1050 #endif /* LISP_FLOAT_TYPE */
1038 1051
1039 1052
1119 Lisp_Object *p = vector_data (vecp); 1132 Lisp_Object *p = vector_data (vecp);
1120 1133
1121 while (length--) 1134 while (length--)
1122 *p++ = object; 1135 *p++ = object;
1123 1136
1124 { 1137 return wrap_vector (vecp);
1125 Lisp_Object vector;
1126 XSETVECTOR (vector, vecp);
1127 return vector;
1128 }
1129 } 1138 }
1130 1139
1131 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /* 1140 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1132 Return a new vector of length LENGTH, with each element being OBJECT. 1141 Return a new vector of length LENGTH, with each element being OBJECT.
1133 See also the function `vector'. 1142 See also the function `vector'.
1148 Lisp_Object *p = vector_data (vecp); 1157 Lisp_Object *p = vector_data (vecp);
1149 1158
1150 while (nargs--) 1159 while (nargs--)
1151 *p++ = *args++; 1160 *p++ = *args++;
1152 1161
1153 { 1162 return wrap_vector (vecp);
1154 Lisp_Object vector;
1155 XSETVECTOR (vector, vecp);
1156 return vector;
1157 }
1158 } 1163 }
1159 1164
1160 Lisp_Object 1165 Lisp_Object
1161 vector1 (Lisp_Object obj0) 1166 vector1 (Lisp_Object obj0)
1162 { 1167 {
1279 bit_vector_length (p) = sizei; 1284 bit_vector_length (p) = sizei;
1280 bit_vector_next (p) = all_bit_vectors; 1285 bit_vector_next (p) = all_bit_vectors;
1281 /* make sure the extra bits in the last long are 0; the calling 1286 /* make sure the extra bits in the last long are 0; the calling
1282 functions might not set them. */ 1287 functions might not set them. */
1283 p->bits[num_longs - 1] = 0; 1288 p->bits[num_longs - 1] = 0;
1284 XSETBIT_VECTOR (all_bit_vectors, p); 1289 all_bit_vectors = wrap_bit_vector (p);
1285 return p; 1290 return p;
1286 } 1291 }
1287 1292
1288 Lisp_Object 1293 Lisp_Object
1289 make_bit_vector (Elemcount length, Lisp_Object bit) 1294 make_bit_vector (Elemcount length, Lisp_Object bit)
1303 last long are 0, so that equal/hash is easy. */ 1308 last long are 0, so that equal/hash is easy. */
1304 if (bits_in_last) 1309 if (bits_in_last)
1305 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1; 1310 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1306 } 1311 }
1307 1312
1308 { 1313 return wrap_bit_vector (p);
1309 Lisp_Object bit_vector;
1310 XSETBIT_VECTOR (bit_vector, p);
1311 return bit_vector;
1312 }
1313 } 1314 }
1314 1315
1315 Lisp_Object 1316 Lisp_Object
1316 make_bit_vector_from_byte_vector (unsigned char *bytevec, Elemcount length) 1317 make_bit_vector_from_byte_vector (unsigned char *bytevec, Elemcount length)
1317 { 1318 {
1319 Lisp_Bit_Vector *p = make_bit_vector_internal (length); 1320 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1320 1321
1321 for (i = 0; i < length; i++) 1322 for (i = 0; i < length; i++)
1322 set_bit_vector_bit (p, i, bytevec[i]); 1323 set_bit_vector_bit (p, i, bytevec[i]);
1323 1324
1324 { 1325 return wrap_bit_vector (p);
1325 Lisp_Object bit_vector;
1326 XSETBIT_VECTOR (bit_vector, p);
1327 return bit_vector;
1328 }
1329 } 1326 }
1330 1327
1331 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /* 1328 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1332 Return a new bit vector of length LENGTH. with each bit set to BIT. 1329 Return a new bit vector of length LENGTH. with each bit set to BIT.
1333 BIT must be one of the integers 0 or 1. See also the function `bit-vector'. 1330 BIT must be one of the integers 0 or 1. See also the function `bit-vector'.
1353 { 1350 {
1354 CHECK_BIT (args[i]); 1351 CHECK_BIT (args[i]);
1355 set_bit_vector_bit (p, i, !ZEROP (args[i])); 1352 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1356 } 1353 }
1357 1354
1358 { 1355 return wrap_bit_vector (p);
1359 Lisp_Object bit_vector;
1360 XSETBIT_VECTOR (bit_vector, p);
1361 return bit_vector;
1362 }
1363 } 1356 }
1364 1357
1365 1358
1366 /************************************************************************/ 1359 /************************************************************************/
1367 /* Compiled-function allocation */ 1360 /* Compiled-function allocation */
1372 1365
1373 static Lisp_Object 1366 static Lisp_Object
1374 make_compiled_function (void) 1367 make_compiled_function (void)
1375 { 1368 {
1376 Lisp_Compiled_Function *f; 1369 Lisp_Compiled_Function *f;
1377 Lisp_Object fun;
1378 1370
1379 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f); 1371 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1380 set_lheader_implementation (&f->lheader, &lrecord_compiled_function); 1372 set_lheader_implementation (&f->lheader, &lrecord_compiled_function);
1381 1373
1382 f->stack_depth = 0; 1374 f->stack_depth = 0;
1389 f->arglist = Qnil; 1381 f->arglist = Qnil;
1390 f->doc_and_interactive = Qnil; 1382 f->doc_and_interactive = Qnil;
1391 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK 1383 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1392 f->annotated = Qnil; 1384 f->annotated = Qnil;
1393 #endif 1385 #endif
1394 XSETCOMPILED_FUNCTION (fun, f); 1386 return wrap_compiled_function (f);
1395 return fun;
1396 } 1387 }
1397 1388
1398 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /* 1389 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1399 Return a new compiled-function object. 1390 Return a new compiled-function object.
1400 Usage: (arglist instructions constants stack-depth 1391 Usage: (arglist instructions constants stack-depth
1515 Return a newly allocated uninterned symbol whose name is NAME. 1506 Return a newly allocated uninterned symbol whose name is NAME.
1516 Its value and function definition are void, and its property list is nil. 1507 Its value and function definition are void, and its property list is nil.
1517 */ 1508 */
1518 (name)) 1509 (name))
1519 { 1510 {
1520 Lisp_Object val;
1521 Lisp_Symbol *p; 1511 Lisp_Symbol *p;
1522 1512
1523 CHECK_STRING (name); 1513 CHECK_STRING (name);
1524 1514
1525 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p); 1515 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1526 set_lheader_implementation (&p->lheader, &lrecord_symbol); 1516 set_lheader_implementation (&p->lheader, &lrecord_symbol);
1527 p->name = XSTRING (name); 1517 p->name = name;
1528 p->plist = Qnil; 1518 p->plist = Qnil;
1529 p->value = Qunbound; 1519 p->value = Qunbound;
1530 p->function = Qunbound; 1520 p->function = Qunbound;
1531 symbol_next (p) = 0; 1521 symbol_next (p) = 0;
1532 XSETSYMBOL (val, p); 1522 return wrap_symbol (p);
1533 return val;
1534 } 1523 }
1535 1524
1536 1525
1537 /************************************************************************/ 1526 /************************************************************************/
1538 /* Extent allocation */ 1527 /* Extent allocation */
1571 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000 1560 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1572 1561
1573 Lisp_Object 1562 Lisp_Object
1574 allocate_event (void) 1563 allocate_event (void)
1575 { 1564 {
1576 Lisp_Object val;
1577 Lisp_Event *e; 1565 Lisp_Event *e;
1578 1566
1579 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e); 1567 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1580 set_lheader_implementation (&e->lheader, &lrecord_event); 1568 set_lheader_implementation (&e->lheader, &lrecord_event);
1581 1569
1582 XSETEVENT (val, e); 1570 return wrap_event (e);
1583 return val;
1584 } 1571 }
1585 1572
1586 1573
1587 /************************************************************************/ 1574 /************************************************************************/
1588 /* Marker allocation */ 1575 /* Marker allocation */
1594 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /* 1581 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1595 Return a new marker which does not point at any place. 1582 Return a new marker which does not point at any place.
1596 */ 1583 */
1597 ()) 1584 ())
1598 { 1585 {
1599 Lisp_Object val;
1600 Lisp_Marker *p; 1586 Lisp_Marker *p;
1601 1587
1602 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p); 1588 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1603 set_lheader_implementation (&p->lheader, &lrecord_marker); 1589 set_lheader_implementation (&p->lheader, &lrecord_marker);
1604 p->buffer = 0; 1590 p->buffer = 0;
1605 p->membpos = 0; 1591 p->membpos = 0;
1606 marker_next (p) = 0; 1592 marker_next (p) = 0;
1607 marker_prev (p) = 0; 1593 marker_prev (p) = 0;
1608 p->insertion_type = 0; 1594 p->insertion_type = 0;
1609 XSETMARKER (val, p); 1595 return wrap_marker (p);
1610 return val;
1611 } 1596 }
1612 1597
1613 Lisp_Object 1598 Lisp_Object
1614 noseeum_make_marker (void) 1599 noseeum_make_marker (void)
1615 { 1600 {
1616 Lisp_Object val;
1617 Lisp_Marker *p; 1601 Lisp_Marker *p;
1618 1602
1619 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p); 1603 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1620 set_lheader_implementation (&p->lheader, &lrecord_marker); 1604 set_lheader_implementation (&p->lheader, &lrecord_marker);
1621 p->buffer = 0; 1605 p->buffer = 0;
1622 p->membpos = 0; 1606 p->membpos = 0;
1623 marker_next (p) = 0; 1607 marker_next (p) = 0;
1624 marker_prev (p) = 0; 1608 marker_prev (p) = 0;
1625 p->insertion_type = 0; 1609 p->insertion_type = 0;
1626 XSETMARKER (val, p); 1610 return wrap_marker (p);
1627 return val;
1628 } 1611 }
1629 1612
1630 1613
1631 /************************************************************************/ 1614 /************************************************************************/
1632 /* String allocation */ 1615 /* String allocation */
1651 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000 1634 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1652 1635
1653 static Lisp_Object 1636 static Lisp_Object
1654 mark_string (Lisp_Object obj) 1637 mark_string (Lisp_Object obj)
1655 { 1638 {
1656 Lisp_String *ptr = XSTRING (obj); 1639 if (CONSP (XSTRING_PLIST (obj)) && EXTENT_INFOP (XCAR (XSTRING_PLIST (obj))))
1657 1640 flush_cached_extent_info (XCAR (XSTRING_PLIST (obj)));
1658 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist))) 1641 return XSTRING_PLIST (obj);
1659 flush_cached_extent_info (XCAR (ptr->plist));
1660 return ptr->plist;
1661 } 1642 }
1662 1643
1663 static int 1644 static int
1664 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) 1645 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1665 { 1646 {
1667 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) && 1648 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1668 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len)); 1649 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1669 } 1650 }
1670 1651
1671 static const struct lrecord_description string_description[] = { 1652 static const struct lrecord_description string_description[] = {
1672 { XD_BYTECOUNT, offsetof (Lisp_String, size) }, 1653 { XD_BYTECOUNT, offsetof (Lisp_String, size_) },
1673 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) }, 1654 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data_), XD_INDIRECT(0, 1) },
1674 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) }, 1655 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
1675 { XD_END } 1656 { XD_END }
1676 }; 1657 };
1677 1658
1678 /* We store the string's extent info as the first element of the string's 1659 /* We store the string's extent info as the first element of the string's
1686 #### This means you can't use an int as a key in a string's plist. */ 1667 #### This means you can't use an int as a key in a string's plist. */
1687 1668
1688 static Lisp_Object * 1669 static Lisp_Object *
1689 string_plist_ptr (Lisp_Object string) 1670 string_plist_ptr (Lisp_Object string)
1690 { 1671 {
1691 Lisp_Object *ptr = &XSTRING (string)->plist; 1672 Lisp_Object *ptr = &XSTRING_PLIST (string);
1692 1673
1693 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr))) 1674 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
1694 ptr = &XCDR (*ptr); 1675 ptr = &XCDR (*ptr);
1695 if (CONSP (*ptr) && INTP (XCAR (*ptr))) 1676 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
1696 ptr = &XCDR (*ptr); 1677 ptr = &XCDR (*ptr);
1791 first_string_chars_block->pos = 0; 1772 first_string_chars_block->pos = 0;
1792 current_string_chars_block = first_string_chars_block; 1773 current_string_chars_block = first_string_chars_block;
1793 } 1774 }
1794 1775
1795 static struct string_chars * 1776 static struct string_chars *
1796 allocate_string_chars_struct (Lisp_String *string_it_goes_with, 1777 allocate_string_chars_struct (Lisp_Object string_it_goes_with,
1797 EMACS_INT fullsize) 1778 EMACS_INT fullsize)
1798 { 1779 {
1799 struct string_chars *s_chars; 1780 struct string_chars *s_chars;
1800 1781
1801 if (fullsize <= 1782 if (fullsize <=
1820 new_scb->pos = fullsize; 1801 new_scb->pos = fullsize;
1821 s_chars = (struct string_chars *) 1802 s_chars = (struct string_chars *)
1822 current_string_chars_block->string_chars; 1803 current_string_chars_block->string_chars;
1823 } 1804 }
1824 1805
1825 s_chars->string = string_it_goes_with; 1806 s_chars->string = XSTRING (string_it_goes_with);
1826 1807
1827 INCREMENT_CONS_COUNTER (fullsize, "string chars"); 1808 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1828 1809
1829 return s_chars; 1810 return s_chars;
1830 } 1811 }
1847 (Bytecount) MAX_STRING_ASCII_BEGIN)); 1828 (Bytecount) MAX_STRING_ASCII_BEGIN));
1848 } 1829 }
1849 #endif 1830 #endif
1850 1831
1851 /* You do NOT want to be calling this! (And if you do, you must call 1832 /* You do NOT want to be calling this! (And if you do, you must call
1852 set_string_ascii_begin() after modifying the string.) Use alloca() 1833 XSET_STRING_ASCII_BEGIN() after modifying the string.) Use alloca()
1853 instead and then call make_string() like the rest of the world. */ 1834 instead and then call make_string() like the rest of the world. */
1854 1835
1855 Lisp_Object 1836 Lisp_Object
1856 make_uninit_string (Bytecount length) 1837 make_uninit_string (Bytecount length)
1857 { 1838 {
1858 Lisp_String *s; 1839 Lisp_String *s;
1859 EMACS_INT fullsize = STRING_FULLSIZE (length); 1840 EMACS_INT fullsize = STRING_FULLSIZE (length);
1860 Lisp_Object val;
1861 1841
1862 assert (length >= 0 && fullsize > 0); 1842 assert (length >= 0 && fullsize > 0);
1863 1843
1864 /* Allocate the string header */ 1844 /* Allocate the string header */
1865 ALLOCATE_FIXED_TYPE (string, Lisp_String, s); 1845 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
1846 xzero (*s);
1866 set_lheader_implementation (&s->u.lheader, &lrecord_string); 1847 set_lheader_implementation (&s->u.lheader, &lrecord_string);
1867 1848
1868 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize) 1849 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
1869 ? xnew_array (Intbyte, length + 1) 1850 ? xnew_array (Intbyte, length + 1)
1870 : allocate_string_chars_struct (s, fullsize)->chars); 1851 : allocate_string_chars_struct (wrap_string (s),
1852 fullsize)->chars);
1871 1853
1872 set_string_length (s, length); 1854 set_string_length (s, length);
1873 s->plist = Qnil; 1855 s->plist = Qnil;
1874 set_string_ascii_begin (s, 0); 1856 set_string_byte (wrap_string (s), length, 0);
1875 1857
1876 set_string_byte (s, length, 0); 1858 return wrap_string (s);
1877
1878 XSETSTRING (val, s);
1879 return val;
1880 } 1859 }
1881 1860
1882 #ifdef VERIFY_STRING_CHARS_INTEGRITY 1861 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1883 static void verify_string_chars_integrity (void); 1862 static void verify_string_chars_integrity (void);
1884 #endif 1863 #endif
1888 POS < 0, resize the string but don't copy any characters. Use 1867 POS < 0, resize the string but don't copy any characters. Use
1889 this if you're planning on completely overwriting the string. 1868 this if you're planning on completely overwriting the string.
1890 */ 1869 */
1891 1870
1892 void 1871 void
1893 resize_string (Lisp_String *s, Bytecount pos, Bytecount delta) 1872 resize_string (Lisp_Object s, Bytecount pos, Bytecount delta)
1894 { 1873 {
1895 Bytecount oldfullsize, newfullsize; 1874 Bytecount oldfullsize, newfullsize;
1896 #ifdef VERIFY_STRING_CHARS_INTEGRITY 1875 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1897 verify_string_chars_integrity (); 1876 verify_string_chars_integrity ();
1898 #endif 1877 #endif
1899 1878
1900 #ifdef ERROR_CHECK_CHARBPOS 1879 #ifdef ERROR_CHECK_CHARBPOS
1901 if (pos >= 0) 1880 if (pos >= 0)
1902 { 1881 {
1903 assert (pos <= string_length (s)); 1882 assert (pos <= XSTRING_LENGTH (s));
1904 if (delta < 0) 1883 if (delta < 0)
1905 assert (pos + (-delta) <= string_length (s)); 1884 assert (pos + (-delta) <= XSTRING_LENGTH (s));
1906 } 1885 }
1907 else 1886 else
1908 { 1887 {
1909 if (delta < 0) 1888 if (delta < 0)
1910 assert ((-delta) <= string_length (s)); 1889 assert ((-delta) <= XSTRING_LENGTH (s));
1911 } 1890 }
1912 #endif /* ERROR_CHECK_CHARBPOS */ 1891 #endif /* ERROR_CHECK_CHARBPOS */
1913 1892
1914 if (delta == 0) 1893 if (delta == 0)
1915 /* simplest case: no size change. */ 1894 /* simplest case: no size change. */
1919 /* If DELTA < 0, the functions below will delete the characters 1898 /* If DELTA < 0, the functions below will delete the characters
1920 before POS. We want to delete characters *after* POS, however, 1899 before POS. We want to delete characters *after* POS, however,
1921 so convert this to the appropriate form. */ 1900 so convert this to the appropriate form. */
1922 pos += -delta; 1901 pos += -delta;
1923 1902
1924 oldfullsize = STRING_FULLSIZE (string_length (s)); 1903 oldfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s));
1925 newfullsize = STRING_FULLSIZE (string_length (s) + delta); 1904 newfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s) + delta);
1926 1905
1927 if (BIG_STRING_FULLSIZE_P (oldfullsize)) 1906 if (BIG_STRING_FULLSIZE_P (oldfullsize))
1928 { 1907 {
1929 if (BIG_STRING_FULLSIZE_P (newfullsize)) 1908 if (BIG_STRING_FULLSIZE_P (newfullsize))
1930 { 1909 {
1931 /* Both strings are big. We can just realloc(). 1910 /* Both strings are big. We can just realloc().
1932 But careful! If the string is shrinking, we have to 1911 But careful! If the string is shrinking, we have to
1933 memmove() _before_ realloc(), and if growing, we have to 1912 memmove() _before_ realloc(), and if growing, we have to
1934 memmove() _after_ realloc() - otherwise the access is 1913 memmove() _after_ realloc() - otherwise the access is
1935 illegal, and we might crash. */ 1914 illegal, and we might crash. */
1936 Bytecount len = string_length (s) + 1 - pos; 1915 Bytecount len = XSTRING_LENGTH (s) + 1 - pos;
1937 1916
1938 if (delta < 0 && pos >= 0) 1917 if (delta < 0 && pos >= 0)
1939 memmove (string_data (s) + pos + delta, string_data (s) + pos, len); 1918 memmove (XSTRING_DATA (s) + pos + delta,
1940 set_string_data (s, (Intbyte *) xrealloc (string_data (s), 1919 XSTRING_DATA (s) + pos, len);
1941 string_length (s) + delta + 1)); 1920 XSET_STRING_DATA
1921 (s, (Intbyte *) xrealloc (XSTRING_DATA (s),
1922 XSTRING_LENGTH (s) + delta + 1));
1942 if (delta > 0 && pos >= 0) 1923 if (delta > 0 && pos >= 0)
1943 memmove (string_data (s) + pos + delta, string_data (s) + pos, len); 1924 memmove (XSTRING_DATA (s) + pos + delta, XSTRING_DATA (s) + pos,
1925 len);
1944 } 1926 }
1945 else /* String has been demoted from BIG_STRING. */ 1927 else /* String has been demoted from BIG_STRING. */
1946 { 1928 {
1947 Intbyte *new_data = 1929 Intbyte *new_data =
1948 allocate_string_chars_struct (s, newfullsize)->chars; 1930 allocate_string_chars_struct (s, newfullsize)->chars;
1949 Intbyte *old_data = string_data (s); 1931 Intbyte *old_data = XSTRING_DATA (s);
1950 1932
1951 if (pos >= 0) 1933 if (pos >= 0)
1952 { 1934 {
1953 memcpy (new_data, old_data, pos); 1935 memcpy (new_data, old_data, pos);
1954 memcpy (new_data + pos + delta, old_data + pos, 1936 memcpy (new_data + pos + delta, old_data + pos,
1955 string_length (s) + 1 - pos); 1937 XSTRING_LENGTH (s) + 1 - pos);
1956 } 1938 }
1957 set_string_data (s, new_data); 1939 XSET_STRING_DATA (s, new_data);
1958 xfree (old_data); 1940 xfree (old_data);
1959 } 1941 }
1960 } 1942 }
1961 else /* old string is small */ 1943 else /* old string is small */
1962 { 1944 {
1967 somewhere depends on there not being any unused 1949 somewhere depends on there not being any unused
1968 allocation space, modulo any alignment 1950 allocation space, modulo any alignment
1969 constraints). */ 1951 constraints). */
1970 if (pos >= 0) 1952 if (pos >= 0)
1971 { 1953 {
1972 Intbyte *addroff = pos + string_data (s); 1954 Intbyte *addroff = pos + XSTRING_DATA (s);
1973 1955
1974 memmove (addroff + delta, addroff, 1956 memmove (addroff + delta, addroff,
1975 /* +1 due to zero-termination. */ 1957 /* +1 due to zero-termination. */
1976 string_length (s) + 1 - pos); 1958 XSTRING_LENGTH (s) + 1 - pos);
1977 } 1959 }
1978 } 1960 }
1979 else 1961 else
1980 { 1962 {
1981 Intbyte *old_data = string_data (s); 1963 Intbyte *old_data = XSTRING_DATA (s);
1982 Intbyte *new_data = 1964 Intbyte *new_data =
1983 BIG_STRING_FULLSIZE_P (newfullsize) 1965 BIG_STRING_FULLSIZE_P (newfullsize)
1984 ? xnew_array (Intbyte, string_length (s) + delta + 1) 1966 ? xnew_array (Intbyte, XSTRING_LENGTH (s) + delta + 1)
1985 : allocate_string_chars_struct (s, newfullsize)->chars; 1967 : allocate_string_chars_struct (s, newfullsize)->chars;
1986 1968
1987 if (pos >= 0) 1969 if (pos >= 0)
1988 { 1970 {
1989 memcpy (new_data, old_data, pos); 1971 memcpy (new_data, old_data, pos);
1990 memcpy (new_data + pos + delta, old_data + pos, 1972 memcpy (new_data + pos + delta, old_data + pos,
1991 string_length (s) + 1 - pos); 1973 XSTRING_LENGTH (s) + 1 - pos);
1992 } 1974 }
1993 set_string_data (s, new_data); 1975 XSET_STRING_DATA (s, new_data);
1994 1976
1995 { 1977 {
1996 /* We need to mark this chunk of the string_chars_block 1978 /* We need to mark this chunk of the string_chars_block
1997 as unused so that compact_string_chars() doesn't 1979 as unused so that compact_string_chars() doesn't
1998 freak. */ 1980 freak. */
1999 struct string_chars *old_s_chars = (struct string_chars *) 1981 struct string_chars *old_s_chars = (struct string_chars *)
2000 ((char *) old_data - offsetof (struct string_chars, chars)); 1982 ((char *) old_data - offsetof (struct string_chars, chars));
2001 /* Sanity check to make sure we aren't hosed by strange 1983 /* Sanity check to make sure we aren't hosed by strange
2002 alignment/padding. */ 1984 alignment/padding. */
2003 assert (old_s_chars->string == s); 1985 assert (old_s_chars->string == XSTRING (s));
2004 MARK_STRING_CHARS_AS_FREE (old_s_chars); 1986 MARK_STRING_CHARS_AS_FREE (old_s_chars);
2005 ((struct unused_string_chars *) old_s_chars)->fullsize = 1987 ((struct unused_string_chars *) old_s_chars)->fullsize =
2006 oldfullsize; 1988 oldfullsize;
2007 } 1989 }
2008 } 1990 }
2009 } 1991 }
2010 1992
2011 set_string_length (s, string_length (s) + delta); 1993 XSET_STRING_LENGTH (s, XSTRING_LENGTH (s) + delta);
2012 /* If pos < 0, the string won't be zero-terminated. 1994 /* If pos < 0, the string won't be zero-terminated.
2013 Terminate now just to make sure. */ 1995 Terminate now just to make sure. */
2014 string_data (s)[string_length (s)] = '\0'; 1996 XSTRING_DATA (s)[XSTRING_LENGTH (s)] = '\0';
2015 1997
2016 if (pos >= 0) 1998 if (pos >= 0)
2017 { 1999 /* We also have to adjust all of the extent indices after the
2018 Lisp_Object string; 2000 place we did the change. We say "pos - 1" because
2019 2001 adjust_extents() is exclusive of the starting position
2020 XSETSTRING (string, s); 2002 passed to it. */
2021 /* We also have to adjust all of the extent indices after the 2003 adjust_extents (s, pos - 1, XSTRING_LENGTH (s), delta);
2022 place we did the change. We say "pos - 1" because
2023 adjust_extents() is exclusive of the starting position
2024 passed to it. */
2025 adjust_extents (string, pos - 1, string_length (s),
2026 delta);
2027 }
2028 2004
2029 #ifdef VERIFY_STRING_CHARS_INTEGRITY 2005 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2030 verify_string_chars_integrity (); 2006 verify_string_chars_integrity ();
2031 #endif 2007 #endif
2032 } 2008 }
2034 #ifdef MULE 2010 #ifdef MULE
2035 2011
2036 /* WARNING: If you modify an existing string, you must call 2012 /* WARNING: If you modify an existing string, you must call
2037 CHECK_LISP_WRITEABLE() before and bump_string_modiff() afterwards. */ 2013 CHECK_LISP_WRITEABLE() before and bump_string_modiff() afterwards. */
2038 void 2014 void
2039 set_string_char (Lisp_String *s, Charcount i, Emchar c) 2015 set_string_char (Lisp_Object s, Charcount i, Emchar c)
2040 { 2016 {
2041 Intbyte newstr[MAX_EMCHAR_LEN]; 2017 Intbyte newstr[MAX_EMCHAR_LEN];
2042 Bytecount bytoff = string_index_char_to_byte (s, i); 2018 Bytecount bytoff = string_index_char_to_byte (s, i);
2043 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1); 2019 Bytecount oldlen = charcount_to_bytecount (XSTRING_DATA (s) + bytoff, 1);
2044 Bytecount newlen = set_charptr_emchar (newstr, c); 2020 Bytecount newlen = set_charptr_emchar (newstr, c);
2045 2021
2046 sledgehammer_check_ascii_begin (wrap_string (s)); 2022 sledgehammer_check_ascii_begin (s);
2047 if (oldlen != newlen) 2023 if (oldlen != newlen)
2048 resize_string (s, bytoff, newlen - oldlen); 2024 resize_string (s, bytoff, newlen - oldlen);
2049 /* Remember, string_data (s) might have changed so we can't cache it. */ 2025 /* Remember, XSTRING_DATA (s) might have changed so we can't cache it. */
2050 memcpy (string_data (s) + bytoff, newstr, newlen); 2026 memcpy (XSTRING_DATA (s) + bytoff, newstr, newlen);
2051 if (oldlen != newlen) 2027 if (oldlen != newlen)
2052 { 2028 {
2053 if (newlen > 1 && i <= (Charcount) string_ascii_begin (s)) 2029 if (newlen > 1 && i <= (Charcount) XSTRING_ASCII_BEGIN (s))
2054 /* Everything starting with the new char is no longer part of 2030 /* Everything starting with the new char is no longer part of
2055 ascii_begin */ 2031 ascii_begin */
2056 set_string_ascii_begin (s, i); 2032 XSET_STRING_ASCII_BEGIN (s, i);
2057 else if (newlen == 1 && i == (Charcount) string_ascii_begin (s)) 2033 else if (newlen == 1 && i == (Charcount) XSTRING_ASCII_BEGIN (s))
2058 /* We've extended ascii_begin, and we have to figure out how much by */ 2034 /* We've extended ascii_begin, and we have to figure out how much by */
2059 { 2035 {
2060 Bytecount j; 2036 Bytecount j;
2061 for (j = i + 1; j < string_length (s); j++) 2037 for (j = i + 1; j < XSTRING_LENGTH (s); j++)
2062 { 2038 {
2063 if (!BYTE_ASCII_P (string_data (s)[j])) 2039 if (!BYTE_ASCII_P (XSTRING_DATA (s)[j]))
2064 break; 2040 break;
2065 } 2041 }
2066 set_string_ascii_begin (s, min (j, MAX_STRING_ASCII_BEGIN)); 2042 XSET_STRING_ASCII_BEGIN (s, min (j, MAX_STRING_ASCII_BEGIN));
2067 } 2043 }
2068 } 2044 }
2069 sledgehammer_check_ascii_begin (wrap_string (s)); 2045 sledgehammer_check_ascii_begin (s);
2070 } 2046 }
2071 2047
2072 #endif /* MULE */ 2048 #endif /* MULE */
2073 2049
2074 DEFUN ("make-string", Fmake_string, 2, 2, 0, /* 2050 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2086 2062
2087 if (len == 1) 2063 if (len == 1)
2088 { 2064 {
2089 /* Optimize the single-byte case */ 2065 /* Optimize the single-byte case */
2090 memset (XSTRING_DATA (val), XCHAR (character), XSTRING_LENGTH (val)); 2066 memset (XSTRING_DATA (val), XCHAR (character), XSTRING_LENGTH (val));
2091 set_string_ascii_begin (XSTRING (val), min (MAX_STRING_ASCII_BEGIN, 2067 XSET_STRING_ASCII_BEGIN (val, min (MAX_STRING_ASCII_BEGIN,
2092 len * XINT (length))); 2068 len * XINT (length)));
2093 } 2069 }
2094 else 2070 else
2095 { 2071 {
2096 EMACS_INT i; 2072 EMACS_INT i;
2097 Intbyte *ptr = XSTRING_DATA (val); 2073 Intbyte *ptr = XSTRING_DATA (val);
2143 for (i = 0; i < length; i++) 2119 for (i = 0; i < length; i++)
2144 { 2120 {
2145 if (!BYTE_ASCII_P (contents[i])) 2121 if (!BYTE_ASCII_P (contents[i]))
2146 break; 2122 break;
2147 } 2123 }
2148 set_string_ascii_begin (XSTRING (string), min (i, MAX_STRING_ASCII_BEGIN)); 2124 XSET_STRING_ASCII_BEGIN (string, min (i, MAX_STRING_ASCII_BEGIN));
2149 #else 2125 #else
2150 set_string_ascii_begin (XSTRING (string), min (XSTRING_LENGTH (string), 2126 XSET_STRING_ASCII_BEGIN (string, min (XSTRING_LENGTH (string),
2151 MAX_STRING_ASCII_BEGIN)); 2127 MAX_STRING_ASCII_BEGIN));
2152 #endif 2128 #endif
2153 sledgehammer_check_ascii_begin (string); 2129 sledgehammer_check_ascii_begin (string);
2154 } 2130 }
2155 2131
2156 /* Take some raw memory, which MUST already be in internal format, 2132 /* Take some raw memory, which MUST already be in internal format,
2235 set_lheader_implementation (&s->u.lheader, &lrecord_string); 2211 set_lheader_implementation (&s->u.lheader, &lrecord_string);
2236 SET_C_READONLY_RECORD_HEADER (&s->u.lheader); 2212 SET_C_READONLY_RECORD_HEADER (&s->u.lheader);
2237 s->plist = Qnil; 2213 s->plist = Qnil;
2238 set_string_data (s, (Intbyte *) contents); 2214 set_string_data (s, (Intbyte *) contents);
2239 set_string_length (s, length); 2215 set_string_length (s, length);
2240 XSETSTRING (val, s); 2216 val = wrap_string (s);
2241 init_string_ascii_begin (val); 2217 init_string_ascii_begin (val);
2242 sledgehammer_check_ascii_begin (val); 2218 sledgehammer_check_ascii_begin (val);
2243 2219
2244 return val; 2220 return val;
2245 } 2221 }
2323 { 2299 {
2324 struct lcrecord_list *p = 2300 struct lcrecord_list *p =
2325 /* Avoid infinite recursion allocating this */ 2301 /* Avoid infinite recursion allocating this */
2326 alloc_unmanaged_lcrecord_type (struct lcrecord_list, 2302 alloc_unmanaged_lcrecord_type (struct lcrecord_list,
2327 &lrecord_lcrecord_list); 2303 &lrecord_lcrecord_list);
2328 Lisp_Object val;
2329 2304
2330 p->implementation = implementation; 2305 p->implementation = implementation;
2331 p->size = size; 2306 p->size = size;
2332 p->free = Qnil; 2307 p->free = Qnil;
2333 XSETLCRECORD_LIST (val, p); 2308 return wrap_lcrecord_list (p);
2334 return val;
2335 } 2309 }
2336 2310
2337 Lisp_Object 2311 Lisp_Object
2338 allocate_managed_lcrecord (Lisp_Object lcrecord_list) 2312 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2339 { 2313 {
2363 list->free = free_header->chain; 2337 list->free = free_header->chain;
2364 free_header->lcheader.free = 0; 2338 free_header->lcheader.free = 0;
2365 return val; 2339 return val;
2366 } 2340 }
2367 else 2341 else
2368 { 2342 return wrap_pointer_1 (alloc_lcrecord (list->size, list->implementation));
2369 Lisp_Object val;
2370
2371 XSETOBJ (val, alloc_lcrecord (list->size, list->implementation));
2372 return val;
2373 }
2374 } 2343 }
2375 2344
2376 /* "Free" a Lisp object LCRECORD by placing it on its associated free list 2345 /* "Free" a Lisp object LCRECORD by placing it on its associated free list
2377 LCRECORD_LIST; next time allocate_managed_lcrecord() is called with the 2346 LCRECORD_LIST; next time allocate_managed_lcrecord() is called with the
2378 same LCRECORD_LIST as its parameter, it will return an object from the 2347 same LCRECORD_LIST as its parameter, it will return an object from the
3076 sweep_markers (void) 3045 sweep_markers (void)
3077 { 3046 {
3078 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) 3047 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3079 #define ADDITIONAL_FREE_marker(ptr) \ 3048 #define ADDITIONAL_FREE_marker(ptr) \
3080 do { Lisp_Object tem; \ 3049 do { Lisp_Object tem; \
3081 XSETMARKER (tem, ptr); \ 3050 tem = wrap_marker (ptr); \
3082 unchain_marker (tem); \ 3051 unchain_marker (tem); \
3083 } while (0) 3052 } while (0)
3084 3053
3085 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker); 3054 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
3086 } 3055 }
3131 3100
3132 string = s_chars->string; 3101 string = s_chars->string;
3133 /* Must be 32-bit aligned. */ 3102 /* Must be 32-bit aligned. */
3134 assert ((((int) string) & 3) == 0); 3103 assert ((((int) string) & 3) == 0);
3135 3104
3136 size = string_length (string); 3105 size = string->size_;
3137 fullsize = STRING_FULLSIZE (size); 3106 fullsize = STRING_FULLSIZE (size);
3138 3107
3139 assert (!BIG_STRING_FULLSIZE_P (fullsize)); 3108 assert (!BIG_STRING_FULLSIZE_P (fullsize));
3140 assert (string_data (string) == s_chars->chars); 3109 assert (string->data_ == s_chars->chars);
3141 pos += fullsize; 3110 pos += fullsize;
3142 } 3111 }
3143 assert (pos == sb->pos); 3112 assert (pos == sb->pos);
3144 } 3113 }
3145 } 3114 }
3186 } 3155 }
3187 3156
3188 string = from_s_chars->string; 3157 string = from_s_chars->string;
3189 assert (!(LRECORD_FREE_P (string))); 3158 assert (!(LRECORD_FREE_P (string)));
3190 3159
3191 size = string_length (string); 3160 size = string->size_;
3192 fullsize = STRING_FULLSIZE (size); 3161 fullsize = STRING_FULLSIZE (size);
3193 3162
3194 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize)); 3163 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
3195 3164
3196 /* Just skip it if it isn't marked. */ 3165 /* Just skip it if it isn't marked. */
3247 3216
3248 #if 1 /* Hack to debug missing purecopy's */ 3217 #if 1 /* Hack to debug missing purecopy's */
3249 static int debug_string_purity; 3218 static int debug_string_purity;
3250 3219
3251 static void 3220 static void
3252 debug_string_purity_print (Lisp_String *p) 3221 debug_string_purity_print (Lisp_Object p)
3253 { 3222 {
3254 Charcount i; 3223 Charcount i;
3255 Charcount s = string_char_length (p); 3224 Charcount s = XSTRING_CHAR_LENGTH (p);
3256 stderr_out ("\""); 3225 stderr_out ("\"");
3257 for (i = 0; i < s; i++) 3226 for (i = 0; i < s; i++)
3258 { 3227 {
3259 Emchar ch = string_char (p, i); 3228 Emchar ch = XSTRING_CHAR (p, i);
3260 if (ch < 32 || ch >= 126) 3229 if (ch < 32 || ch >= 126)
3261 stderr_out ("\\%03o", ch); 3230 stderr_out ("\\%03o", ch);
3262 else if (ch == '\\' || ch == '\"') 3231 else if (ch == '\\' || ch == '\"')
3263 stderr_out ("\\%c", ch); 3232 stderr_out ("\\%c", ch);
3264 else 3233 else
3274 { 3243 {
3275 int num_small_used = 0; 3244 int num_small_used = 0;
3276 Bytecount num_small_bytes = 0, num_bytes = 0; 3245 Bytecount num_small_bytes = 0, num_bytes = 0;
3277 int debug = debug_string_purity; 3246 int debug = debug_string_purity;
3278 3247
3279 #define UNMARK_string(ptr) do { \ 3248 #define UNMARK_string(ptr) do { \
3280 Lisp_String *p = (ptr); \ 3249 Lisp_String *p = (ptr); \
3281 Bytecount size = string_length (p); \ 3250 Bytecount size = p->size_; \
3282 UNMARK_RECORD_HEADER (&(p->u.lheader)); \ 3251 UNMARK_RECORD_HEADER (&(p->u.lheader)); \
3283 num_bytes += size; \ 3252 num_bytes += size; \
3284 if (!BIG_STRING_SIZE_P (size)) \ 3253 if (!BIG_STRING_SIZE_P (size)) \
3285 { \ 3254 { \
3286 num_small_bytes += size; \ 3255 num_small_bytes += size; \
3287 num_small_used++; \ 3256 num_small_used++; \
3288 } \ 3257 } \
3289 if (debug) \ 3258 if (debug) \
3290 debug_string_purity_print (p); \ 3259 debug_string_purity_print (wrap_string (p)); \
3291 } while (0) 3260 } while (0)
3292 #define ADDITIONAL_FREE_string(ptr) do { \ 3261 #define ADDITIONAL_FREE_string(ptr) do { \
3293 Bytecount size = string_length (ptr); \ 3262 Bytecount size = ptr->size_; \
3294 if (BIG_STRING_SIZE_P (size)) \ 3263 if (BIG_STRING_SIZE_P (size)) \
3295 xfree (ptr->data); \ 3264 xfree (ptr->data_); \
3296 } while (0) 3265 } while (0)
3297 3266
3298 SWEEP_FIXED_TYPE_BLOCK_1 (string, Lisp_String, u.lheader); 3267 SWEEP_FIXED_TYPE_BLOCK_1 (string, Lisp_String, u.lheader);
3299 3268
3300 gc_count_num_short_string_in_use = num_small_used; 3269 gc_count_num_short_string_in_use = num_small_used;
4099 #endif 4068 #endif
4100 4069
4101 #ifndef Qnull_pointer 4070 #ifndef Qnull_pointer
4102 /* C guarantees that Qnull_pointer will be initialized to all 0 bits, 4071 /* C guarantees that Qnull_pointer will be initialized to all 0 bits,
4103 so the following is actually a no-op. */ 4072 so the following is actually a no-op. */
4104 XSETOBJ (Qnull_pointer, 0); 4073 Qnull_pointer = wrap_pointer_1 (0);
4105 #endif 4074 #endif
4106 4075
4107 gc_generation_number[0] = 0; 4076 gc_generation_number[0] = 0;
4108 breathing_space = 0; 4077 breathing_space = 0;
4109 all_bit_vectors = Qzero; 4078 all_bit_vectors = Qzero;
4161 ERROR_ME_NOT. 4130 ERROR_ME_NOT.
4162 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42; 4131 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
4163 ERROR_ME_WARN. 4132 ERROR_ME_WARN.
4164 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 4133 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
4165 3333632; 4134 3333632;
4135 ERROR_ME_DEBUG_WARN.
4136 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
4137 8675309;
4166 #endif /* ERROR_CHECK_TYPECHECK */ 4138 #endif /* ERROR_CHECK_TYPECHECK */
4167 } 4139 }
4168 4140
4169 static void 4141 static void
4170 init_lcrecord_lists (void) 4142 init_lcrecord_lists (void)