/* Lisp object printing and output streams.
- Copyright (C) 1985, 1986, 1988, 1993, 1994 Free Software Foundation, Inc.
+ Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc.
This file is part of GNU Emacs.
You should have received a copy of the GNU General Public License
along with GNU Emacs; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
#include <config.h>
#include <stdio.h>
-#undef NULL
#include "lisp.h"
#ifndef standalone
#include "process.h"
#include "dispextern.h"
#include "termchar.h"
+#include "keyboard.h"
#endif /* not standalone */
#ifdef USE_TEXT_PROPERTIES
}
/* Print the contents of a string STRING using PRINTCHARFUN.
- It isn't safe to use strout, because printing one char can relocate. */
+ It isn't safe to use strout in many cases,
+ because printing one char can relocate. */
print_string (string, printcharfun)
Lisp_Object string;
Lisp_Object printcharfun;
{
- if (EQ (printcharfun, Qnil) || EQ (printcharfun, Qt))
- /* In predictable cases, strout is safe: output to buffer or frame. */
+ if (EQ (printcharfun, Qt))
+ /* strout is safe for output to a frame (echo area). */
strout (XSTRING (string)->data, XSTRING (string)->size, printcharfun);
+ else if (EQ (printcharfun, Qnil))
+ {
+#ifdef MAX_PRINT_CHARS
+ if (max_print)
+ print_chars += XSTRING (string)->size;
+#endif /* MAX_PRINT_CHARS */
+ insert_from_string (string, 0, XSTRING (string)->size, 1);
+ }
else
{
/* Otherwise, fetch the string address for each character. */
}
\f
DEFUN ("write-char", Fwrite_char, Swrite_char, 1, 2, 0,
- "Output character CHAR to stream PRINTCHARFUN.\n\
+ "Output character CHARACTER to stream PRINTCHARFUN.\n\
PRINTCHARFUN defaults to the value of `standard-output' (which see).")
- (ch, printcharfun)
- Lisp_Object ch, printcharfun;
+ (character, printcharfun)
+ Lisp_Object character, printcharfun;
{
struct buffer *old = current_buffer;
int old_point = -1;
if (NILP (printcharfun))
printcharfun = Vstandard_output;
- CHECK_NUMBER (ch, 0);
+ CHECK_NUMBER (character, 0);
PRINTPREPARE;
- PRINTCHAR (XINT (ch));
+ PRINTCHAR (XINT (character));
PRINTFINISH;
- return ch;
+ return character;
}
/* Used from outside of print.c to print a block of SIZE chars at DATA
Fset_buffer (Fget_buffer_create (build_string (bufname)));
+ current_buffer->directory = old->directory;
current_buffer->read_only = Qnil;
Ferase_buffer ();
Quoting characters are printed when needed to make output that `read'\n\
can handle, whenever this is possible.\n\
Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
- (obj, printcharfun)
- Lisp_Object obj, printcharfun;
+ (object, printcharfun)
+ Lisp_Object object, printcharfun;
{
struct buffer *old = current_buffer;
int old_point = -1;
printcharfun = Vstandard_output;
PRINTPREPARE;
print_depth = 0;
- print (obj, printcharfun, 1);
+ print (object, printcharfun, 1);
PRINTFINISH;
- return obj;
+ return object;
}
/* a buffer which is used to hold output being built by prin1-to-string */
any Lisp object. Quoting characters are used when needed to make output\n\
that `read' can handle, whenever this is possible, unless the optional\n\
second argument NOESCAPE is non-nil.")
- (obj, noescape)
- Lisp_Object obj, noescape;
+ (object, noescape)
+ Lisp_Object object, noescape;
{
struct buffer *old = current_buffer;
int old_point = -1;
int start_point;
Lisp_Object original, printcharfun;
- struct gcpro gcpro1;
+ struct gcpro gcpro1, gcpro2;
+ Lisp_Object tem;
+
+ /* Save and restore this--we are altering a buffer
+ but we don't want to deactivate the mark just for that.
+ No need for specbind, since errors deactivate the mark. */
+ tem = Vdeactivate_mark;
+ GCPRO2 (object, tem);
printcharfun = Vprin1_to_string_buffer;
PRINTPREPARE;
print_depth = 0;
- print (obj, printcharfun, NILP (noescape));
+ print (object, printcharfun, NILP (noescape));
/* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
PRINTFINISH;
set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
- obj = Fbuffer_string ();
+ object = Fbuffer_string ();
- GCPRO1 (obj);
Ferase_buffer ();
set_buffer_internal (old);
+
+ Vdeactivate_mark = tem;
UNGCPRO;
- return obj;
+ return object;
}
DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0,
No quoting characters are used; no delimiters are printed around\n\
the contents of strings.\n\
Output stream is PRINTCHARFUN, or value of standard-output (which see).")
- (obj, printcharfun)
- Lisp_Object obj, printcharfun;
+ (object, printcharfun)
+ Lisp_Object object, printcharfun;
{
struct buffer *old = current_buffer;
int old_point = -1;
printcharfun = Vstandard_output;
PRINTPREPARE;
print_depth = 0;
- print (obj, printcharfun, 0);
+ print (object, printcharfun, 0);
PRINTFINISH;
- return obj;
+ return object;
}
DEFUN ("print", Fprint, Sprint, 1, 2, 0,
Quoting characters are printed when needed to make output that `read'\n\
can handle, whenever this is possible.\n\
Output stream is PRINTCHARFUN, or value of `standard-output' (which see).")
- (obj, printcharfun)
- Lisp_Object obj, printcharfun;
+ (object, printcharfun)
+ Lisp_Object object, printcharfun;
{
struct buffer *old = current_buffer;
int old_point = -1;
#endif /* MAX_PRINT_CHARS */
if (NILP (printcharfun))
printcharfun = Vstandard_output;
- GCPRO1 (obj);
+ GCPRO1 (object);
PRINTPREPARE;
print_depth = 0;
PRINTCHAR ('\n');
- print (obj, printcharfun, 1);
+ print (object, printcharfun, 1);
PRINTCHAR ('\n');
PRINTFINISH;
#ifdef MAX_PRINT_CHARS
print_chars = 0;
#endif /* MAX_PRINT_CHARS */
UNGCPRO;
- return obj;
+ return object;
}
/* The subroutine object for external-debugging-output is kept here
Lisp_Object arg;
{
Fprin1 (arg, Qexternal_debugging_output);
+ fprintf (stderr, "\r\n");
+}
+\f
+DEFUN ("error-message-string", Ferror_message_string, Serror_message_string,
+ 1, 1, 0,
+ "Convert an error value (ERROR-SYMBOL . DATA) to an error message.")
+ (obj)
+ Lisp_Object obj;
+{
+ struct buffer *old = current_buffer;
+ Lisp_Object original, printcharfun, value;
+ struct gcpro gcpro1;
+
+ print_error_message (obj, Vprin1_to_string_buffer, NULL);
+
+ set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
+ value = Fbuffer_string ();
+
+ GCPRO1 (value);
+ Ferase_buffer ();
+ set_buffer_internal (old);
+ UNGCPRO;
+
+ return value;
+}
+
+/* Print an error message for the error DATA
+ onto Lisp output stream STREAM (suitable for the print functions). */
+
+print_error_message (data, stream)
+ Lisp_Object data, stream;
+{
+ Lisp_Object errname, errmsg, file_error, tail;
+ struct gcpro gcpro1;
+ int i;
+
+ errname = Fcar (data);
+
+ if (EQ (errname, Qerror))
+ {
+ data = Fcdr (data);
+ if (!CONSP (data)) data = Qnil;
+ errmsg = Fcar (data);
+ file_error = Qnil;
+ }
+ else
+ {
+ errmsg = Fget (errname, Qerror_message);
+ file_error = Fmemq (Qfile_error,
+ Fget (errname, Qerror_conditions));
+ }
+
+ /* Print an error message including the data items. */
+
+ tail = Fcdr_safe (data);
+ GCPRO1 (tail);
+
+ /* For file-error, make error message by concatenating
+ all the data items. They are all strings. */
+ if (!NILP (file_error) && !NILP (tail))
+ errmsg = XCONS (tail)->car, tail = XCONS (tail)->cdr;
+
+ if (STRINGP (errmsg))
+ Fprinc (errmsg, stream);
+ else
+ write_string_1 ("peculiar error", -1, stream);
+
+ for (i = 0; CONSP (tail); tail = Fcdr (tail), i++)
+ {
+ write_string_1 (i ? ", " : ": ", 2, stream);
+ if (!NILP (file_error))
+ Fprinc (Fcar (tail), stream);
+ else
+ Fprin1 (Fcar (tail), stream);
+ }
+ UNGCPRO;
}
\f
#ifdef LISP_FLOAT_TYPE
/*
* The buffer should be at least as large as the max string size of the
- * largest float, printed in the biggest notation. This is undoubtably
+ * largest float, printed in the biggest notation. This is undoubtedly
* 20d float_output_format, with the negative of the C-constant "HUGE"
* from <math.h>.
*
/* Check the width specification. */
width = -1;
if ('0' <= *cp && *cp <= '9')
- for (width = 0; (*cp >= '0' && *cp <= '9'); cp++)
- width = (width * 10) + (*cp - '0');
+ {
+ width = 0;
+ do
+ width = (width * 10) + (*cp++ - '0');
+ while (*cp >= '0' && *cp <= '9');
+
+ /* A precision of zero is valid only for %f. */
+ if (width > DBL_DIG
+ || (width == 0 && *cp != 'f'))
+ goto lose;
+ }
if (*cp != 'e' && *cp != 'f' && *cp != 'g')
goto lose;
- /* A precision of zero is valid for %f; everything else requires
- at least one. Width may be omitted anywhere. */
- if (width != -1
- && (width < (*cp != 'f')
- || width > DBL_DIG))
- goto lose;
-
if (cp[1] != 0)
goto lose;
switch (XGCTYPE (obj))
{
case Lisp_Int:
- sprintf (buf, "%d", XINT (obj));
+ if (sizeof (int) == sizeof (EMACS_INT))
+ sprintf (buf, "%d", XINT (obj));
+ else if (sizeof (long) == sizeof (EMACS_INT))
+ sprintf (buf, "%ld", XINT (obj));
+ else
+ abort ();
strout (buf, -1, printcharfun);
break;
else
print_string (XPROCESS (obj)->name, printcharfun);
}
+ else if (BOOL_VECTOR_P (obj))
+ {
+ register int i;
+ register unsigned char c;
+ struct gcpro gcpro1;
+ int size_in_chars
+ = (XBOOL_VECTOR (obj)->size + BITS_PER_CHAR) / BITS_PER_CHAR;
+
+ GCPRO1 (obj);
+
+ PRINTCHAR ('#');
+ PRINTCHAR ('&');
+ sprintf (buf, "%d", XBOOL_VECTOR (obj)->size);
+ strout (buf, -1, printcharfun);
+ PRINTCHAR ('\"');
+
+ /* Don't print more characters than the specified maximum. */
+ if (INTEGERP (Vprint_length)
+ && XINT (Vprint_length) < size_in_chars)
+ size_in_chars = XINT (Vprint_length);
+
+ for (i = 0; i < size_in_chars; i++)
+ {
+ QUIT;
+ c = XBOOL_VECTOR (obj)->data[i];
+ if (c == '\n' && print_escape_newlines)
+ {
+ PRINTCHAR ('\\');
+ PRINTCHAR ('n');
+ }
+ else if (c == '\f' && print_escape_newlines)
+ {
+ PRINTCHAR ('\\');
+ PRINTCHAR ('f');
+ }
+ else
+ {
+ if (c == '\"' || c == '\\')
+ PRINTCHAR ('\\');
+ PRINTCHAR (c);
+ }
+ }
+ PRINTCHAR ('\"');
+
+ UNGCPRO;
+ }
else if (SUBRP (obj))
{
strout ("#<subr ", -1, printcharfun);
PRINTCHAR ('#');
size &= PSEUDOVECTOR_SIZE_MASK;
}
+ if (CHAR_TABLE_P (obj))
+ {
+ /* We print a char-table as if it were a vector,
+ lumping the parent and default slots in with the
+ character slots. But we add #^ as a prefix. */
+ PRINTCHAR ('#');
+ PRINTCHAR ('^');
+ size &= PSEUDOVECTOR_SIZE_MASK;
+ }
if (size & PSEUDOVECTOR_FLAG)
goto badtype;
{
register int i;
register Lisp_Object tem;
+
+ /* Don't print more elements than the specified maximum. */
+ if (INTEGERP (Vprint_length)
+ && XINT (Vprint_length) < size)
+ size = XINT (Vprint_length);
+
for (i = 0; i < size; i++)
{
if (i) PRINTCHAR (' ');
#ifndef standalone
case Lisp_Misc:
- switch (XMISC (obj)->type)
+ switch (XMISCTYPE (obj))
{
case Lisp_Misc_Marker:
strout ("#<marker ", -1, printcharfun);
PRINTCHAR ('>');
break;
- case Lisp_Misc_Display_Objfwd:
- strout (buf, "#<display_objfwd to ", -1, printcharfun);
- if (!current_perdisplay)
- strout ("no-current-perdisplay");
- else
- print (*(Lisp_Object *)((char *) current_perdisplay
- + XDISPLAY_OBJFWD (obj)->offset),
- printcharfun, escapeflag);
+ case Lisp_Misc_Kboard_Objfwd:
+ strout (buf, "#<kboard_objfwd to ", -1, printcharfun);
+ print (*(Lisp_Object *)((char *) current_kboard
+ + XKBOARD_OBJFWD (obj)->offset),
+ printcharfun, escapeflag);
PRINTCHAR ('>');
break;
Probably should just abort () */
strout ("#<EMACS BUG: INVALID DATATYPE ", -1, printcharfun);
if (MISCP (obj))
- sprintf (buf, "(MISC 0x%04x)", (int) XMISC (obj)->type);
+ sprintf (buf, "(MISC 0x%04x)", (int) XMISCTYPE (obj));
else if (VECTORLIKEP (obj))
sprintf (buf, "(PVEC 0x%08x)", (int) XVECTOR (obj)->size);
else
This may be any function of one argument.\n\
It may also be a buffer (output is inserted before point)\n\
or a marker (output is inserted and the marker is advanced)\n\
-or the symbol t (output appears in the minibuffer line).");
+or the symbol t (output appears in the echo area).");
Vstandard_output = Qt;
Qstandard_output = intern ("standard-output");
staticpro (&Qstandard_output);
defsubr (&Sprin1);
defsubr (&Sprin1_to_string);
+ defsubr (&Serror_message_string);
defsubr (&Sprinc);
defsubr (&Sprint);
defsubr (&Sterpri);
HCoop / bpt / emacs.git / blobdiff