+ s = (struct Lisp_String *) (PUREBEG + pure_bytes_used);
+#ifdef LRECORD_STRING
+ set_lheader_implementation (&(s->lheader), lrecord_string);
+#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
+ s->lheader.pure = 1;
+#endif
+#endif
+ set_string_length (s, length);
+ if (no_need_to_copy_data)
+ {
+ set_string_data (s, (Bufbyte *) data);
+ }
+ else
+ {
+ set_string_data (s, (Bufbyte *) s + sizeof (struct Lisp_String));
+ memcpy (string_data (s), data, length);
+ set_string_byte (s, length, 0);
+ }
+ s->plist = Qnil;
+ pure_bytes_used += size;
+
+#ifdef PURESTAT
+ bump_purestat (&purestat_string_all, size);
+ if (purecopying_for_bytecode)
+ bump_purestat (&purestat_string_other_function, size);
+#endif /* PURESTAT */
+
+ /* Do this after the official "completion" of the purecopying. */
+ s->plist = Fpurecopy (plist);
+
+ XSETSTRING (new, s);
+ return new;
+}
+
+
+Lisp_Object
+make_pure_pname (CONST Bufbyte *data, Bytecount length,
+ int no_need_to_copy_data)
+{
+ Lisp_Object name = make_pure_string (data, length, Qnil,
+ no_need_to_copy_data);
+ bump_purestat (&purestat_string_pname, pure_sizeof (name));
+
+ /* We've made (at least) Qnil now, and Vobarray will soon be set up. */
+ symbols_initialized = 1;
+
+ return name;
+}
+
+
+Lisp_Object
+pure_cons (Lisp_Object car, Lisp_Object cdr)
+{
+ Lisp_Object new;
+ struct Lisp_Cons *c;
+
+ if (!check_purespace (sizeof (struct Lisp_Cons)))
+ return Fcons (Fpurecopy (car), Fpurecopy (cdr));
+
+ c = (struct Lisp_Cons *) (PUREBEG + pure_bytes_used);
+#ifdef LRECORD_CONS
+ set_lheader_implementation (&(c->lheader), lrecord_cons);
+#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
+ c->lheader.pure = 1;
+#endif
+#endif
+ pure_bytes_used += sizeof (struct Lisp_Cons);
+ bump_purestat (&purestat_cons, sizeof (struct Lisp_Cons));
+
+ c->car = Fpurecopy (car);
+ c->cdr = Fpurecopy (cdr);
+ XSETCONS (new, c);
+ return new;
+}
+
+Lisp_Object
+pure_list (int nargs, Lisp_Object *args)
+{
+ Lisp_Object val = Qnil;
+
+ for (--nargs; nargs >= 0; nargs--)
+ val = pure_cons (args[nargs], val);
+
+ return val;
+}
+
+#ifdef LISP_FLOAT_TYPE
+
+static Lisp_Object
+make_pure_float (double num)
+{
+ struct Lisp_Float *f;
+ Lisp_Object val;
+
+ /* Make sure that PUREBEG + pure_bytes_used is aligned on at least a sizeof
+ (double) boundary. Some architectures (like the sparc) require
+ this, and I suspect that floats are rare enough that it's no
+ tragedy for those that don't. */
+ {
+#if defined (__GNUC__) && (__GNUC__ >= 2)
+ /* In gcc, we can directly ask what the alignment constraints of a
+ structure are, but in general, that's not possible... Arrgh!!
+ */
+ int alignment = __alignof (struct Lisp_Float);
+#else /* !GNUC */
+ /* Best guess is to make the `double' slot be aligned to the size
+ of double (which is probably 8 bytes). This assumes that it's
+ ok to align the beginning of the structure to the same boundary
+ that the `double' slot in it is supposed to be aligned to; this
+ should be ok because presumably there is padding in the layout
+ of the struct to account for this.
+ */
+ int alignment = sizeof (float_data (f));
+#endif /* !GNUC */
+ char *p = ((char *) PUREBEG + pure_bytes_used);
+
+ p = (char *) (((EMACS_UINT) p + alignment - 1) & - alignment);
+ pure_bytes_used = p - (char *) PUREBEG;
+ }
+
+ if (!check_purespace (sizeof (struct Lisp_Float)))
+ return make_float (num);
+
+ f = (struct Lisp_Float *) (PUREBEG + pure_bytes_used);
+ set_lheader_implementation (&(f->lheader), lrecord_float);
+#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
+ f->lheader.pure = 1;
+#endif
+ pure_bytes_used += sizeof (struct Lisp_Float);
+ bump_purestat (&purestat_float, sizeof (struct Lisp_Float));
+
+ float_data (f) = num;
+ XSETFLOAT (val, f);
+ return val;
+}
+
+#endif /* LISP_FLOAT_TYPE */
+
+Lisp_Object
+make_pure_vector (size_t len, Lisp_Object init)
+{
+ Lisp_Object new;
+ struct Lisp_Vector *v;
+ size_t size = (sizeof (struct Lisp_Vector)
+ + (len - 1) * sizeof (Lisp_Object));
+
+ init = Fpurecopy (init);
+
+ if (!check_purespace (size))
+ return make_vector (len, init);
+
+ v = (struct Lisp_Vector *) (PUREBEG + pure_bytes_used);
+#ifdef LRECORD_VECTOR
+ set_lheader_implementation (&(v->header.lheader), lrecord_vector);
+#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
+ v->header.lheader.pure = 1;
+#endif
+#endif
+ pure_bytes_used += size;
+ bump_purestat (&purestat_vector_all, size);
+
+ v->size = len;
+
+ for (size = 0; size < len; size++)
+ v->contents[size] = init;
+
+ XSETVECTOR (new, v);
+ return new;
+}
+
+#if 0
+/* Presently unused */
+void *
+alloc_pure_lrecord (int size, struct lrecord_implementation *implementation)
+{
+ struct lrecord_header *header = (void *) (PUREBEG + pure_bytes_used);
+
+ if (pure_bytes_used + size > get_PURESIZE())
+ pure_storage_exhausted ();
+
+ set_lheader_implementation (header, implementation);
+ header->next = 0;
+ return header;
+}
+#endif /* unused */
+
+
+\f
+DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
+Make a copy of OBJECT in pure storage.
+Recursively copies contents of vectors and cons cells.
+Does not copy symbols.
+*/
+ (obj))
+{
+ int i;
+ if (!purify_flag)
+ return obj;
+
+ if (!POINTER_TYPE_P (XTYPE (obj))
+ || PURIFIED (XPNTR (obj))
+ /* happens when bootstrapping Qnil */
+ || EQ (obj, Qnull_pointer))
+ return obj;
+
+ switch (XTYPE (obj))
+ {
+#ifndef LRECORD_CONS
+ case Lisp_Type_Cons:
+ return pure_cons (XCAR (obj), XCDR (obj));
+#endif
+
+#ifndef LRECORD_STRING
+ case Lisp_Type_String:
+ return make_pure_string (XSTRING_DATA (obj),
+ XSTRING_LENGTH (obj),
+ XSTRING (obj)->plist,
+ 0);
+#endif /* ! LRECORD_STRING */
+
+#ifndef LRECORD_VECTOR
+ case Lisp_Type_Vector:
+ {
+ struct Lisp_Vector *o = XVECTOR (obj);
+ Lisp_Object new = make_pure_vector (vector_length (o), Qnil);
+ for (i = 0; i < vector_length (o); i++)
+ XVECTOR_DATA (new)[i] = Fpurecopy (o->contents[i]);
+ return new;
+ }
+#endif /* !LRECORD_VECTOR */
+
+ default:
+ {
+ 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 (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 LRECORD_CONS
+ else if (CONSP (obj))
+ return pure_cons (XCAR (obj), XCDR (obj));
+#endif /* LRECORD_CONS */
+#ifdef LRECORD_VECTOR
+ else if (VECTORP (obj))
+ {
+ struct Lisp_Vector *o = XVECTOR (obj);
+ Lisp_Object new = make_pure_vector (vector_length (o), Qnil);
+ for (i = 0; i < vector_length (o); i++)
+ XVECTOR_DATA (new)[i] = Fpurecopy (o->contents[i]);
+ return new;
+ }
+#endif /* LRECORD_VECTOR */
+#ifdef LRECORD_STRING
+ else if (STRINGP (obj))
+ {
+ return make_pure_string (XSTRING_DATA (obj),
+ XSTRING_LENGTH (obj),
+ XSTRING (obj)->plist,
+ 0);
+ }
+#endif /* LRECORD_STRING */
+#ifdef LISP_FLOAT_TYPE
+ else if (FLOATP (obj))
+ return make_pure_float (float_data (XFLOAT (obj)));
+#endif /* LISP_FLOAT_TYPE */
+ else if (SYMBOLP (obj))
+ {
+ /*
+ * Symbols can't be made pure (and thus read-only),
+ * because assigning to their function, value or plist
+ * slots would produced a SEGV in the dumped XEmacs. So
+ * we previously would just return the symbol unchanged.
+ *
+ * But purified aggregate objects like lists and vectors
+ * can contain uninterned symbols. If there are no
+ * other non-pure references to the symbol, then the
+ * symbol is not protected from garbage collection
+ * because the collector does not mark the contents of
+ * purified objects. So to protect the symbols, an impure
+ * reference has to be kept for each uninterned symbol
+ * that is referenced by a pure object. All such
+ * symbols are stored in the hashtable pointed to by
+ * Vpure_uninterned_symbol_table, which is itself
+ * staticpro'd.
+ */
+ if (!NILP (XSYMBOL (obj)->obarray))
+ return obj;
+ Fputhash (obj, Qnil, Vpure_uninterned_symbol_table);
+ return obj;
+ }
+ else
+ signal_simple_error ("Can't purecopy %S", obj);
+ }
+ }
+ return obj;
+}
+
+
+\f
+static void
+puresize_adjust_h (size_t puresize)
+{
+ FILE *stream = fopen ("puresize-adjust.h", "w");
+
+ if (stream == NULL)
+ report_file_error ("Opening puresize adjustment file",
+ Fcons (build_string ("puresize-adjust.h"), Qnil));
+
+ fprintf (stream,
+ "/*\tDo not edit this file!\n"
+ "\tAutomatically generated by XEmacs */\n"
+ "# define PURESIZE_ADJUSTMENT (%ld)\n",
+ (long) (puresize - RAW_PURESIZE));
+ fclose (stream);
+}
+
+void
+report_pure_usage (int report_impurities,
+ int die_if_pure_storage_exceeded)
+{
+ int rc = 0;
+
+ if (pure_lossage)
+ {
+ message ("\n****\tPure Lisp storage exhausted!\n"
+ "\tPurespace usage: %ld of %ld\n"
+ "****",
+ (long) get_PURESIZE() + pure_lossage,
+ (long) get_PURESIZE());
+ if (die_if_pure_storage_exceeded)
+ {
+ puresize_adjust_h (get_PURESIZE() + pure_lossage);
+#ifdef HEAP_IN_DATA
+ sheap_adjust_h();
+#endif
+ rc = -1;
+ }
+ }
+ else
+ {
+ size_t lost = (get_PURESIZE() - pure_bytes_used) / 1024;
+ char buf[200];
+ /* extern Lisp_Object Vemacs_beta_version; */
+ /* This used to be NILP(Vemacs_beta_version) ? 512 : 4; */
+#ifndef PURESIZE_SLOP
+#define PURESIZE_SLOP 0
+#endif
+ size_t slop = PURESIZE_SLOP;
+
+ sprintf (buf, "Purespace usage: %ld of %ld (%d%%",
+ (long) pure_bytes_used,
+ (long) get_PURESIZE(),
+ (int) (pure_bytes_used / (get_PURESIZE() / 100.0) + 0.5));
+ if (lost > ((slop ? slop : 1) / 1024)) {
+ sprintf (buf + strlen (buf), " -- %ldk wasted", (long)lost);
+ if (die_if_pure_storage_exceeded) {
+ puresize_adjust_h (pure_bytes_used + slop);
+#ifdef HEAP_IN_DATA
+ sheap_adjust_h();
+#endif
+ rc = -1;
+ }
+ }
+
+ strcat (buf, ").");
+ message ("%s", buf);
+ }
+
+#ifdef PURESTAT
+
+ purestat_vector_other.nbytes =
+ purestat_vector_all.nbytes -
+ purestat_vector_bytecode_constants.nbytes;
+ purestat_vector_other.nobjects =
+ purestat_vector_all.nobjects -
+ purestat_vector_bytecode_constants.nobjects;
+
+ purestat_string_other.nbytes =
+ purestat_string_all.nbytes -
+ (purestat_string_pname.nbytes +
+ purestat_string_bytecodes.nbytes +
+ purestat_string_interactive.nbytes +
+ purestat_string_documentation.nbytes +
+#ifdef I18N3
+ purestat_string_domain.nbytes +
+#endif
+ purestat_string_other_function.nbytes);
+
+ purestat_string_other.nobjects =
+ purestat_string_all.nobjects -
+ (purestat_string_pname.nobjects +
+ purestat_string_bytecodes.nobjects +
+ purestat_string_interactive.nobjects +
+ purestat_string_documentation.nobjects +
+#ifdef I18N3
+ purestat_string_domain.nobjects +
+#endif
+ purestat_string_other_function.nobjects);
+
+ message (" %-26s Total Bytes", "");
+
+ {
+ int j;
+
+ for (j = 0; j < countof (purestats); j++)
+ if (!purestats[j])
+ clear_message ();
+ else
+ {
+ char buf [100];
+ sprintf(buf, "%s:", purestats[j]->name);
+ message (" %-26s %5d %7d %2d%%",
+ buf,
+ purestats[j]->nobjects,
+ purestats[j]->nbytes,
+ (int) (purestats[j]->nbytes / (pure_bytes_used / 100.0) + 0.5));
+ }
+ }
+#endif /* PURESTAT */
+
+
+ if (report_impurities)
+ {
+ Lisp_Object tem = Felt (Fgarbage_collect (), make_int (5));
+ struct gcpro gcpro1;
+ GCPRO1 (tem);
+ message ("\nImpurities:");
+ while (!NILP (tem))
+ {
+ if (CONSP (tem) && SYMBOLP (Fcar (tem)) && CONSP (Fcdr (tem)))
+ {
+ int total = XINT (Fcar (Fcdr (tem)));
+ if (total > 0)
+ {
+ char buf [100];
+ char *s = buf;
+ memcpy (buf, string_data (XSYMBOL (Fcar (tem))->name),
+ string_length (XSYMBOL (Fcar (tem))->name) + 1);
+ while (*s++) if (*s == '-') *s = ' ';
+ s--; *s++ = ':'; *s = 0;
+ message (" %-33s %6d", buf, total);
+ }
+ tem = Fcdr (Fcdr (tem));
+ }
+ else /* WTF?! */
+ {
+ Fprin1 (tem, Qexternal_debugging_output);
+ tem = Qnil;
+ }
+ }
+ UNGCPRO;
+ garbage_collect_1 (); /* GC garbage_collect's garbage */
+ }
+ clear_message ();
+
+ if (rc < 0) {
+ unlink("SATISFIED");
+ fatal ("Pure size adjusted, Don't Panic! I will restart the `make'");
+ } else if (pure_lossage && die_if_pure_storage_exceeded) {
+ fatal ("Pure storage exhausted");
+ }
+}
+
+\f
+/**********************************************************************/
+/* staticpro */
+/**********************************************************************/