-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 ();