Mercurial > hg > xemacs-beta

comparison src/alloc.c @ 440:8de8e3f6228a r21-2-28

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-28
author cvs
date Mon, 13 Aug 2007 11:33:38 +0200
parents 84b14dcb0985
children abe6d1db359e
comparison
equal deleted inserted replaced
439:357dd071b03c 440:8de8e3f6228a
268 error ("Memory exhausted"); 268 error ("Memory exhausted");
269 } 269 }
270 270
271 /* like malloc and realloc but check for no memory left, and block input. */ 271 /* like malloc and realloc but check for no memory left, and block input. */
272 272
273 #ifdef xmalloc
274 #undef xmalloc 273 #undef xmalloc
275 #endif
276
277 void * 274 void *
278 xmalloc (size_t size) 275 xmalloc (size_t size)
279 { 276 {
280 void *val = malloc (size); 277 void *val = malloc (size);
281 278
282 if (!val && (size != 0)) memory_full (); 279 if (!val && (size != 0)) memory_full ();
283 return val; 280 return val;
284 } 281 }
285 282
286 #ifdef xcalloc
287 #undef xcalloc 283 #undef xcalloc
288 #endif
289
290 static void * 284 static void *
291 xcalloc (size_t nelem, size_t elsize) 285 xcalloc (size_t nelem, size_t elsize)
292 { 286 {
293 void *val = calloc (nelem, elsize); 287 void *val = calloc (nelem, elsize);
294 288
300 xmalloc_and_zero (size_t size) 294 xmalloc_and_zero (size_t size)
301 { 295 {
302 return xcalloc (size, sizeof (char)); 296 return xcalloc (size, sizeof (char));
303 } 297 }
304 298
305 #ifdef xrealloc
306 #undef xrealloc 299 #undef xrealloc
307 #endif
308
309 void * 300 void *
310 xrealloc (void *block, size_t size) 301 xrealloc (void *block, size_t size)
311 { 302 {
312 /* We must call malloc explicitly when BLOCK is 0, since some 303 /* We must call malloc explicitly when BLOCK is 0, since some
313 reallocs don't do this. */ 304 reallocs don't do this. */
362 353
363 #define deadbeef_memory(ptr, size) 354 #define deadbeef_memory(ptr, size)
364 355
365 #endif /* !ERROR_CHECK_GC */ 356 #endif /* !ERROR_CHECK_GC */
366 357
367 #ifdef xstrdup
368 #undef xstrdup 358 #undef xstrdup
369 #endif
370
371 char * 359 char *
372 xstrdup (CONST char *str) 360 xstrdup (CONST char *str)
373 { 361 {
374 int len = strlen (str) + 1; /* for stupid terminating 0 */ 362 int len = strlen (str) + 1; /* for stupid terminating 0 */
375 363
518 unsigned char lrecord_char_table_entry; 506 unsigned char lrecord_char_table_entry;
519 unsigned char lrecord_charset; 507 unsigned char lrecord_charset;
520 #ifndef FILE_CODING 508 #ifndef FILE_CODING
521 unsigned char lrecord_coding_system; 509 unsigned char lrecord_coding_system;
522 #endif 510 #endif
511 #endif
512
513 #if !((defined HAVE_X_WINDOWS) && \
514 (defined (HAVE_MENUBARS) || \
515 defined (HAVE_SCROLLBARS) || \
516 defined (HAVE_DIALOGS) || \
517 defined (HAVE_TOOLBARS) || \
518 defined (HAVE_WIDGETS)))
519 unsigned char lrecord_popup_data;
523 #endif 520 #endif
524 521
525 #ifndef HAVE_TOOLBARS 522 #ifndef HAVE_TOOLBARS
526 unsigned char lrecord_toolbar_button; 523 unsigned char lrecord_toolbar_button;
527 #endif 524 #endif
578 (a struct Lisp_String) is a fixed-size structure and is managed the 575 (a struct Lisp_String) is a fixed-size structure and is managed the
579 same way as all the other such types. This structure contains a 576 same way as all the other such types. This structure contains a
580 pointer to the actual string data, which is stored in structures of 577 pointer to the actual string data, which is stored in structures of
581 type struct string_chars_block. Each string_chars_block consists 578 type struct string_chars_block. Each string_chars_block consists
582 of a pointer to a struct Lisp_String, followed by the data for that 579 of a pointer to a struct Lisp_String, followed by the data for that
583 string, followed by another pointer to a struct Lisp_String, 580 string, followed by another pointer to a Lisp_String, followed by
584 followed by the data for that string, etc. At GC time, the data in 581 the data for that string, etc. At GC time, the data in these
585 these blocks is compacted by searching sequentially through all the 582 blocks is compacted by searching sequentially through all the
586 blocks and compressing out any holes created by unmarked strings. 583 blocks and compressing out any holes created by unmarked strings.
587 Strings that are more than a certain size (bigger than the size of 584 Strings that are more than a certain size (bigger than the size of
588 a string_chars_block, although something like half as big might 585 a string_chars_block, although something like half as big might
589 make more sense) are malloc()ed separately and not stored in 586 make more sense) are malloc()ed separately and not stored in
590 string_chars_blocks. Furthermore, no one string stretches across 587 string_chars_blocks. Furthermore, no one string stretches across
694 Furthermore, we never take objects off the free list 691 Furthermore, we never take objects off the free list
695 unless there's a large number (usually 1000, but 692 unless there's a large number (usually 1000, but
696 varies depending on type) of them already on the list. 693 varies depending on type) of them already on the list.
697 This way, we ensure that an object that gets freed will 694 This way, we ensure that an object that gets freed will
698 remain free for the next 1000 (or whatever) times that 695 remain free for the next 1000 (or whatever) times that
699 an object of that type is allocated. 696 an object of that type is allocated. */
700 */
701 697
702 #ifndef MALLOC_OVERHEAD 698 #ifndef MALLOC_OVERHEAD
703 #ifdef GNU_MALLOC 699 #ifdef GNU_MALLOC
704 #define MALLOC_OVERHEAD 0 700 #define MALLOC_OVERHEAD 0
705 #elif defined (rcheck) 701 #elif defined (rcheck)
924 920
925 /************************************************************************/ 921 /************************************************************************/
926 /* Cons allocation */ 922 /* Cons allocation */
927 /************************************************************************/ 923 /************************************************************************/
928 924
929 DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons); 925 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
930 /* conses are used and freed so often that we set this really high */ 926 /* conses are used and freed so often that we set this really high */
931 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */ 927 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
932 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000 928 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
933 929
934 static Lisp_Object 930 static Lisp_Object
953 } 949 }
954 return 0; 950 return 0;
955 } 951 }
956 952
957 static const struct lrecord_description cons_description[] = { 953 static const struct lrecord_description cons_description[] = {
958 { XD_LISP_OBJECT, offsetof(struct Lisp_Cons, car), 2 }, 954 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car) },
955 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr) },
959 { XD_END } 956 { XD_END }
960 }; 957 };
961 958
962 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons, 959 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
963 mark_cons, print_cons, 0, 960 mark_cons, print_cons, 0,
967 * internal_hash knows how to 964 * internal_hash knows how to
968 * handle conses. 965 * handle conses.
969 */ 966 */
970 0, 967 0,
971 cons_description, 968 cons_description,
972 struct Lisp_Cons); 969 Lisp_Cons);
973 970
974 DEFUN ("cons", Fcons, 2, 2, 0, /* 971 DEFUN ("cons", Fcons, 2, 2, 0, /*
975 Create a new cons, give it CAR and CDR as components, and return it. 972 Create a new cons, give it CAR and CDR as components, and return it.
976 */ 973 */
977 (car, cdr)) 974 (car, cdr))
978 { 975 {
979 /* This cannot GC. */ 976 /* This cannot GC. */
980 Lisp_Object val; 977 Lisp_Object val;
981 struct Lisp_Cons *c; 978 Lisp_Cons *c;
982 979
983 ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c); 980 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
984 set_lheader_implementation (&(c->lheader), &lrecord_cons); 981 set_lheader_implementation (&(c->lheader), &lrecord_cons);
985 XSETCONS (val, c); 982 XSETCONS (val, c);
986 c->car = car; 983 c->car = car;
987 c->cdr = cdr; 984 c->cdr = cdr;
988 return val; 985 return val;
993 "real" consing. */ 990 "real" consing. */
994 Lisp_Object 991 Lisp_Object
995 noseeum_cons (Lisp_Object car, Lisp_Object cdr) 992 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
996 { 993 {
997 Lisp_Object val; 994 Lisp_Object val;
998 struct Lisp_Cons *c; 995 Lisp_Cons *c;
999 996
1000 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c); 997 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
1001 set_lheader_implementation (&(c->lheader), &lrecord_cons); 998 set_lheader_implementation (&(c->lheader), &lrecord_cons);
1002 XSETCONS (val, c); 999 XSETCONS (val, c);
1003 XCAR (val) = car; 1000 XCAR (val) = car;
1004 XCDR (val) = cdr; 1001 XCDR (val) = cdr;
1005 return val; 1002 return val;
1098 /* Float allocation */ 1095 /* Float allocation */
1099 /************************************************************************/ 1096 /************************************************************************/
1100 1097
1101 #ifdef LISP_FLOAT_TYPE 1098 #ifdef LISP_FLOAT_TYPE
1102 1099
1103 DECLARE_FIXED_TYPE_ALLOC (float, struct Lisp_Float); 1100 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
1104 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000 1101 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1105 1102
1106 Lisp_Object 1103 Lisp_Object
1107 make_float (double float_value) 1104 make_float (double float_value)
1108 { 1105 {
1109 Lisp_Object val; 1106 Lisp_Object val;
1110 struct Lisp_Float *f; 1107 Lisp_Float *f;
1111 1108
1112 ALLOCATE_FIXED_TYPE (float, struct Lisp_Float, f); 1109 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f);
1110
1111 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1112 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
1113 xzero (*f);
1114
1113 set_lheader_implementation (&(f->lheader), &lrecord_float); 1115 set_lheader_implementation (&(f->lheader), &lrecord_float);
1114 float_data (f) = float_value; 1116 float_data (f) = float_value;
1115 XSETFLOAT (val, f); 1117 XSETFLOAT (val, f);
1116 return val; 1118 return val;
1117 } 1119 }
1158 } 1160 }
1159 return 1; 1161 return 1;
1160 } 1162 }
1161 1163
1162 static const struct lrecord_description vector_description[] = { 1164 static const struct lrecord_description vector_description[] = {
1163 { XD_LONG, offsetof(struct Lisp_Vector, size) }, 1165 { XD_LONG, offsetof (Lisp_Vector, size) },
1164 { XD_LISP_OBJECT, offsetof(struct Lisp_Vector, contents), XD_INDIRECT(0, 0) }, 1166 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) },
1165 { XD_END } 1167 { XD_END }
1166 }; 1168 };
1167 1169
1168 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector, 1170 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1169 mark_vector, print_vector, 0, 1171 mark_vector, print_vector, 0,
1339 /************************************************************************/ 1341 /************************************************************************/
1340 1342
1341 static Lisp_Object all_bit_vectors; 1343 static Lisp_Object all_bit_vectors;
1342 1344
1343 /* #### should allocate `small' bit vectors from a frob-block */ 1345 /* #### should allocate `small' bit vectors from a frob-block */
1344 static struct Lisp_Bit_Vector * 1346 static Lisp_Bit_Vector *
1345 make_bit_vector_internal (size_t sizei) 1347 make_bit_vector_internal (size_t sizei)
1346 { 1348 {
1347 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei); 1349 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1348 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs); 1350 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1349 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem); 1351 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1361 } 1363 }
1362 1364
1363 Lisp_Object 1365 Lisp_Object
1364 make_bit_vector (size_t length, Lisp_Object init) 1366 make_bit_vector (size_t length, Lisp_Object init)
1365 { 1367 {
1366 struct Lisp_Bit_Vector *p = make_bit_vector_internal (length); 1368 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1367 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length); 1369 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1368 1370
1369 CHECK_BIT (init); 1371 CHECK_BIT (init);
1370 1372
1371 if (ZEROP (init)) 1373 if (ZEROP (init))
1581 1583
1582 /************************************************************************/ 1584 /************************************************************************/
1583 /* Symbol allocation */ 1585 /* Symbol allocation */
1584 /************************************************************************/ 1586 /************************************************************************/
1585 1587
1586 DECLARE_FIXED_TYPE_ALLOC (symbol, struct Lisp_Symbol); 1588 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
1587 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000 1589 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1588 1590
1589 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /* 1591 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1590 Return a newly allocated uninterned symbol whose name is NAME. 1592 Return a newly allocated uninterned symbol whose name is NAME.
1591 Its value and function definition are void, and its property list is nil. 1593 Its value and function definition are void, and its property list is nil.
1592 */ 1594 */
1593 (name)) 1595 (name))
1594 { 1596 {
1595 Lisp_Object val; 1597 Lisp_Object val;
1596 struct Lisp_Symbol *p; 1598 Lisp_Symbol *p;
1597 1599
1598 CHECK_STRING (name); 1600 CHECK_STRING (name);
1599 1601
1600 ALLOCATE_FIXED_TYPE (symbol, struct Lisp_Symbol, p); 1602 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1601 set_lheader_implementation (&(p->lheader), &lrecord_symbol); 1603 set_lheader_implementation (&(p->lheader), &lrecord_symbol);
1602 p->name = XSTRING (name); 1604 p->name = XSTRING (name);
1603 p->plist = Qnil; 1605 p->plist = Qnil;
1604 p->value = Qunbound; 1606 p->value = Qunbound;
1605 p->function = Qunbound; 1607 p->function = Qunbound;
1640 1642
1641 /************************************************************************/ 1643 /************************************************************************/
1642 /* Event allocation */ 1644 /* Event allocation */
1643 /************************************************************************/ 1645 /************************************************************************/
1644 1646
1645 DECLARE_FIXED_TYPE_ALLOC (event, struct Lisp_Event); 1647 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
1646 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000 1648 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1647 1649
1648 Lisp_Object 1650 Lisp_Object
1649 allocate_event (void) 1651 allocate_event (void)
1650 { 1652 {
1651 Lisp_Object val; 1653 Lisp_Object val;
1652 struct Lisp_Event *e; 1654 Lisp_Event *e;
1653 1655
1654 ALLOCATE_FIXED_TYPE (event, struct Lisp_Event, e); 1656 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1655 set_lheader_implementation (&(e->lheader), &lrecord_event); 1657 set_lheader_implementation (&(e->lheader), &lrecord_event);
1656 1658
1657 XSETEVENT (val, e); 1659 XSETEVENT (val, e);
1658 return val; 1660 return val;
1659 } 1661 }
1661 1663
1662 /************************************************************************/ 1664 /************************************************************************/
1663 /* Marker allocation */ 1665 /* Marker allocation */
1664 /************************************************************************/ 1666 /************************************************************************/
1665 1667
1666 DECLARE_FIXED_TYPE_ALLOC (marker, struct Lisp_Marker); 1668 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
1667 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000 1669 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1668 1670
1669 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /* 1671 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1670 Return a new marker which does not point at any place. 1672 Return a new marker which does not point at any place.
1671 */ 1673 */
1672 ()) 1674 ())
1673 { 1675 {
1674 Lisp_Object val; 1676 Lisp_Object val;
1675 struct Lisp_Marker *p; 1677 Lisp_Marker *p;
1676 1678
1677 ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p); 1679 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1678 set_lheader_implementation (&(p->lheader), &lrecord_marker); 1680 set_lheader_implementation (&(p->lheader), &lrecord_marker);
1679 p->buffer = 0; 1681 p->buffer = 0;
1680 p->memind = 0; 1682 p->memind = 0;
1681 marker_next (p) = 0; 1683 marker_next (p) = 0;
1682 marker_prev (p) = 0; 1684 marker_prev (p) = 0;
1687 1689
1688 Lisp_Object 1690 Lisp_Object
1689 noseeum_make_marker (void) 1691 noseeum_make_marker (void)
1690 { 1692 {
1691 Lisp_Object val; 1693 Lisp_Object val;
1692 struct Lisp_Marker *p; 1694 Lisp_Marker *p;
1693 1695
1694 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p); 1696 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1695 set_lheader_implementation (&(p->lheader), &lrecord_marker); 1697 set_lheader_implementation (&(p->lheader), &lrecord_marker);
1696 p->buffer = 0; 1698 p->buffer = 0;
1697 p->memind = 0; 1699 p->memind = 0;
1698 marker_next (p) = 0; 1700 marker_next (p) = 0;
1699 marker_prev (p) = 0; 1701 marker_prev (p) = 0;
1742 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) && 1744 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1743 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len)); 1745 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1744 } 1746 }
1745 1747
1746 static const struct lrecord_description string_description[] = { 1748 static const struct lrecord_description string_description[] = {
1747 { XD_BYTECOUNT, offsetof(Lisp_String, size) }, 1749 { XD_BYTECOUNT, offsetof (Lisp_String, size) },
1748 { XD_OPAQUE_DATA_PTR, offsetof(Lisp_String, data), XD_INDIRECT(0, 1) }, 1750 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
1749 { XD_LISP_OBJECT, offsetof(Lisp_String, plist), 1 }, 1751 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
1750 { XD_END } 1752 { XD_END }
1751 }; 1753 };
1752 1754
1753 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string, 1755 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
1754 mark_string, print_string, 1756 mark_string, print_string,
1928 1930
1929 if (BIG_STRING_FULLSIZE_P (oldfullsize)) 1931 if (BIG_STRING_FULLSIZE_P (oldfullsize))
1930 { 1932 {
1931 if (BIG_STRING_FULLSIZE_P (newfullsize)) 1933 if (BIG_STRING_FULLSIZE_P (newfullsize))
1932 { 1934 {
1933 /* Both strings are big. We can just realloc(). */ 1935 /* Both strings are big. We can just realloc().
1936 But careful! If the string is shrinking, we have to
1937 memmove() _before_ realloc(), and if growing, we have to
1938 memmove() _after_ realloc() - otherwise the access is
1939 illegal, and we might crash. */
1940 Bytecount len = string_length (s) + 1 - pos;
1941
1942 if (delta < 0 && pos >= 0)
1943 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1934 set_string_data (s, (Bufbyte *) xrealloc (string_data (s), 1944 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
1935 string_length (s) + delta + 1)); 1945 string_length (s) + delta + 1));
1936 if (pos >= 0) 1946 if (delta > 0 && pos >= 0)
1937 { 1947 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1938 Bufbyte *addroff = pos + string_data (s);
1939
1940 memmove (addroff + delta, addroff,
1941 string_length (s) + 1 - pos);
1942 }
1943 } 1948 }
1944 else /* String has been demoted from BIG_STRING. */ 1949 else /* String has been demoted from BIG_STRING. */
1945 { 1950 {
1946 Bufbyte *new_data = 1951 Bufbyte *new_data =
1947 allocate_string_chars_struct (s, newfullsize)->chars; 1952 allocate_string_chars_struct (s, newfullsize)->chars;
2122 2127
2123 /* Take some raw memory, encoded in some external data format, 2128 /* Take some raw memory, encoded in some external data format,
2124 and convert it into a Lisp string. */ 2129 and convert it into a Lisp string. */
2125 Lisp_Object 2130 Lisp_Object
2126 make_ext_string (CONST Extbyte *contents, EMACS_INT length, 2131 make_ext_string (CONST Extbyte *contents, EMACS_INT length,
2127 enum external_data_format fmt) 2132 Lisp_Object coding_system)
2128 { 2133 {
2129 Bufbyte *intstr; 2134 Lisp_Object string;
2130 Bytecount intlen; 2135 TO_INTERNAL_FORMAT (DATA, (contents, length),
2131 2136 LISP_STRING, string,
2132 GET_CHARPTR_INT_DATA_ALLOCA (contents, length, fmt, intstr, intlen); 2137 coding_system);
2133 return make_string (intstr, intlen); 2138 return string;
2134 } 2139 }
2135 2140
2136 Lisp_Object 2141 Lisp_Object
2137 build_string (CONST char *str) 2142 build_string (CONST char *str)
2138 { 2143 {
2139 /* Some strlen's crash and burn if passed null. */ 2144 /* Some strlen's crash and burn if passed null. */
2140 return make_string ((CONST Bufbyte *) str, (str ? strlen(str) : 0)); 2145 return make_string ((CONST Bufbyte *) str, (str ? strlen(str) : 0));
2141 } 2146 }
2142 2147
2143 Lisp_Object 2148 Lisp_Object
2144 build_ext_string (CONST char *str, enum external_data_format fmt) 2149 build_ext_string (CONST char *str, Lisp_Object coding_system)
2145 { 2150 {
2146 /* Some strlen's crash and burn if passed null. */ 2151 /* Some strlen's crash and burn if passed null. */
2147 return make_ext_string ((CONST Extbyte *) str, (str ? strlen(str) : 0), fmt); 2152 return make_ext_string ((CONST Extbyte *) str, (str ? strlen(str) : 0),
2153 coding_system);
2148 } 2154 }
2149 2155
2150 Lisp_Object 2156 Lisp_Object
2151 build_translated_string (CONST char *str) 2157 build_translated_string (CONST char *str)
2152 { 2158 {
2404 abort (); 2410 abort ();
2405 staticvec_nodump[staticidx_nodump++] = varaddress; 2411 staticvec_nodump[staticidx_nodump++] = varaddress;
2406 } 2412 }
2407 2413
2408 /* Not "static" because of linker lossage on some systems */ 2414 /* Not "static" because of linker lossage on some systems */
2409 struct { 2415 struct
2416 {
2410 void *data; 2417 void *data;
2411 const struct struct_description *desc; 2418 const struct struct_description *desc;
2412 } dumpstructvec[200]; 2419 } dumpstructvec[200];
2413 2420
2414 static int dumpstructidx; 2421 static int dumpstructidx;
2630 { 2637 {
2631 if (MARKED_RECORD_HEADER_P (h)) 2638 if (MARKED_RECORD_HEADER_P (h))
2632 UNMARK_RECORD_HEADER (h); 2639 UNMARK_RECORD_HEADER (h);
2633 num_used++; 2640 num_used++;
2634 /* total_size += n->implementation->size_in_bytes (h);*/ 2641 /* total_size += n->implementation->size_in_bytes (h);*/
2635 /* ### May modify header->next on a C_READONLY lcrecord */ 2642 /* #### May modify header->next on a C_READONLY lcrecord */
2636 prev = &(header->next); 2643 prev = &(header->next);
2637 header = *prev; 2644 header = *prev;
2638 tick_lcrecord_stats (h, 0); 2645 tick_lcrecord_stats (h, 0);
2639 } 2646 }
2640 else 2647 else
2675 total_storage += 2682 total_storage +=
2676 MALLOC_OVERHEAD + 2683 MALLOC_OVERHEAD +
2677 STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, 2684 STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
2678 BIT_VECTOR_LONG_STORAGE (len)); 2685 BIT_VECTOR_LONG_STORAGE (len));
2679 num_used++; 2686 num_used++;
2680 /* ### May modify next on a C_READONLY bitvector */ 2687 /* #### May modify next on a C_READONLY bitvector */
2681 prev = &(bit_vector_next (v)); 2688 prev = &(bit_vector_next (v));
2682 bit_vector = *prev; 2689 bit_vector = *prev;
2683 } 2690 }
2684 else 2691 else
2685 { 2692 {
2835 sweep_conses (void) 2842 sweep_conses (void)
2836 { 2843 {
2837 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) 2844 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2838 #define ADDITIONAL_FREE_cons(ptr) 2845 #define ADDITIONAL_FREE_cons(ptr)
2839 2846
2840 SWEEP_FIXED_TYPE_BLOCK (cons, struct Lisp_Cons); 2847 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
2841 } 2848 }
2842 2849
2843 /* Explicitly free a cons cell. */ 2850 /* Explicitly free a cons cell. */
2844 void 2851 void
2845 free_cons (struct Lisp_Cons *ptr) 2852 free_cons (Lisp_Cons *ptr)
2846 { 2853 {
2847 #ifdef ERROR_CHECK_GC 2854 #ifdef ERROR_CHECK_GC
2848 /* If the CAR is not an int, then it will be a pointer, which will 2855 /* If the CAR is not an int, then it will be a pointer, which will
2849 always be four-byte aligned. If this cons cell has already been 2856 always be four-byte aligned. If this cons cell has already been
2850 placed on the free list, however, its car will probably contain 2857 placed on the free list, however, its car will probably contain
2854 if (POINTER_TYPE_P (XTYPE (ptr->car))) 2861 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2855 ASSERT_VALID_POINTER (XPNTR (ptr->car)); 2862 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2856 #endif /* ERROR_CHECK_GC */ 2863 #endif /* ERROR_CHECK_GC */
2857 2864
2858 #ifndef ALLOC_NO_POOLS 2865 #ifndef ALLOC_NO_POOLS
2859 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, struct Lisp_Cons, ptr); 2866 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
2860 #endif /* ALLOC_NO_POOLS */ 2867 #endif /* ALLOC_NO_POOLS */
2861 } 2868 }
2862 2869
2863 /* explicitly free a list. You **must make sure** that you have 2870 /* explicitly free a list. You **must make sure** that you have
2864 created all the cons cells that make up this list and that there 2871 created all the cons cells that make up this list and that there
2910 sweep_floats (void) 2917 sweep_floats (void)
2911 { 2918 {
2912 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) 2919 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2913 #define ADDITIONAL_FREE_float(ptr) 2920 #define ADDITIONAL_FREE_float(ptr)
2914 2921
2915 SWEEP_FIXED_TYPE_BLOCK (float, struct Lisp_Float); 2922 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
2916 } 2923 }
2917 #endif /* LISP_FLOAT_TYPE */ 2924 #endif /* LISP_FLOAT_TYPE */
2918 2925
2919 static void 2926 static void
2920 sweep_symbols (void) 2927 sweep_symbols (void)
2921 { 2928 {
2922 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) 2929 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2923 #define ADDITIONAL_FREE_symbol(ptr) 2930 #define ADDITIONAL_FREE_symbol(ptr)
2924 2931
2925 SWEEP_FIXED_TYPE_BLOCK (symbol, struct Lisp_Symbol); 2932 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
2926 } 2933 }
2927 2934
2928 static void 2935 static void
2929 sweep_extents (void) 2936 sweep_extents (void)
2930 { 2937 {
2938 sweep_events (void) 2945 sweep_events (void)
2939 { 2946 {
2940 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) 2947 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2941 #define ADDITIONAL_FREE_event(ptr) 2948 #define ADDITIONAL_FREE_event(ptr)
2942 2949
2943 SWEEP_FIXED_TYPE_BLOCK (event, struct Lisp_Event); 2950 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
2944 } 2951 }
2945 2952
2946 static void 2953 static void
2947 sweep_markers (void) 2954 sweep_markers (void)
2948 { 2955 {
2951 do { Lisp_Object tem; \ 2958 do { Lisp_Object tem; \
2952 XSETMARKER (tem, ptr); \ 2959 XSETMARKER (tem, ptr); \
2953 unchain_marker (tem); \ 2960 unchain_marker (tem); \
2954 } while (0) 2961 } while (0)
2955 2962
2956 SWEEP_FIXED_TYPE_BLOCK (marker, struct Lisp_Marker); 2963 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
2957 } 2964 }
2958 2965
2959 /* Explicitly free a marker. */ 2966 /* Explicitly free a marker. */
2960 void 2967 void
2961 free_marker (struct Lisp_Marker *ptr) 2968 free_marker (Lisp_Marker *ptr)
2962 { 2969 {
2963 #ifdef ERROR_CHECK_GC 2970 #ifdef ERROR_CHECK_GC
2964 /* Perhaps this will catch freeing an already-freed marker. */ 2971 /* Perhaps this will catch freeing an already-freed marker. */
2965 Lisp_Object temmy; 2972 Lisp_Object temmy;
2966 XSETMARKER (temmy, ptr); 2973 XSETMARKER (temmy, ptr);
2967 assert (MARKERP (temmy)); 2974 assert (MARKERP (temmy));
2968 #endif /* ERROR_CHECK_GC */ 2975 #endif /* ERROR_CHECK_GC */
2969 2976
2970 #ifndef ALLOC_NO_POOLS 2977 #ifndef ALLOC_NO_POOLS
2971 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, struct Lisp_Marker, ptr); 2978 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
2972 #endif /* ALLOC_NO_POOLS */ 2979 #endif /* ALLOC_NO_POOLS */
2973 } 2980 }
2974 2981
2975 2982
2976 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY) 2983 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
3262 #ifdef PDUMP 3269 #ifdef PDUMP
3263 /* Unmark all dumped objects */ 3270 /* Unmark all dumped objects */
3264 { 3271 {
3265 int i; 3272 int i;
3266 char *p = pdump_rt_list; 3273 char *p = pdump_rt_list;
3267 if(p) 3274 if (p)
3268 for(;;) 3275 for (;;)
3269 { 3276 {
3270 pdump_reloc_table *rt = (pdump_reloc_table *)p; 3277 pdump_reloc_table *rt = (pdump_reloc_table *)p;
3271 p += sizeof (pdump_reloc_table); 3278 p += sizeof (pdump_reloc_table);
3272 if (rt->desc) { 3279 if (rt->desc)
3273 for (i=0; i<rt->count; i++) 3280 {
3274 { 3281 for (i=0; i<rt->count; i++)
3275 UNMARK_RECORD_HEADER ((struct lrecord_header *)(*(EMACS_INT *)p)); 3282 {
3276 p += sizeof (EMACS_INT); 3283 UNMARK_RECORD_HEADER ((struct lrecord_header *)(*(EMACS_INT *)p));
3277 } 3284 p += sizeof (EMACS_INT);
3278 } else 3285 }
3279 break; 3286 } else
3287 break;
3280 } 3288 }
3281 } 3289 }
3282 #endif 3290 #endif
3283 } 3291 }
3284 3292
3292 To make it easier to tell when this has happened with strings(1) we 3300 To make it easier to tell when this has happened with strings(1) we
3293 clear some known-to-be-garbage blocks of memory, so that leftover 3301 clear some known-to-be-garbage blocks of memory, so that leftover
3294 results of old evaluation don't look like potential problems. 3302 results of old evaluation don't look like potential problems.
3295 But first we set some notable variables to nil and do one more GC, 3303 But first we set some notable variables to nil and do one more GC,
3296 to turn those strings into garbage. 3304 to turn those strings into garbage.
3297 */ 3305 */
3298 3306
3299 /* Yeah, this list is pretty ad-hoc... */ 3307 /* Yeah, this list is pretty ad-hoc... */
3300 Vprocess_environment = Qnil; 3308 Vprocess_environment = Qnil;
3301 Vexec_directory = Qnil; 3309 Vexec_directory = Qnil;
3302 Vdata_directory = Qnil; 3310 Vdata_directory = Qnil;
3328 for (scb = first_string_chars_block; scb; scb = scb->next) 3336 for (scb = first_string_chars_block; scb; scb = scb->next)
3329 { 3337 {
3330 int count = sizeof (scb->string_chars) - scb->pos; 3338 int count = sizeof (scb->string_chars) - scb->pos;
3331 3339
3332 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE); 3340 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3333 if (count != 0) { 3341 if (count != 0)
3334 /* from the block's fill ptr to the end */ 3342 {
3335 memset ((scb->string_chars + scb->pos), 0, count); 3343 /* from the block's fill ptr to the end */
3336 } 3344 memset ((scb->string_chars + scb->pos), 0, count);
3345 }
3337 } 3346 }
3338 } 3347 }
3339 3348
3340 /* There, that ought to be enough... */ 3349 /* There, that ought to be enough... */
3341 3350
3751 ()) 3760 ())
3752 { 3761 {
3753 return make_int (consing_since_gc); 3762 return make_int (consing_since_gc);
3754 } 3763 }
3755 3764
3765 #if 0
3756 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /* 3766 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
3757 Return the address of the last byte Emacs has allocated, divided by 1024. 3767 Return the address of the last byte Emacs has allocated, divided by 1024.
3758 This may be helpful in debugging Emacs's memory usage. 3768 This may be helpful in debugging Emacs's memory usage.
3759 The value is divided by 1024 to make sure it will fit in a lisp integer. 3769 The value is divided by 1024 to make sure it will fit in a lisp integer.
3760 */ 3770 */
3761 ()) 3771 ())
3762 { 3772 {
3763 return make_int ((EMACS_INT) sbrk (0) / 1024); 3773 return make_int ((EMACS_INT) sbrk (0) / 1024);
3764 } 3774 }
3765 3775 #endif
3766 3776
3767 3777
3768 int 3778 int
3769 object_dead_p (Lisp_Object obj) 3779 object_dead_p (Lisp_Object obj)
3770 { 3780 {
4036 DEFSUBR (Fstring); 4046 DEFSUBR (Fstring);
4037 DEFSUBR (Fmake_symbol); 4047 DEFSUBR (Fmake_symbol);
4038 DEFSUBR (Fmake_marker); 4048 DEFSUBR (Fmake_marker);
4039 DEFSUBR (Fpurecopy); 4049 DEFSUBR (Fpurecopy);
4040 DEFSUBR (Fgarbage_collect); 4050 DEFSUBR (Fgarbage_collect);
4051 #if 0
4041 DEFSUBR (Fmemory_limit); 4052 DEFSUBR (Fmemory_limit);
4053 #endif
4042 DEFSUBR (Fconsing_since_gc); 4054 DEFSUBR (Fconsing_since_gc);
4043 } 4055 }
4044 4056
4045 void 4057 void
4046 vars_of_alloc (void) 4058 vars_of_alloc (void)
4234 } 4246 }
4235 4247
4236 static pdump_entry_list_elmt * 4248 static pdump_entry_list_elmt *
4237 pdump_get_entry (const void *obj) 4249 pdump_get_entry (const void *obj)
4238 { 4250 {
4239 int pos = pdump_make_hash(obj); 4251 int pos = pdump_make_hash (obj);
4240 pdump_entry_list_elmt *e; 4252 pdump_entry_list_elmt *e;
4253
4254 assert (obj != 0);
4255
4241 while ((e = pdump_hash[pos]) != 0) 4256 while ((e = pdump_hash[pos]) != 0)
4242 { 4257 {
4243 if (e->obj == obj) 4258 if (e->obj == obj)
4244 return e; 4259 return e;
4245 4260
4265 pos++; 4280 pos++;
4266 if (pos == PDUMP_HASHSIZE) 4281 if (pos == PDUMP_HASHSIZE)
4267 pos = 0; 4282 pos = 0;
4268 } 4283 }
4269 4284
4270 e = malloc (sizeof (pdump_entry_list_elmt)); 4285 e = xnew (pdump_entry_list_elmt);
4271 4286
4272 e->next = list->first; 4287 e->next = list->first;
4273 e->obj = obj; 4288 e->obj = obj;
4274 e->size = size; 4289 e->size = size;
4275 e->count = count; 4290 e->count = count;
4278 4293
4279 list->count += count; 4294 list->count += count;
4280 pdump_hash[pos] = e; 4295 pdump_hash[pos] = e;
4281 4296
4282 align = align_table[size & 255]; 4297 align = align_table[size & 255];
4283 if (align<2 && is_lrecord) 4298 if (align < 2 && is_lrecord)
4284 align = 2; 4299 align = 2;
4285 4300
4286 if(align < list->align) 4301 if (align < list->align)
4287 list->align = align; 4302 list->align = align;
4288 } 4303 }
4289 4304
4290 static pdump_entry_list * 4305 static pdump_entry_list *
4291 pdump_get_entry_list(const struct struct_description *sdesc) 4306 pdump_get_entry_list (const struct struct_description *sdesc)
4292 { 4307 {
4293 int i; 4308 int i;
4294 for(i=0; i<pdump_struct_table.count; i++) 4309 for (i=0; i<pdump_struct_table.count; i++)
4295 if (pdump_struct_table.list[i].sdesc == sdesc) 4310 if (pdump_struct_table.list[i].sdesc == sdesc)
4296 return &pdump_struct_table.list[i].list; 4311 return &pdump_struct_table.list[i].list;
4297 4312
4298 if (pdump_struct_table.size <= pdump_struct_table.count) 4313 if (pdump_struct_table.size <= pdump_struct_table.count)
4299 { 4314 {
4300 if (pdump_struct_table.size == -1) 4315 if (pdump_struct_table.size == -1)
4301 pdump_struct_table.size = 10; 4316 pdump_struct_table.size = 10;
4302 else 4317 else
4303 pdump_struct_table.size = pdump_struct_table.size * 2; 4318 pdump_struct_table.size = pdump_struct_table.size * 2;
4304 pdump_struct_table.list = xrealloc (pdump_struct_table.list, 4319 pdump_struct_table.list = (pdump_struct_list_elmt *)
4305 pdump_struct_table.size*sizeof (pdump_struct_list_elmt)); 4320 xrealloc (pdump_struct_table.list,
4321 pdump_struct_table.size * sizeof (pdump_struct_list_elmt));
4306 } 4322 }
4307 pdump_struct_table.list[pdump_struct_table.count].list.first = 0; 4323 pdump_struct_table.list[pdump_struct_table.count].list.first = 0;
4308 pdump_struct_table.list[pdump_struct_table.count].list.align = 8; 4324 pdump_struct_table.list[pdump_struct_table.count].list.align = 8;
4309 pdump_struct_table.list[pdump_struct_table.count].list.count = 0; 4325 pdump_struct_table.list[pdump_struct_table.count].list.count = 0;
4310 pdump_struct_table.list[pdump_struct_table.count].sdesc = sdesc; 4326 pdump_struct_table.list[pdump_struct_table.count].sdesc = sdesc;
4311 4327
4312 return &pdump_struct_table.list[pdump_struct_table.count++].list; 4328 return &pdump_struct_table.list[pdump_struct_table.count++].list;
4313 } 4329 }
4314 4330
4315 static struct { 4331 static struct
4316 Lisp_Object obj; 4332 {
4333 struct lrecord_header *obj;
4317 int position; 4334 int position;
4318 int offset; 4335 int offset;
4319 } backtrace[65536]; 4336 } backtrace[65536];
4320 4337
4321 static int depth; 4338 static int depth;
4329 if (!backtrace[i].obj) 4346 if (!backtrace[i].obj)
4330 fprintf (stderr, " - ind. (%d, %d)\n", backtrace[i].position, backtrace[i].offset); 4347 fprintf (stderr, " - ind. (%d, %d)\n", backtrace[i].position, backtrace[i].offset);
4331 else 4348 else
4332 { 4349 {
4333 fprintf (stderr, " - %s (%d, %d)\n", 4350 fprintf (stderr, " - %s (%d, %d)\n",
4334 XRECORD_LHEADER_IMPLEMENTATION (backtrace[i].obj)->name, 4351 LHEADER_IMPLEMENTATION (backtrace[i].obj)->name,
4335 backtrace[i].position, 4352 backtrace[i].position,
4336 backtrace[i].offset); 4353 backtrace[i].offset);
4337 } 4354 }
4338 } 4355 }
4339 } 4356 }
4349 4366
4350 int line = XD_INDIRECT_VAL (code); 4367 int line = XD_INDIRECT_VAL (code);
4351 int delta = XD_INDIRECT_DELTA (code); 4368 int delta = XD_INDIRECT_DELTA (code);
4352 4369
4353 irdata = ((char *)idata) + idesc[line].offset; 4370 irdata = ((char *)idata) + idesc[line].offset;
4354 switch (idesc[line].type) { 4371 switch (idesc[line].type)
4355 case XD_SIZE_T: 4372 {
4356 count = *(size_t *)irdata; 4373 case XD_SIZE_T:
4357 break; 4374 count = *(size_t *)irdata;
4358 case XD_INT: 4375 break;
4359 count = *(int *)irdata; 4376 case XD_INT:
4360 break; 4377 count = *(int *)irdata;
4361 case XD_LONG: 4378 break;
4362 count = *(long *)irdata; 4379 case XD_LONG:
4363 break; 4380 count = *(long *)irdata;
4364 case XD_BYTECOUNT: 4381 break;
4365 count = *(Bytecount *)irdata; 4382 case XD_BYTECOUNT:
4366 break; 4383 count = *(Bytecount *)irdata;
4367 default: 4384 break;
4368 fprintf (stderr, "Unsupported count type : %d (line = %d, code=%ld)\n", idesc[line].type, line, (long)code); 4385 default:
4369 pdump_backtrace (); 4386 fprintf (stderr, "Unsupported count type : %d (line = %d, code=%ld)\n", idesc[line].type, line, (long)code);
4370 abort (); 4387 pdump_backtrace ();
4371 } 4388 abort ();
4389 }
4372 count += delta; 4390 count += delta;
4373 return count; 4391 return count;
4374 } 4392 }
4375 4393
4376 static void 4394 static void
4377 pdump_register_sub (const void *data, const struct lrecord_description *desc, int me) 4395 pdump_register_sub (const void *data, const struct lrecord_description *desc, int me)
4378 { 4396 {
4379 int pos; 4397 int pos;
4380 const void *rdata;
4381 4398
4382 restart: 4399 restart:
4383 for (pos = 0; desc[pos].type != XD_END; pos++) 4400 for (pos = 0; desc[pos].type != XD_END; pos++)
4384 { 4401 {
4402 const void *rdata = (const char *)data + desc[pos].offset;
4403
4385 backtrace[me].position = pos; 4404 backtrace[me].position = pos;
4386 backtrace[me].offset = desc[pos].offset; 4405 backtrace[me].offset = desc[pos].offset;
4387 4406
4388 rdata = ((const char *)data) + desc[pos].offset; 4407 switch (desc[pos].type)
4389 switch(desc[pos].type)
4390 { 4408 {
4391 case XD_SPECIFIER_END: 4409 case XD_SPECIFIER_END:
4392 pos = 0; 4410 pos = 0;
4393 desc = ((const struct Lisp_Specifier *)data)->methods->extra_description; 4411 desc = ((const Lisp_Specifier *)data)->methods->extra_description;
4394 goto restart; 4412 goto restart;
4395 case XD_SIZE_T: 4413 case XD_SIZE_T:
4396 case XD_INT: 4414 case XD_INT:
4397 case XD_LONG: 4415 case XD_LONG:
4398 case XD_BYTECOUNT: 4416 case XD_BYTECOUNT:
4401 case XD_LO_LINK: 4419 case XD_LO_LINK:
4402 break; 4420 break;
4403 case XD_OPAQUE_DATA_PTR: 4421 case XD_OPAQUE_DATA_PTR:
4404 { 4422 {
4405 EMACS_INT count = desc[pos].data1; 4423 EMACS_INT count = desc[pos].data1;
4406 if (XD_IS_INDIRECT(count)) 4424 if (XD_IS_INDIRECT (count))
4407 count = pdump_get_indirect_count (count, desc, data); 4425 count = pdump_get_indirect_count (count, desc, data);
4408 4426
4409 pdump_add_entry (&pdump_opaque_data_list, 4427 pdump_add_entry (&pdump_opaque_data_list,
4410 *(void **)rdata, 4428 *(void **)rdata,
4411 count, 4429 count,
4427 pdump_add_entry (&pdump_opaque_data_list, str, strlen (str)+1, 1, 0); 4445 pdump_add_entry (&pdump_opaque_data_list, str, strlen (str)+1, 1, 0);
4428 break; 4446 break;
4429 } 4447 }
4430 case XD_LISP_OBJECT: 4448 case XD_LISP_OBJECT:
4431 { 4449 {
4450 const Lisp_Object *pobj = (const Lisp_Object *)rdata;
4451
4452 assert (desc[pos].data1 == 0);
4453
4454 backtrace[me].offset = (const char *)pobj - (const char *)data;
4455 pdump_register_object (*pobj);
4456 break;
4457 }
4458 case XD_LISP_OBJECT_ARRAY:
4459 {
4460 int i;
4432 EMACS_INT count = desc[pos].data1; 4461 EMACS_INT count = desc[pos].data1;
4433 int i;
4434 if (XD_IS_INDIRECT (count)) 4462 if (XD_IS_INDIRECT (count))
4435 count = pdump_get_indirect_count (count, desc, data); 4463 count = pdump_get_indirect_count (count, desc, data);
4436 4464
4437 for(i=0;i<count;i++) { 4465 for (i = 0; i < count; i++)
4438 const Lisp_Object *pobj = ((const Lisp_Object *)rdata) + i; 4466 {
4439 Lisp_Object dobj = *pobj; 4467 const Lisp_Object *pobj = ((const Lisp_Object *)rdata) + i;
4440 4468 Lisp_Object dobj = *pobj;
4441 backtrace[me].offset = (const char *)pobj - (const char *)data; 4469
4442 pdump_register_object (dobj); 4470 backtrace[me].offset = (const char *)pobj - (const char *)data;
4443 } 4471 pdump_register_object (dobj);
4472 }
4444 break; 4473 break;
4445 } 4474 }
4446 case XD_STRUCT_PTR: 4475 case XD_STRUCT_PTR:
4447 { 4476 {
4448 EMACS_INT count = desc[pos].data1; 4477 EMACS_INT count = desc[pos].data1;
4449 const struct struct_description *sdesc = desc[pos].data2; 4478 const struct struct_description *sdesc = desc[pos].data2;
4450 const char *dobj = *(const char **)rdata; 4479 const char *dobj = *(const char **)rdata;
4451 if (dobj) { 4480 if (dobj)
4452 if (XD_IS_INDIRECT (count)) 4481 {
4453 count = pdump_get_indirect_count (count, desc, data); 4482 if (XD_IS_INDIRECT (count))
4454 4483 count = pdump_get_indirect_count (count, desc, data);
4455 pdump_register_struct (dobj, sdesc, count); 4484
4456 } 4485 pdump_register_struct (dobj, sdesc, count);
4486 }
4457 break; 4487 break;
4458 } 4488 }
4459 default: 4489 default:
4460 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type); 4490 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4461 pdump_backtrace (); 4491 pdump_backtrace ();
4465 } 4495 }
4466 4496
4467 static void 4497 static void
4468 pdump_register_object (Lisp_Object obj) 4498 pdump_register_object (Lisp_Object obj)
4469 { 4499 {
4470 if (!obj || 4500 struct lrecord_header *objh;
4471 !POINTER_TYPE_P (XTYPE (obj)) || 4501
4472 pdump_get_entry (XRECORD_LHEADER (obj))) 4502 if (!POINTER_TYPE_P (XTYPE (obj)))
4473 return; 4503 return;
4474 4504
4475 if (XRECORD_LHEADER_IMPLEMENTATION (obj)->description) 4505 objh = XRECORD_LHEADER (obj);
4506 if (!objh)
4507 return;
4508
4509 if (pdump_get_entry (objh))
4510 return;
4511
4512 if (LHEADER_IMPLEMENTATION (objh)->description)
4476 { 4513 {
4477 int me = depth++; 4514 int me = depth++;
4478 if (me>65536) 4515 if (me>65536)
4479 { 4516 {
4480 fprintf (stderr, "Backtrace overflow, loop ?\n"); 4517 fprintf (stderr, "Backtrace overflow, loop ?\n");
4481 abort (); 4518 abort ();
4482 } 4519 }
4483 backtrace[me].obj = obj; 4520 backtrace[me].obj = objh;
4484 backtrace[me].position = 0; 4521 backtrace[me].position = 0;
4485 backtrace[me].offset = 0; 4522 backtrace[me].offset = 0;
4486 4523
4487 pdump_add_entry (pdump_object_table + XRECORD_LHEADER (obj)->type, 4524 pdump_add_entry (pdump_object_table + objh->type,
4488 XRECORD_LHEADER (obj), 4525 objh,
4489 XRECORD_LHEADER_IMPLEMENTATION (obj)->static_size ? 4526 LHEADER_IMPLEMENTATION (objh)->static_size ?
4490 XRECORD_LHEADER_IMPLEMENTATION (obj)->static_size : 4527 LHEADER_IMPLEMENTATION (objh)->static_size :
4491 XRECORD_LHEADER_IMPLEMENTATION (obj)->size_in_bytes_method (XRECORD_LHEADER (obj)), 4528 LHEADER_IMPLEMENTATION (objh)->size_in_bytes_method (objh),
4492 1, 4529 1,
4493 1); 4530 1);
4494 pdump_register_sub (XRECORD_LHEADER (obj), 4531 pdump_register_sub (objh,
4495 XRECORD_LHEADER_IMPLEMENTATION (obj)->description, 4532 LHEADER_IMPLEMENTATION (objh)->description,
4496 me); 4533 me);
4497 --depth; 4534 --depth;
4498 } 4535 }
4499 else 4536 else
4500 { 4537 {
4501 pdump_alert_undump_object[XRECORD_LHEADER (obj)->type]++; 4538 pdump_alert_undump_object[objh->type]++;
4502 fprintf (stderr, "Undumpable object type : %s\n", XRECORD_LHEADER_IMPLEMENTATION (obj)->name); 4539 fprintf (stderr, "Undumpable object type : %s\n", LHEADER_IMPLEMENTATION (objh)->name);
4503 pdump_backtrace (); 4540 pdump_backtrace ();
4504 } 4541 }
4505 } 4542 }
4506 4543
4507 static void 4544 static void
4541 size_t size = elmt->size; 4578 size_t size = elmt->size;
4542 int count = elmt->count; 4579 int count = elmt->count;
4543 if (desc) 4580 if (desc)
4544 { 4581 {
4545 int pos, i; 4582 int pos, i;
4546 void *rdata;
4547 memcpy (pdump_buf, elmt->obj, size*count); 4583 memcpy (pdump_buf, elmt->obj, size*count);
4548 4584
4549 for (i=0; i<count; i++) 4585 for (i=0; i<count; i++)
4550 { 4586 {
4551 char *cur = ((char *)pdump_buf) + i*size; 4587 char *cur = ((char *)pdump_buf) + i*size;
4552 restart: 4588 restart:
4553 for (pos = 0; desc[pos].type != XD_END; pos++) 4589 for (pos = 0; desc[pos].type != XD_END; pos++)
4554 { 4590 {
4555 rdata = cur + desc[pos].offset; 4591 void *rdata = cur + desc[pos].offset;
4556 switch (desc[pos].type) 4592 switch (desc[pos].type)
4557 { 4593 {
4558 case XD_SPECIFIER_END: 4594 case XD_SPECIFIER_END:
4559 pos = 0; 4595 desc = ((const Lisp_Specifier *)(elmt->obj))->methods->extra_description;
4560 desc = ((const struct Lisp_Specifier *)(elmt->obj))->methods->extra_description;
4561 goto restart; 4596 goto restart;
4562 case XD_SIZE_T: 4597 case XD_SIZE_T:
4563 case XD_INT: 4598 case XD_INT:
4564 case XD_LONG: 4599 case XD_LONG:
4565 case XD_BYTECOUNT: 4600 case XD_BYTECOUNT:
4593 } 4628 }
4594 case XD_LO_LINK: 4629 case XD_LO_LINK:
4595 { 4630 {
4596 Lisp_Object obj = *(Lisp_Object *)rdata; 4631 Lisp_Object obj = *(Lisp_Object *)rdata;
4597 pdump_entry_list_elmt *elmt1; 4632 pdump_entry_list_elmt *elmt1;
4598 for(;;) 4633 for (;;)
4599 { 4634 {
4600 elmt1 = pdump_get_entry (XRECORD_LHEADER(obj)); 4635 elmt1 = pdump_get_entry (XRECORD_LHEADER (obj));
4601 if (elmt1) 4636 if (elmt1)
4602 break; 4637 break;
4603 obj = *(Lisp_Object *)(desc[pos].offset + (char *)(XRECORD_LHEADER (obj))); 4638 obj = *(Lisp_Object *)(desc[pos].offset + (char *)(XRECORD_LHEADER (obj)));
4604 } 4639 }
4605 *(EMACS_INT *)rdata = elmt1->save_offset; 4640 *(EMACS_INT *)rdata = elmt1->save_offset;
4606 break; 4641 break;
4607 } 4642 }
4608 case XD_LISP_OBJECT: 4643 case XD_LISP_OBJECT:
4609 { 4644 {
4645 Lisp_Object *pobj = (Lisp_Object *) rdata;
4646
4647 assert (desc[pos].data1 == 0);
4648
4649 if (POINTER_TYPE_P (XTYPE (*pobj)) && XRECORD_LHEADER (*pobj))
4650 *(EMACS_INT *)pobj =
4651 pdump_get_entry (XRECORD_LHEADER (*pobj))->save_offset;
4652 break;
4653 }
4654 case XD_LISP_OBJECT_ARRAY:
4655 {
4610 EMACS_INT count = desc[pos].data1; 4656 EMACS_INT count = desc[pos].data1;
4611 int i; 4657 int i;
4612 if (XD_IS_INDIRECT (count)) 4658 if (XD_IS_INDIRECT (count))
4613 count = pdump_get_indirect_count (count, desc, elmt->obj); 4659 count = pdump_get_indirect_count (count, desc, elmt->obj);
4614 4660
4615 for(i=0; i<count; i++) 4661 for (i=0; i<count; i++)
4616 { 4662 {
4617 Lisp_Object *pobj = ((Lisp_Object *)rdata) + i; 4663 Lisp_Object *pobj = ((Lisp_Object *)rdata) + i;
4618 Lisp_Object dobj = *pobj; 4664 if (POINTER_TYPE_P (XTYPE (*pobj)) && XRECORD_LHEADER (*pobj))
4619 if (dobj && POINTER_TYPE_P (XTYPE (dobj))) 4665 *(EMACS_INT *)pobj =
4620 *pobj = pdump_get_entry (XRECORD_LHEADER (dobj))->save_offset; 4666 pdump_get_entry (XRECORD_LHEADER (*pobj))->save_offset;
4621 } 4667 }
4622 break; 4668 break;
4623 } 4669 }
4624 case XD_DOC_STRING: 4670 case XD_DOC_STRING:
4625 { 4671 {
4642 4688
4643 static void 4689 static void
4644 pdump_reloc_one (void *data, EMACS_INT delta, const struct lrecord_description *desc) 4690 pdump_reloc_one (void *data, EMACS_INT delta, const struct lrecord_description *desc)
4645 { 4691 {
4646 int pos; 4692 int pos;
4647 void *rdata; 4693
4648 4694 restart:
4649 restart:
4650 for (pos = 0; desc[pos].type != XD_END; pos++) 4695 for (pos = 0; desc[pos].type != XD_END; pos++)
4651 { 4696 {
4652 rdata = ((char *)data) + desc[pos].offset; 4697 void *rdata = (char *)data + desc[pos].offset;
4653 switch (desc[pos].type) { 4698 switch (desc[pos].type)
4654 case XD_SPECIFIER_END:
4655 pos = 0;
4656 desc = ((const struct Lisp_Specifier *)data)->methods->extra_description;
4657 goto restart;
4658 case XD_SIZE_T:
4659 case XD_INT:
4660 case XD_LONG:
4661 case XD_BYTECOUNT:
4662 case XD_INT_RESET:
4663 break;
4664 case XD_OPAQUE_DATA_PTR:
4665 case XD_C_STRING:
4666 case XD_STRUCT_PTR:
4667 case XD_LO_LINK:
4668 { 4699 {
4669 EMACS_INT ptr = *(EMACS_INT *)rdata; 4700 case XD_SPECIFIER_END:
4670 if (ptr) 4701 pos = 0;
4671 *(EMACS_INT *)rdata = ptr+delta; 4702 desc = ((const Lisp_Specifier *)data)->methods->extra_description;
4703 goto restart;
4704 case XD_SIZE_T:
4705 case XD_INT:
4706 case XD_LONG:
4707 case XD_BYTECOUNT:
4708 case XD_INT_RESET:
4672 break; 4709 break;
4673 } 4710 case XD_OPAQUE_DATA_PTR:
4674 case XD_LISP_OBJECT: 4711 case XD_C_STRING:
4675 case XD_LO_RESET_NIL: 4712 case XD_STRUCT_PTR:
4676 { 4713 case XD_LO_LINK:
4677 EMACS_INT count = desc[pos].data1; 4714 {
4678 int i; 4715 EMACS_INT ptr = *(EMACS_INT *)rdata;
4679 if (XD_IS_INDIRECT (count)) 4716 if (ptr)
4680 count = pdump_get_indirect_count (count, desc, data); 4717 *(EMACS_INT *)rdata = ptr+delta;
4681 4718 break;
4682 for (i=0; i<count; i++) 4719 }
4683 { 4720 case XD_LISP_OBJECT:
4684 Lisp_Object *pobj = ((Lisp_Object *)rdata) + i; 4721 {
4685 Lisp_Object dobj = *pobj; 4722 Lisp_Object *pobj = (Lisp_Object *) rdata;
4686 if (dobj && POINTER_TYPE_P (XTYPE (dobj))) 4723
4687 *pobj = dobj + delta; 4724 assert (desc[pos].data1 == 0);
4688 } 4725
4689 break; 4726 if (POINTER_TYPE_P (XTYPE (*pobj))
4690 } 4727 && ! EQ (*pobj, Qnull_pointer))
4691 case XD_DOC_STRING: 4728 XSETOBJ (*pobj, XTYPE (*pobj), (char *) XPNTR (*pobj) + delta);
4692 { 4729
4693 EMACS_INT str = *(EMACS_INT *)rdata; 4730 break;
4694 if (str > 0) 4731 }
4695 *(EMACS_INT *)rdata = str + delta; 4732 case XD_LISP_OBJECT_ARRAY:
4696 break; 4733 case XD_LO_RESET_NIL:
4697 } 4734 {
4698 default: 4735 EMACS_INT count = desc[pos].data1;
4699 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type); 4736 int i;
4700 abort (); 4737 if (XD_IS_INDIRECT (count))
4701 }; 4738 count = pdump_get_indirect_count (count, desc, data);
4739
4740 for (i=0; i<count; i++)
4741 {
4742 Lisp_Object *pobj = (Lisp_Object *) rdata + i;
4743
4744 if (POINTER_TYPE_P (XTYPE (*pobj))
4745 && ! EQ (*pobj, Qnull_pointer))
4746 XSETOBJ (*pobj, XTYPE (*pobj), (char *) XPNTR (*pobj) + delta);
4747 }
4748 break;
4749 }
4750 case XD_DOC_STRING:
4751 {
4752 EMACS_INT str = *(EMACS_INT *)rdata;
4753 if (str > 0)
4754 *(EMACS_INT *)rdata = str + delta;
4755 break;
4756 }
4757 default:
4758 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4759 abort ();
4760 };
4702 } 4761 }
4703 } 4762 }
4704 4763
4705 static void 4764 static void
4706 pdump_allocate_offset (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc) 4765 pdump_allocate_offset (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc)
4711 max_size = size; 4770 max_size = size;
4712 cur_offset += size; 4771 cur_offset += size;
4713 } 4772 }
4714 4773
4715 static void 4774 static void
4716 pdump_scan_by_alignement (void (*f)(pdump_entry_list_elmt *, const struct lrecord_description *)) 4775 pdump_scan_by_alignment (void (*f)(pdump_entry_list_elmt *, const struct lrecord_description *))
4717 { 4776 {
4718 int align, i; 4777 int align, i;
4719 const struct lrecord_description *idesc; 4778 const struct lrecord_description *idesc;
4720 pdump_entry_list_elmt *elmt; 4779 pdump_entry_list_elmt *elmt;
4721 for (align=8; align>=0; align--) 4780 for (align=8; align>=0; align--)
4733 elmt = elmt->next; 4792 elmt = elmt->next;
4734 } 4793 }
4735 } 4794 }
4736 4795
4737 for (i=0; i<pdump_struct_table.count; i++) 4796 for (i=0; i<pdump_struct_table.count; i++)
4738 if (pdump_struct_table.list[i].list.align == align) { 4797 if (pdump_struct_table.list[i].list.align == align)
4739 elmt = pdump_struct_table.list[i].list.first; 4798 {
4740 idesc = pdump_struct_table.list[i].sdesc->description; 4799 elmt = pdump_struct_table.list[i].list.first;
4741 while (elmt) 4800 idesc = pdump_struct_table.list[i].sdesc->description;
4742 { 4801 while (elmt)
4743 f (elmt, idesc); 4802 {
4744 elmt = elmt->next; 4803 f (elmt, idesc);
4745 } 4804 elmt = elmt->next;
4746 } 4805 }
4806 }
4747 4807
4748 elmt = pdump_opaque_data_list.first; 4808 elmt = pdump_opaque_data_list.first;
4749 while (elmt) 4809 while (elmt)
4750 { 4810 {
4751 if (align_table[elmt->size & 255] == align) 4811 if (align_table[elmt->size & 255] == align)
4756 } 4816 }
4757 4817
4758 static void 4818 static void
4759 pdump_dump_staticvec (void) 4819 pdump_dump_staticvec (void)
4760 { 4820 {
4761 Lisp_Object *reloc = malloc (staticidx*sizeof (Lisp_Object)); 4821 EMACS_INT *reloc = xnew_array (EMACS_INT, staticidx);
4762 int i; 4822 int i;
4763 write (pdump_fd, staticvec, staticidx*sizeof (Lisp_Object *)); 4823 write (pdump_fd, staticvec, staticidx*sizeof (Lisp_Object *));
4764 4824
4765 for(i=0; i<staticidx; i++) 4825 for (i=0; i<staticidx; i++)
4766 { 4826 {
4767 Lisp_Object obj = *staticvec[i]; 4827 Lisp_Object obj = *staticvec[i];
4768 if (obj && POINTER_TYPE_P (XTYPE (obj))) 4828 if (POINTER_TYPE_P (XTYPE (obj)))
4769 reloc[i] = pdump_get_entry (XRECORD_LHEADER (obj))->save_offset; 4829 reloc[i] = pdump_get_entry (XRECORD_LHEADER (obj))->save_offset;
4770 else 4830 else
4771 reloc[i] = obj; 4831 reloc[i] = *(EMACS_INT *)(staticvec[i]);
4772 } 4832 }
4773 write (pdump_fd, reloc, staticidx*sizeof (Lisp_Object)); 4833 write (pdump_fd, reloc, staticidx*sizeof (Lisp_Object));
4774 free (reloc); 4834 free (reloc);
4775 } 4835 }
4776 4836
4782 { 4842 {
4783 EMACS_INT adr; 4843 EMACS_INT adr;
4784 write (pdump_fd, &(dumpstructvec[i].data), sizeof (void *)); 4844 write (pdump_fd, &(dumpstructvec[i].data), sizeof (void *));
4785 adr = pdump_get_entry (*(void **)(dumpstructvec[i].data))->save_offset; 4845 adr = pdump_get_entry (*(void **)(dumpstructvec[i].data))->save_offset;
4786 write (pdump_fd, &adr, sizeof (adr)); 4846 write (pdump_fd, &adr, sizeof (adr));
4787 } 4847 }
4788 } 4848 }
4789 4849
4790 static void 4850 static void
4791 pdump_dump_itable (void) 4851 pdump_dump_itable (void)
4792 { 4852 {
4801 pdump_reloc_table rt; 4861 pdump_reloc_table rt;
4802 4862
4803 for (i=0; i<=last_lrecord_type_index_assigned; i++) 4863 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4804 { 4864 {
4805 elmt = pdump_object_table[i].first; 4865 elmt = pdump_object_table[i].first;
4806 if(!elmt) 4866 if (!elmt)
4807 continue; 4867 continue;
4808 rt.desc = lrecord_implementations_table[i]->description; 4868 rt.desc = lrecord_implementations_table[i]->description;
4809 rt.count = pdump_object_table[i].count; 4869 rt.count = pdump_object_table[i].count;
4810 write (pdump_fd, &rt, sizeof (rt)); 4870 write (pdump_fd, &rt, sizeof (rt));
4811 while (elmt) 4871 while (elmt)
4812 { 4872 {
4813 EMACS_INT rdata = pdump_get_entry (XRECORD_LHEADER (elmt->obj))->save_offset; 4873 EMACS_INT rdata = pdump_get_entry (elmt->obj)->save_offset;
4814 write (pdump_fd, &rdata, sizeof (rdata)); 4874 write (pdump_fd, &rdata, sizeof (rdata));
4815 elmt = elmt->next; 4875 elmt = elmt->next;
4816 } 4876 }
4817 } 4877 }
4818 4878
4819 rt.desc = 0; 4879 rt.desc = 0;
4820 rt.count = 0; 4880 rt.count = 0;
4821 write (pdump_fd, &rt, sizeof (rt)); 4881 write (pdump_fd, &rt, sizeof (rt));
4822 4882
4826 rt.desc = pdump_struct_table.list[i].sdesc->description; 4886 rt.desc = pdump_struct_table.list[i].sdesc->description;
4827 rt.count = pdump_struct_table.list[i].list.count; 4887 rt.count = pdump_struct_table.list[i].list.count;
4828 write (pdump_fd, &rt, sizeof (rt)); 4888 write (pdump_fd, &rt, sizeof (rt));
4829 while (elmt) 4889 while (elmt)
4830 { 4890 {
4831 EMACS_INT rdata = pdump_get_entry (XRECORD_LHEADER (elmt->obj))->save_offset; 4891 EMACS_INT rdata = pdump_get_entry (elmt->obj)->save_offset;
4832 for (j=0; j<elmt->count; j++) { 4892 for (j=0; j<elmt->count; j++)
4833 write (pdump_fd, &rdata, sizeof (rdata)); 4893 {
4834 rdata += elmt->size; 4894 write (pdump_fd, &rdata, sizeof (rdata));
4835 } 4895 rdata += elmt->size;
4896 }
4836 elmt = elmt->next; 4897 elmt = elmt->next;
4837 } 4898 }
4838 } 4899 }
4839 rt.desc = 0; 4900 rt.desc = 0;
4840 rt.count = 0; 4901 rt.count = 0;
4849 4910
4850 write (pdump_fd, &count, sizeof (count)); 4911 write (pdump_fd, &count, sizeof (count));
4851 4912
4852 for (i=0; i<pdump_wireidx; i++) 4913 for (i=0; i<pdump_wireidx; i++)
4853 { 4914 {
4854 Lisp_Object obj = pdump_get_entry (XRECORD_LHEADER (*(pdump_wirevec[i])))->save_offset; 4915 EMACS_INT obj = pdump_get_entry (XRECORD_LHEADER (*(pdump_wirevec[i])))->save_offset;
4855 write (pdump_fd, &pdump_wirevec[i], sizeof (pdump_wirevec[i])); 4916 write (pdump_fd, &pdump_wirevec[i], sizeof (pdump_wirevec[i]));
4856 write (pdump_fd, &obj, sizeof (obj)); 4917 write (pdump_fd, &obj, sizeof (obj));
4857 } 4918 }
4858 4919
4859 for (i=0; i<pdump_wireidx_list; i++) 4920 for (i=0; i<pdump_wireidx_list; i++)
4860 { 4921 {
4861 Lisp_Object obj = *(pdump_wirevec_list[i]); 4922 Lisp_Object obj = *(pdump_wirevec_list[i]);
4862 pdump_entry_list_elmt *elmt; 4923 pdump_entry_list_elmt *elmt;
4863 EMACS_INT res; 4924 EMACS_INT res;
4864 4925
4865 for(;;) 4926 for (;;)
4866 { 4927 {
4867 const struct lrecord_description *desc; 4928 const struct lrecord_description *desc;
4868 int pos; 4929 int pos;
4869 elmt = pdump_get_entry (XRECORD_LHEADER (obj)); 4930 elmt = pdump_get_entry (XRECORD_LHEADER (obj));
4870 if (elmt) 4931 if (elmt)
4898 4959
4899 Vterminal_console = Qnil; 4960 Vterminal_console = Qnil;
4900 Vterminal_frame = Qnil; 4961 Vterminal_frame = Qnil;
4901 Vterminal_device = Qnil; 4962 Vterminal_device = Qnil;
4902 4963
4903 pdump_hash = malloc (PDUMP_HASHSIZE*sizeof (pdump_entry_list_elmt *)); 4964 pdump_hash = xnew_array_and_zero (pdump_entry_list_elmt *, PDUMP_HASHSIZE);
4904 memset (pdump_hash, 0, PDUMP_HASHSIZE*sizeof (pdump_entry_list_elmt *));
4905 4965
4906 for (i=0; i<=last_lrecord_type_index_assigned; i++) 4966 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4907 { 4967 {
4908 pdump_object_table[i].first = 0; 4968 pdump_object_table[i].first = 0;
4909 pdump_object_table[i].align = 8; 4969 pdump_object_table[i].align = 8;
4922 pdump_register_object (*staticvec[i]); 4982 pdump_register_object (*staticvec[i]);
4923 for (i=0; i<pdump_wireidx; i++) 4983 for (i=0; i<pdump_wireidx; i++)
4924 pdump_register_object (*pdump_wirevec[i]); 4984 pdump_register_object (*pdump_wirevec[i]);
4925 4985
4926 none = 1; 4986 none = 1;
4927 for(i=0;i<=last_lrecord_type_index_assigned;i++) 4987 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4928 if (pdump_alert_undump_object[i]) 4988 if (pdump_alert_undump_object[i])
4929 { 4989 {
4930 if (none) 4990 if (none)
4931 printf ("Undumpable types list :\n"); 4991 printf ("Undumpable types list :\n");
4932 none = 0; 4992 none = 0;
4945 hd.last_type = last_lrecord_type_index_assigned; 5005 hd.last_type = last_lrecord_type_index_assigned;
4946 5006
4947 cur_offset = 256; 5007 cur_offset = 256;
4948 max_size = 0; 5008 max_size = 0;
4949 5009
4950 pdump_scan_by_alignement (pdump_allocate_offset); 5010 pdump_scan_by_alignment (pdump_allocate_offset);
4951 pdump_qnil = pdump_get_entry (XRECORD_LHEADER (Qnil)); 5011 pdump_qnil = pdump_get_entry (XRECORD_LHEADER (Qnil));
4952 5012
4953 pdump_buf = malloc (max_size); 5013 pdump_buf = xmalloc (max_size);
4954 pdump_fd = open ("xemacs.dmp", O_WRONLY|O_CREAT|O_TRUNC, 0666); 5014 /* Avoid use of the `open' macro. We want the real function. */
5015 #undef open
5016 pdump_fd = open ("xemacs.dmp",
5017 O_WRONLY | O_CREAT | O_TRUNC | OPEN_BINARY, 0666);
4955 hd.stab_offset = (cur_offset + 3) & ~3; 5018 hd.stab_offset = (cur_offset + 3) & ~3;
4956 5019
4957 write (pdump_fd, &hd, sizeof (hd)); 5020 write (pdump_fd, &hd, sizeof (hd));
4958 lseek (pdump_fd, 256, SEEK_SET); 5021 lseek (pdump_fd, 256, SEEK_SET);
4959 5022
4960 pdump_scan_by_alignement (pdump_dump_data); 5023 pdump_scan_by_alignment (pdump_dump_data);
4961 5024
4962 lseek (pdump_fd, hd.stab_offset, SEEK_SET); 5025 lseek (pdump_fd, hd.stab_offset, SEEK_SET);
4963 5026
4964 pdump_dump_staticvec (); 5027 pdump_dump_staticvec ();
4965 pdump_dump_structvec (); 5028 pdump_dump_structvec ();
4984 int i; 5047 int i;
4985 char *p; 5048 char *p;
4986 EMACS_INT delta; 5049 EMACS_INT delta;
4987 EMACS_INT count; 5050 EMACS_INT count;
4988 5051
5052 #define PDUMP_READ(p, type) (p = (char*) (((type *) p) + 1), *((type *) p - 1))
5053
4989 pdump_start = pdump_end = 0; 5054 pdump_start = pdump_end = 0;
4990 5055
4991 pdump_fd = open ("xemacs.dmp", O_RDONLY); 5056 pdump_fd = open ("xemacs.dmp", O_RDONLY | OPEN_BINARY);
4992 if (pdump_fd<0) 5057 if (pdump_fd<0)
4993 return 0; 5058 return 0;
4994 5059
4995 length = lseek (pdump_fd, 0, SEEK_END); 5060 length = lseek (pdump_fd, 0, SEEK_END);
4996 lseek (pdump_fd, 0, SEEK_SET); 5061 lseek (pdump_fd, 0, SEEK_SET);
4997 5062
4998 #ifdef HAVE_MMAP 5063 #ifdef HAVE_MMAP
4999 pdump_start = mmap (0, length, PROT_READ|PROT_WRITE, MAP_PRIVATE, pdump_fd, 0); 5064 pdump_start = (char *) mmap (0, length, PROT_READ|PROT_WRITE, MAP_PRIVATE, pdump_fd, 0);
5000 if (pdump_start == MAP_FAILED) 5065 if (pdump_start == MAP_FAILED)
5001 pdump_start = 0; 5066 pdump_start = 0;
5002 #endif 5067 #endif
5003 5068
5004 if (!pdump_start) 5069 if (!pdump_start)
5005 { 5070 {
5006 pdump_start = (void *)((((unsigned long)(malloc(length+255))) + 255) & ~255); 5071 pdump_start = (char *)((((unsigned long)(xmalloc(length+255))) + 255) & ~255);
5007 read(pdump_fd, pdump_start, length); 5072 read (pdump_fd, pdump_start, length);
5008 } 5073 }
5009 5074
5010 close (pdump_fd); 5075 close (pdump_fd);
5011 5076
5012 pdump_end = pdump_start + length; 5077 pdump_end = pdump_start + length;
5013 5078
5014 staticidx = ((dump_header *)(pdump_start))->nb_staticpro; 5079 staticidx = ((dump_header *)(pdump_start))->nb_staticpro;
5015 last_lrecord_type_index_assigned = ((dump_header *)(pdump_start))->last_type; 5080 last_lrecord_type_index_assigned = ((dump_header *)pdump_start)->last_type;
5016 delta = ((EMACS_INT)pdump_start) - ((dump_header *)pdump_start)->reloc_address; 5081 delta = ((EMACS_INT)pdump_start) - ((dump_header *)pdump_start)->reloc_address;
5017 p = pdump_start + ((dump_header *)pdump_start)->stab_offset; 5082 p = pdump_start + ((dump_header *)pdump_start)->stab_offset;
5018 5083
5019 /* Put back the staticvec in place */ 5084 /* Put back the staticvec in place */
5020 memcpy (staticvec, p, staticidx*sizeof (Lisp_Object *)); 5085 memcpy (staticvec, p, staticidx*sizeof (Lisp_Object *));
5021 p += staticidx*sizeof (Lisp_Object *); 5086 p += staticidx*sizeof (Lisp_Object *);
5022 for (i=0; i<staticidx; i++) 5087 for (i=0; i<staticidx; i++)
5023 { 5088 {
5024 Lisp_Object obj = *(Lisp_Object *)p; 5089 Lisp_Object obj = PDUMP_READ (p, Lisp_Object);
5025 p += sizeof (Lisp_Object); 5090 if (POINTER_TYPE_P (XTYPE (obj)))
5026 if (obj && POINTER_TYPE_P (XTYPE (obj))) 5091 XSETOBJ (obj, XTYPE (obj), (char *) XPNTR (obj) + delta);
5027 obj += delta;
5028 *staticvec[i] = obj; 5092 *staticvec[i] = obj;
5029 } 5093 }
5030 5094
5031 /* Put back the dumpstructs */ 5095 /* Put back the dumpstructs */
5032 for (i=0; i<((dump_header *)pdump_start)->nb_structdmp; i++) 5096 for (i=0; i<((dump_header *)pdump_start)->nb_structdmp; i++)
5033 { 5097 {
5034 void **adr = *(void **)p; 5098 void **adr = PDUMP_READ (p, void **);
5035 p += sizeof (void *); 5099 *adr = (void *) (PDUMP_READ (p, char *) + delta);
5036 *adr = (void *)((*(EMACS_INT *)p) + delta);
5037 p += sizeof (EMACS_INT);
5038 } 5100 }
5039 5101
5040 /* Put back the lrecord_implementations_table */ 5102 /* Put back the lrecord_implementations_table */
5041 memcpy (lrecord_implementations_table, p, sizeof (lrecord_implementations_table)); 5103 memcpy (lrecord_implementations_table, p, sizeof (lrecord_implementations_table));
5042 p += sizeof (lrecord_implementations_table); 5104 p += sizeof (lrecord_implementations_table);
5043 5105
5044 /* Give back their numbers to the lrecord implementations */ 5106 /* Give back their numbers to the lrecord implementations */
5045 for (i=0; i<sizeof(lrecord_implementations_table)/sizeof(lrecord_implementations_table[0]); i++) 5107 for (i = 0; i < countof (lrecord_implementations_table); i++)
5046 if (lrecord_implementations_table[i]) 5108 if (lrecord_implementations_table[i])
5047 { 5109 {
5048 *(lrecord_implementations_table[i]->lrecord_type_index) = i; 5110 *(lrecord_implementations_table[i]->lrecord_type_index) = i;
5049 last_lrecord_type_index_assigned = i; 5111 last_lrecord_type_index_assigned = i;
5050 } 5112 }
5051 5113
5052 /* Do the relocations */ 5114 /* Do the relocations */
5053 pdump_rt_list = p; 5115 pdump_rt_list = p;
5054 count = 2; 5116 count = 2;
5055 for(;;) 5117 for (;;)
5056 { 5118 {
5057 pdump_reloc_table *rt = (pdump_reloc_table *)p; 5119 pdump_reloc_table rt = PDUMP_READ (p, pdump_reloc_table);
5058 p += sizeof (pdump_reloc_table); 5120 if (rt.desc)
5059 if (rt->desc) { 5121 {
5060 for (i=0; i<rt->count; i++) 5122 for (i=0; i < rt.count; i++)
5061 { 5123 {
5062 EMACS_INT adr = delta + *(EMACS_INT *)p; 5124 char *adr = delta + *(char **)p;
5063 *(EMACS_INT *)p = adr; 5125 *(char **)p = adr;
5064 pdump_reloc_one ((void *)adr, delta, rt->desc); 5126 pdump_reloc_one (adr, delta, rt.desc);
5065 p += sizeof (EMACS_INT); 5127 p += sizeof (char *);
5066 } 5128 }
5067 } else 5129 } else
5068 if(!(--count)) 5130 if (!(--count))
5069 break; 5131 break;
5070 } 5132 }
5071 5133
5072 /* Put the pdump_wire variables in place */ 5134 /* Put the pdump_wire variables in place */
5073 count = *(EMACS_INT *)p; 5135 count = PDUMP_READ (p, EMACS_INT);
5074 p += sizeof(EMACS_INT);
5075 5136
5076 for (i=0; i<count; i++) 5137 for (i=0; i<count; i++)
5077 { 5138 {
5078 Lisp_Object *var, obj; 5139 Lisp_Object *var = PDUMP_READ (p, Lisp_Object *);
5079 var = *(Lisp_Object **)p; 5140 Lisp_Object obj = PDUMP_READ (p, Lisp_Object);
5080 p += sizeof (Lisp_Object *); 5141
5081 5142 if (POINTER_TYPE_P (XTYPE (obj)))
5082 obj = *(Lisp_Object *)p; 5143 XSETOBJ (obj, XTYPE (obj), (char *) XPNTR (obj) + delta);
5083 p += sizeof (Lisp_Object); 5144
5084
5085 if (obj && POINTER_TYPE_P (XTYPE (obj)))
5086 obj += delta;
5087 *var = obj; 5145 *var = obj;
5088 } 5146 }
5089 5147
5090 /* Final cleanups */ 5148 /* Final cleanups */
5091 /* reorganize hash tables */ 5149 /* reorganize hash tables */
5092 p = pdump_rt_list; 5150 p = pdump_rt_list;
5093 for(;;) 5151 for (;;)
5094 { 5152 {
5095 pdump_reloc_table *rt = (pdump_reloc_table *)p; 5153 pdump_reloc_table rt = PDUMP_READ (p, pdump_reloc_table);
5096 p += sizeof (pdump_reloc_table); 5154 if (!rt.desc)
5097 if (!rt->desc)
5098 break; 5155 break;
5099 if (rt->desc == hash_table_description) 5156 if (rt.desc == hash_table_description)
5100 { 5157 {
5101 for (i=0; i<rt->count; i++) 5158 for (i=0; i < rt.count; i++)
5102 { 5159 pdump_reorganize_hash_table (PDUMP_READ (p, Lisp_Object));
5103 struct Lisp_Hash_Table *ht = XHASH_TABLE (*(EMACS_INT *)p);
5104 reorganize_hash_table (ht);
5105 p += sizeof (EMACS_INT);
5106 }
5107 break; 5160 break;
5108 } else 5161 } else
5109 p += sizeof (EMACS_INT)*rt->count; 5162 p += sizeof (Lisp_Object) * rt.count;
5110 } 5163 }
5111 return 1; 5164 return 1;
5112 } 5165 }
5113 5166
5114 #endif 5167 #endif /* PDUMP */