xemacs-beta: src/alloc.c comparison

comparison src/alloc.c @ 70:131b0175ea99 r20-0b30

Import from CVS: tag r20-0b30

author	cvs
date	Mon, 13 Aug 2007 09:02:59 +0200
parents	56c54cf7c5b6
children	1ce6082ce73f

comparison

equal deleted inserted replaced

-:804d1389bcd6
+:131b0175ea99
 #ifndef standalone
 #include "backtrace.h"
 #include "buffer.h"
 #include "bytecode.h"
+#include "chartab.h"
 #include "device.h"
 #include "elhash.h"
 #include "events.h"
 #include "extents.h"
 #include "frame.h"
 pure_lossage += size;
 return (0);
 }
 else if (pureptr + size > PURESIZE)
 {
-/* This can cause recursive bad behavior, we'll yell at the end */
+message ("\nERROR:  Pure Lisp storage exhausted!\n");
-/* when we're done. */
-/* message ("\nERROR:  Pure Lisp storage exhausted!\n"); */
 pure_lossage = size;
 return (0);
 }
 else
 return (1);
 b->annotated = Fpurecopy (Vcurrent_compiled_function_annotation);
 else if (!NILP (Vload_file_name_internal_the_purecopy))
 b->annotated = Vload_file_name_internal_the_purecopy;
 else if (!NILP (Vload_file_name_internal))
 {
-	struct gcpro gcpro1;
-	GCPRO1(val);		/* don't let val or b get reaped */
 	Vload_file_name_internal_the_purecopy =
 	  Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal));
 	b->annotated = Vload_file_name_internal_the_purecopy;
-	UNGCPRO;
 }
 #endif
 #ifdef I18N3
 if (docp && intp && domp)
 #ifdef VERIFY_STRING_CHARS_INTEGRITY
 verify_string_chars_integrity ();
 #endif
 }
+#ifdef MULE
+void
+set_string_char (struct Lisp_String *s, Charcount i, Emchar c)
+{
+Bytecount oldlen, newlen;
+Bufbyte newstr[MAX_EMCHAR_LEN];
+Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
+oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
+newlen = set_charptr_emchar (newstr, c);
+if (oldlen != newlen)
+resize_string (s, bytoff, newlen - oldlen);
+/* Remember, string_data (s) might have changed so we can't
+cache it. */
+memcpy (string_data (s) + bytoff, newstr, newlen);
+}
+#endif /* MULE */
 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
 Return a newly created string of length LENGTH, with each element being INIT.
 LENGTH must be an integer and INIT must be a character.
 */
 (length, init))
 and package it up it into a Lisp string. */
 Lisp_Object
 make_string (CONST Bufbyte *contents, Bytecount length)
 {
 Lisp_Object val;
+/* Make sure we find out about bad make_string's when they happen */
+#if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
+bytecount_to_charcount (contents, length); /* Just for the assertions */
+#endif
 val = make_uninit_string (length);
 memcpy (XSTRING_DATA (val), contents, length);
 return (val);
 }
 	(struct free_lcrecord_header *) lheader;
 #ifdef ERROR_CHECK_GC
 CONST struct lrecord_implementation *implementation
 	= lheader->implementation;
 /* There should be no other pointers to the free list. */
 assert (!MARKED_RECORD_HEADER_P (lheader));
 /* Only lcrecords should be here. */
 assert (!implementation->basic_p);
 /* Only free lcrecords should be here. */
 assert (implementation == list->implementation);
 /* So must the size. */
 assert (implementation->static_size == 0
 	      || implementation->static_size == list->size);
 #endif /* ERROR_CHECK_GC */
 MARK_RECORD_HEADER (lheader);
 chain = free_header->chain;
 }
 return Qnil;
 {
 if (COMPILED_FUNCTIONP (obj))
 {
 struct Lisp_Compiled_Function *o = XCOMPILED_FUNCTION (obj);
 Lisp_Object new = make_compiled_function (1);
-	    /* How on earth could this code have worked before?  -sb */
+struct Lisp_Compiled_Function *n = XCOMPILED_FUNCTION (obj);
-struct Lisp_Compiled_Function *n = XCOMPILED_FUNCTION (new);
 n->flags = o->flags;
 n->bytecodes = Fpurecopy (o->bytecodes);
 n->constants = Fpurecopy (o->constants);
 n->arglist = Fpurecopy (o->arglist);
 n->doc_and_interactive = Fpurecopy (o->doc_and_interactive);
-	    n->maxdepth = o->maxdepth;
 return (new);
 }
 #ifdef LISP_FLOAT_TYPE
 else if (FLOATP (obj))
 return make_pure_float (float_data (XFLOAT (obj)));
 return (obj);
 }
-static void
-PURESIZE_h(long int puresize)
-{
-int fd;
-char *PURESIZE_h_file = "puresize_adjust.h";
-char *WARNING = "/* This file is generated by XEmacs, DO NOT MODIFY!!! */\n";
-char define_PURESIZE[256];
-if ((fd = open(PURESIZE_h_file, O_WRONLY|O_CREAT|O_TRUNC, 0666)) < 0) {
-report_file_error("Can't write PURESIZE_ADJUSTMENT",
-		      Fcons(build_ext_string(PURESIZE_h_file, FORMAT_FILENAME),
-			    Qnil));
-}
-write(fd, WARNING, strlen(WARNING));
-sprintf(define_PURESIZE, "# define PURESIZE_ADJUSTMENT %ld\n",
-	  puresize - RAW_PURESIZE);
-write(fd, define_PURESIZE, strlen(define_PURESIZE));
-close(fd);
-}
 void
 report_pure_usage (int report_impurities,
 int die_if_pure_storage_exceeded)
 {
-int rc = 0;
 if (pure_lossage)
 {
 CONST long report_round = 5000;
 message ("\n****\tPure Lisp storage exhausted!\n"
-"\tPurespace usage: %ld of %ld\n"
+"\tCheck whether you are loading .el files when .elc files were intended.\n"
+"\tOtherwise, increase PURESIZE in puresize.h and relink.\n\n"
+"\tPURESIZE is presently %ld.\n"
+"\tAn additional %ld bytes will guarantee enough pure space;\n"
+"\ta smaller increment may work (due to structure-sharing).\n"
 "****",
-PURESIZE+pure_lossage, PURESIZE);
+	       (long) PURESIZE,
-if (die_if_pure_storage_exceeded) {
+(((pure_lossage + report_round - 1)
-	PURESIZE_h(PURESIZE + pure_lossage);
+/ report_round) * report_round));
-	rc = -1;
-}
 }
 else
 {
 int lost = (PURESIZE - pureptr) / 1024;
 char buf[200];
 sprintf (buf, "Purespace usage: %ld of %ld (%d%%",
 pureptr, (long) PURESIZE,
 (int) (pureptr / (PURESIZE / 100.0) + 0.5));
-if (lost > 2) {
+if (lost > 2)
 sprintf (buf + strlen (buf), " -- %dk wasted", lost);
-	if (die_if_pure_storage_exceeded) {
-	  PURESIZE_h(pureptr + 16);
-	  rc = -1;
-	}
-}
 strcat (buf, ").");
 message ("%s", buf);
 }
 #ifdef PURESTAT
 UNGCPRO;
 garbage_collect_1 ();         /* GC garbage_collect's garbage */
 }
 clear_message ();
-if (rc < 0) {
+if (pure_lossage && die_if_pure_storage_exceeded)
-(void)unlink("SATISFIED");
-fatal ("Pure size adjusted, will restart `make'");
-} else if (pure_lossage && die_if_pure_storage_exceeded) {
 fatal ("Pure storage exhausted");
-}
 }
 /**********************************************************************/
 /*                            staticpro                               */
 }
 #endif /* not standalone */
+#if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
+static void
+verify_string_chars_integrity (void)
+{
+struct string_chars_block *sb;
+/* Scan each existing string block sequentially, string by string.  */
+for (sb = first_string_chars_block; sb; sb = sb->next)
+{
+int pos = 0;
+/* POS is the index of the next string in the block.  */
+while (pos < sb->pos)
+{
+struct string_chars *s_chars =
+(struct string_chars *) &(sb->string_chars[pos]);
+struct Lisp_String *string;
+	  int size;
+	  int fullsize;
+	  /* If the string_chars struct is marked as free (i.e. the STRING
+	     pointer is 0xFFFFFFFF) then this is an unused chunk of string
+storage. (See below.) */
+	  if (FREE_STRUCT_P (s_chars))
+	    {
+	      fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
+	      pos += fullsize;
+	      continue;
+}
+string = s_chars->string;
+	  /* Must be 32-bit aligned. */
+	  assert ((((int) string) & 3) == 0);
+size = string_length (string);
+fullsize = STRING_FULLSIZE (size);
+assert (!BIG_STRING_FULLSIZE_P (fullsize));
+	  assert (string_data (string) == s_chars->chars);
+	  pos += fullsize;
+}
+assert (pos == sb->pos);
+}
+}
+#endif /* MULE && ERROR_CHECK_GC */
 /* Compactify string chars, relocating the reference to each --
 free any empty string_chars_block we see. */
 static void
 compact_string_chars (void)
 {
 /* Yeah, this list is pretty ad-hoc... */
 Vprocess_environment = Qnil;
 Vexec_directory = Qnil;
 Vdata_directory = Qnil;
-Vsite_directory = Qnil;
 Vdoc_directory = Qnil;
 Vconfigure_info_directory = Qnil;
 Vexec_path = Qnil;
 Vload_path = Qnil;
 /* Vdump_load_path = Qnil; */
 /* #### this is somewhat ad-hoc and should probably be an object
 method */
 prune_weak_hashtables (marked_p);
 prune_weak_lists (marked_p);
 prune_specifiers (marked_p);
+prune_syntax_tables (marked_p);
 gc_sweep ();
 consing_since_gc = 0;
 #ifndef DEBUG_XEMACS
 ())
 {
 Lisp_Object pl = Qnil;
 Lisp_Object ret[6];
 int i;
-if (purify_flag && pure_lossage)
-{
-return Qnil;
-}
 garbage_collect_1 ();
 for (i = 0; i < last_lrecord_type_index_assigned; i++)
 {

Mercurial > hg > xemacs-beta

comparison src/alloc.c @ 70:131b0175ea99 r20-0b30