#include "lstream.h"
#include "sysfile.h"
+#include <limits.h>
#include <float.h>
/* Define if not in float.h */
#ifndef DBL_DIG
CONST Bufbyte *newnonreloc = nonreloc;
struct gcpro gcpro1, gcpro2;
- /* Emacs won't print whilst GCing, but an external debugger might */
+ /* Emacs won't print while GCing, but an external debugger might */
if (gc_in_progress) return;
/* Perhaps not necessary but probably safer. */
static Lisp_Object
print_prepare (Lisp_Object printcharfun, Lisp_Object *frame_kludge)
{
- /* Emacs won't print whilst GCing, but an external debugger might */
+ /* Emacs won't print while GCing, but an external debugger might */
if (gc_in_progress)
return Qnil;
static void
print_finish (Lisp_Object stream, Lisp_Object frame_kludge)
{
- /* Emacs won't print whilst GCing, but an external debugger might */
+ /* Emacs won't print while GCing, but an external debugger might */
if (gc_in_progress)
return;
clear_echo_area_from_print (f, Qnil, 1);
echo_area_append (f, resizing_buffer_stream_ptr (str),
Qnil, 0, Lstream_byte_count (str),
- Vprint_message_label);
+ Vprint_message_label);
Lstream_delete (str);
}
}
}
void
-temp_output_buffer_setup (CONST char *bufname)
+temp_output_buffer_setup (Lisp_Object bufname)
{
/* This function can GC */
struct buffer *old = current_buffer;
so that proper translation on the buffer name can occur. */
#endif
- Fset_buffer (Fget_buffer_create (build_string (bufname)));
+ Fset_buffer (Fget_buffer_create (bufname));
current_buffer->read_only = Qnil;
Ferase_buffer (Qnil);
}
Lisp_Object
-internal_with_output_to_temp_buffer (CONST char *bufname,
+internal_with_output_to_temp_buffer (Lisp_Object bufname,
Lisp_Object (*function) (Lisp_Object arg),
Lisp_Object arg,
Lisp_Object same_frame)
GCPRO3 (buf, arg, same_frame);
- temp_output_buffer_setup (GETTEXT (bufname));
+ temp_output_buffer_setup (bufname);
buf = Vstandard_output;
arg = (*function) (arg);
(args))
{
/* This function can GC */
- struct gcpro gcpro1;
- Lisp_Object name;
+ Lisp_Object name = Qnil;
int speccount = specpdl_depth ();
- Lisp_Object val;
+ struct gcpro gcpro1, gcpro2;
+ Lisp_Object val = Qnil;
#ifdef I18N3
/* #### should set the buffer to be translating. See print_internal(). */
#endif
- GCPRO1 (args);
+ GCPRO2 (name, val);
name = Feval (XCAR (args));
- UNGCPRO;
CHECK_STRING (name);
- temp_output_buffer_setup ((char *) XSTRING_DATA (name));
+
+ temp_output_buffer_setup (name);
+ UNGCPRO;
val = Fprogn (XCDR (args));
write_char_internal ("(", printcharfun);
{
- int i = 0;
- int max = 0;
-
- if (INTP (Vprint_length))
- max = XINT (Vprint_length);
- while (CONSP (obj))
+ int len;
+ int max = INTP (Vprint_length) ? XINT (Vprint_length) : INT_MAX;
+ Lisp_Object tortoise;
+ /* Use tortoise/hare to make sure circular lists don't infloop */
+
+ for (tortoise = obj, len = 0;
+ CONSP (obj);
+ obj = XCDR (obj), len++)
{
- if (i++)
+ if (len > 0)
write_char_internal (" ", printcharfun);
- if (max && i > max)
+ if (EQ (obj, tortoise) && len > 0)
+ {
+ if (print_readably)
+ error ("printing unreadable circular list");
+ else
+ write_c_string ("... <circular list>", printcharfun);
+ break;
+ }
+ if (len & 1)
+ tortoise = XCDR (tortoise);
+ if (len > max)
{
write_c_string ("...", printcharfun);
break;
}
- print_internal (XCAR (obj), printcharfun,
- escapeflag);
- obj = XCDR (obj);
+ print_internal (XCAR (obj), printcharfun, escapeflag);
}
}
if (!LISTP (obj))
print_internal (obj, printcharfun, escapeflag);
}
UNGCPRO;
+
write_char_internal (")", printcharfun);
return;
}
QUIT;
- /* Emacs won't print whilst GCing, but an external debugger might */
+ /* Emacs won't print while GCing, but an external debugger might */
if (gc_in_progress) return;
#ifdef I18N3
print_depth--;
}
-static void
-print_compiled_function_internal (CONST char *start, CONST char *end,
- Lisp_Object obj,
- Lisp_Object printcharfun, int escapeflag)
-{
- /* This function can GC */
- struct Lisp_Compiled_Function *b =
- XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */
- int docp = b->flags.documentationp;
- int intp = b->flags.interactivep;
- struct gcpro gcpro1, gcpro2;
- char buf[100];
- GCPRO2 (obj, printcharfun);
-
- write_c_string (start, printcharfun);
-#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
- if (!print_readably)
- {
- Lisp_Object ann = compiled_function_annotation (b);
- if (!NILP (ann))
- {
- write_c_string ("(from ", printcharfun);
- print_internal (ann, printcharfun, 1);
- write_c_string (") ", printcharfun);
- }
- }
-#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
- /* COMPILED_ARGLIST = 0 */
- print_internal (b->arglist, printcharfun, escapeflag);
- /* COMPILED_BYTECODE = 1 */
- write_char_internal (" ", printcharfun);
- /* we don't really want to see that junk in the bytecode instructions. */
- if (STRINGP (b->bytecodes) && !print_readably)
- {
- sprintf (buf, "\"...(%ld)\"", (long) XSTRING_LENGTH (b->bytecodes));
- write_c_string (buf, printcharfun);
- }
- else
- print_internal (b->bytecodes, printcharfun, escapeflag);
- /* COMPILED_CONSTANTS = 2 */
- write_char_internal (" ", printcharfun);
- print_internal (b->constants, printcharfun, escapeflag);
- /* COMPILED_STACK_DEPTH = 3 */
- sprintf (buf, " %d", b->maxdepth);
- write_c_string (buf, printcharfun);
- /* COMPILED_DOC_STRING = 4 */
- if (docp || intp)
- {
- write_char_internal (" ", printcharfun);
- print_internal (compiled_function_documentation (b), printcharfun,
- escapeflag);
- }
- /* COMPILED_INTERACTIVE = 5 */
- if (intp)
- {
- write_char_internal (" ", printcharfun);
- print_internal (compiled_function_interactive (b), printcharfun,
- escapeflag);
- }
- UNGCPRO;
- write_c_string (end, printcharfun);
-}
-
-void
-print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun,
- int escapeflag)
-{
- /* This function can GC */
- print_compiled_function_internal (((print_readably) ? "#[" :
- "#<compiled-function "),
- ((print_readably) ? "]" : ">"),
- obj, printcharfun, escapeflag);
-}
#ifdef LISP_FLOAT_TYPE
void
{
char pigbuf[350]; /* see comments in float_to_string */
- float_to_string (pigbuf, float_data (XFLOAT (obj)));
+ float_to_string (pigbuf, XFLOAT_DATA (obj));
write_c_string (pigbuf, printcharfun);
}
#endif /* LISP_FLOAT_TYPE */
XSETSTRING (nameobj, name);
for (i = 0; i < size; i++)
{
- Bufbyte c = string_byte (name, i);
-
- if (c == '\"' || c == '\\' || c == '\'' || c == ';' || c == '#' ||
- c == '(' || c == ')' || c == ',' || c =='.' || c == '`' ||
- c == '[' || c == ']' || c == '?' || c <= 040)
+ switch (string_byte (name, i))
{
+ case 0: case 1: case 2: case 3:
+ case 4: case 5: case 6: case 7:
+ case 8: case 9: case 10: case 11:
+ case 12: case 13: case 14: case 15:
+ case 16: case 17: case 18: case 19:
+ case 20: case 21: case 22: case 23:
+ case 24: case 25: case 26: case 27:
+ case 28: case 29: case 30: case 31:
+ case ' ': case '\"': case '\\': case '\'':
+ case ';': case '#' : case '(' : case ')':
+ case ',': case '.' : case '`' :
+ case '[': case ']' : case '?' :
if (i > last)
- {
- output_string (printcharfun, 0, nameobj, last,
- i - last);
- }
+ output_string (printcharfun, 0, nameobj, last, i - last);
write_char_internal ("\\", printcharfun);
last = i;
}
debug_backtrace (void)
{
/* This function can GC */
- int old_print_readably = print_readably;
- int old_print_depth = print_depth;
- Lisp_Object old_print_length = Vprint_length;
- Lisp_Object old_print_level = Vprint_level;
- Lisp_Object old_inhibit_quit = Vinhibit_quit;
+ int old_print_readably = print_readably;
+ int old_print_depth = print_depth;
+ Lisp_Object old_print_length = Vprint_length;
+ Lisp_Object old_print_level = Vprint_level;
+ Lisp_Object old_inhibit_quit = Vinhibit_quit;
+
struct gcpro gcpro1, gcpro2, gcpro3;
GCPRO3 (old_print_level, old_print_length, old_inhibit_quit);
Vprint_length = make_int (debug_print_length);
if (debug_print_level > 0)
Vprint_level = make_int (debug_print_level);
+
Fbacktrace (Qexternal_debugging_output, Qt);
stderr_out ("\n");
fflush (stderr);
- Vinhibit_quit = old_inhibit_quit;
- Vprint_level = old_print_level;
- Vprint_length = old_print_length;
- print_depth = old_print_depth;
+
+ Vinhibit_quit = old_inhibit_quit;
+ Vprint_level = old_print_level;
+ Vprint_length = old_print_length;
+ print_depth = old_print_depth;
print_readably = old_print_readably;
print_unbuffered--;
+
UNGCPRO;
}
if (COMPILED_FUNCTIONP (*bt->function))
{
#if defined(COMPILED_FUNCTION_ANNOTATION_HACK)
- Lisp_Object ann = Fcompiled_function_annotation (*bt->function);
+ Lisp_Object ann =
+ compiled_function_annotation (XCOMPILED_FUNCTION (*bt->function));
#else
Lisp_Object ann = Qnil;
#endif
projects / chise / xemacs-chise.git.1 / blobdiff