xemacs-beta: src/print.c comparison

comparison src/print.c @ 278:90d73dddcdc4 r21-0b37

Import from CVS: tag r21-0b37

author	cvs
date	Mon, 13 Aug 2007 10:31:29 +0200
parents	6330739388db
children	7df0dd720c89

comparison

equal deleted inserted replaced

-:cfdf3ff11843
+:90d73dddcdc4
 /* Seriously hacked on by Ben Wing for Mule. */
 #include <config.h>
 #include "lisp.h"
-#ifndef standalone
 #include "backtrace.h"
 #include "buffer.h"
 #include "bytecode.h"
 #include "console-tty.h"
 #include "console-stream.h"
 #include "frame.h"
 #include "insdel.h"
 #include "lstream.h"
 #include "sysfile.h"
-#endif /* not standalone */
 #include <float.h>
 /* Define if not in float.h */
 #ifndef DBL_DIG
 #define DBL_DIG 16
 #endif
 static void
 output_string (Lisp_Object function, CONST Bufbyte *nonreloc,
 	       Lisp_Object reloc, Bytecount offset, Bytecount len)
 {
 /* This function can GC */
-Charcount ccoff, cclen;
+Charcount cclen;
 /* We change the value of nonreloc (fetching it from reloc as
 necessary), but we don't want to pass this changed value on to
 other functions that take both a nonreloc and a reloc, or things
 may get confused and an assertion failure in
 fixup_internal_substring() may get triggered. */
 fixup_internal_substring (newnonreloc, reloc, offset, &len);
 if (STRINGP (reloc))
 newnonreloc = XSTRING_DATA (reloc);
-ccoff = bytecount_to_charcount (newnonreloc, offset);
 cclen = bytecount_to_charcount (newnonreloc + offset, len);
 if (LSTREAMP (function))
 {
 if (STRINGP (reloc))
 	{
 	  /* Protect against Lstream_write() causing a GC and
 	     relocating the string.  For small strings, we do it by
 	     alloc'ing the string and using a copy; for large strings,
-	     we inhibit GC.  Now that print_streams are dead, this
+	     we inhibit GC.  */
-	     case should happen very rarely anyway.  */
 	  if (len < 65536)
 	    {
 	      Bufbyte *copied = alloca_array (Bufbyte, len);
 	      memcpy (copied, newnonreloc + offset, len);
 	      Lstream_write (XLSTREAM (function), copied, len);
 	Lstream_write (XLSTREAM (function), newnonreloc + offset, len);
 if (print_unbuffered)
 	Lstream_flush (XLSTREAM (function));
 }
-#ifndef standalone
 else if (BUFFERP (function))
 {
 CHECK_LIVE_BUFFER (function);
 buffer_insert_string (XBUFFER (function), nonreloc, reloc, offset, len);
 }
 else if (MARKERP (function))
 {
-/* marker_position will err if marker doesn't point anywhere */
+/* marker_position() will err if marker doesn't point anywhere.  */
 Bufpos spoint = marker_position (function);
-buffer_insert_string_1 (XBUFFER (Fmarker_buffer (function)),
+buffer_insert_string_1 (XMARKER (function)->buffer,
 			      spoint, nonreloc, reloc, offset, len,
 			      0);
 Fset_marker (function, make_int (spoint + cclen),
 		   Fmarker_buffer (function));
 }
 else if (FRAMEP (function))
 {
+/* This gets used by functions not invoking print_prepare(),
+such as Fwrite_char.  */
 struct frame *f = XFRAME (function);
+CHECK_LIVE_FRAME (function);
 if (!EQ (Vprint_message_label, echo_area_status (f)))
 	clear_echo_area_from_print (f, Qnil, 1);
 echo_area_append (f, nonreloc, reloc, offset, len, Vprint_message_label);
 }
-#endif /* not standalone */
 else if (EQ (function, Qt) || EQ (function, Qnil))
 {
 write_string_to_stdio_stream (stdout, 0, newnonreloc, offset, len,
 				    FORMAT_TERMINAL);
 }
 else
 {
+Charcount ccoff = bytecount_to_charcount (newnonreloc, offset);
 Charcount iii;
 for (iii = ccoff; iii < cclen + ccoff; iii++)
 	{
 	  call1 (function,
 	}
 }
 UNGCPRO;
 }
+#define RESET_PRINT_GENSYM do {			\
+if (!CONSP (Vprint_gensym))			\
+Vprint_gensym_alist = Qnil;			\
+} while (0)
 static Lisp_Object
 canonicalize_printcharfun (Lisp_Object printcharfun)
 {
 if (NILP (printcharfun))
 printcharfun = Vstandard_output;
 if (EQ (printcharfun, Qt) || NILP (printcharfun))
-{
+printcharfun = Fselected_frame (Qnil); /* print to minibuffer */
-#ifndef standalone
-printcharfun = Fselected_frame (Qnil); /* print to minibuffer */
-#endif
-}
 return printcharfun;
 }
-/* Now that print_streams are dead, I wonder if the following two
-functions are needed as separate entities.  */
 static Lisp_Object
-print_prepare (Lisp_Object printcharfun)
+print_prepare (Lisp_Object printcharfun, Lisp_Object *frame_kludge)
 {
 /* Emacs won't print whilst GCing, but an external debugger might */
 if (gc_in_progress)
 return Qnil;
+RESET_PRINT_GENSYM;
 printcharfun = canonicalize_printcharfun (printcharfun);
-if (!CONSP (Vprint_gensym))
-Vprint_gensym_alist = Qnil;
+/* Here we could safely return the canonicalized PRINTCHARFUN.
+However, if PRINTCHARFUN is a frame, printing of complex
+structures becomes very expensive, because `append-message'
+(called by echo_area_append) gets called as many times as
+output_string() is called (and that's a *lot*).  append-message
+tries to keep top of the message-stack in sync with the contents
+of " *Echo Area" buffer, consing a new string for each component
+of the printed structure.  For instance, if you print (a a),
+append-message will cons up the following strings:
+"("
+	 "(a"
+	 "(a "
+	 "(a a"
+	 "(a a)"
+and will use only the last one.  With larger objects, this turns
+into an O(n^2) consing frenzy that locks up XEmacs in incessant
+garbage collection.
+We prevent this by creating a resizing_buffer stream and letting
+the printer write into it.  print_finish() will notice this
+stream, and invoke echo_area_append() with the stream's buffer,
+only once.  */
+if (FRAMEP (printcharfun))
+{
+CHECK_LIVE_FRAME (printcharfun);
+*frame_kludge = printcharfun;
+printcharfun = make_resizing_buffer_output_stream ();
+}
 return printcharfun;
 }
 static void
-print_finish (Lisp_Object stream)
+print_finish (Lisp_Object stream, Lisp_Object frame_kludge)
 {
 /* Emacs won't print whilst GCing, but an external debugger might */
 if (gc_in_progress)
 return;
-if (!CONSP (Vprint_gensym))
+RESET_PRINT_GENSYM;
-Vprint_gensym_alist = Qnil;
-}
+/* See the comment in print_prepare().  */
+if (FRAMEP (frame_kludge))
-#if 1 /* Prefer space over "speed" */
+{
-#define write_char_internal(string_of_length_1, stream) \
+struct frame *f = XFRAME (frame_kludge);
-write_string_1 ((CONST Bufbyte *) (string_of_length_1), 1, (stream))
+Lstream *str = XLSTREAM (stream);
-#else
+CHECK_LIVE_FRAME (frame_kludge);
-#define write_char_internal(string_of_length_1, stream) \
-output_string ((stream), (CONST Bufbyte *) (string_of_length_1), Qnil, 0, 1)
+Lstream_flush (str);
-#endif
+if (!EQ (Vprint_message_label, echo_area_status (f)))
+	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);
+Lstream_delete (str);
+}
+}
+/* Used for printing a character.  STRING_OF_LENGTH_1 must contain a
+single-byte character, not just any emchar.  */
+#define write_char_internal(string_of_length_1, stream)			\
+output_string ((stream), (CONST Bufbyte *) (string_of_length_1),	\
+		 Qnil, 0, 1)
 /* NOTE:  Do not call this with the data of a Lisp_String,
 *  as printcharfun might cause a GC, which might cause
 *  the string's data to be relocated.
-*  Use print_object_internal (string, printcharfun, 0)
+*  Use print_internal (string, printcharfun, 0)
 *  to princ a Lisp_String
 * Note: "stream" should be the result of "canonicalize_printcharfun"
 *  (ie Qnil means stdout, not Vstandard_output, etc)
 */
 void
 write_string_1 (CONST Bufbyte *str, Bytecount size, Lisp_Object stream)
 {
 /* This function can GC */
+#ifdef ERROR_CHECK_BUFPOS
 assert (size >= 0);
+#endif
 output_string (stream, str, Qnil, 0, size);
 }
 void
 write_c_string (CONST char *str, Lisp_Object stream)
 /* This function can GC */
 Bufbyte str[MAX_EMCHAR_LEN];
 Bytecount len;
 CHECK_CHAR_COERCE_INT (ch);
+RESET_PRINT_GENSYM;
 len = set_charptr_emchar (str, XCHAR (ch));
 output_string (canonicalize_printcharfun (stream), str, Qnil, 0, len);
+RESET_PRINT_GENSYM;
 return ch;
 }
-#ifndef standalone
 void
 temp_output_buffer_setup (CONST char *bufname)
 {
 /* This function can GC */
 temp_output_buffer_show (Vstandard_output, Qnil);
 return unbind_to (speccount, val);
 }
-#endif /* not standalone */
 DEFUN ("terpri", Fterpri, 0, 1, 0, /*
 Output a newline to STREAM.
 If STREAM is omitted or nil, the value of `standard-output' is used.
 */
 Output stream is STREAM, or value of `standard-output' (which see).
 */
 (object, stream))
 {
 /* This function can GC */
-Lisp_Object the_stream = Qnil;
+Lisp_Object the_stream = Qnil, frame = Qnil;
 struct gcpro gcpro1, gcpro2, gcpro3;
 GCPRO3 (object, stream, the_stream);
 print_depth = 0;
-the_stream = print_prepare (stream);
+the_stream = print_prepare (stream, &frame);
 print_internal (object, the_stream, 1);
-print_finish (the_stream);
+print_finish (the_stream, frame);
 UNGCPRO;
 return object;
 }
-/* Stream to which prin1-to-string prints. */
-static Lisp_Object Vprin1_to_string_stream;
 DEFUN ("prin1-to-string", Fprin1_to_string, 1, 2, 0, /*
 Return a string containing the printed representation of OBJECT,
 any Lisp object.  Quoting characters are used when needed to make output
 that `read' can handle, whenever this is possible, unless the optional
 second argument NOESCAPE is non-nil.
 */
 (object, noescape))
 {
 /* This function can GC */
-Lstream *stream;
+Lisp_Object stream;
-struct gcpro gcpro1;
+Lstream *str;
+struct gcpro gcpro1, gcpro2;
-/* We avoid creating a new stream for every invocation of
-prin1_to_string, for better memory usage.  #### Is it necessary?  */
+stream = make_resizing_buffer_output_stream ();
+str = XLSTREAM (stream);
-if (NILP (Vprin1_to_string_stream))
-Vprin1_to_string_stream = make_resizing_buffer_output_stream ();
+/* Protect OBJECT, in case a caller forgot to protect. */
-stream = XLSTREAM (Vprin1_to_string_stream);
+GCPRO2 (object, stream);
-Lstream_rewind (stream);
-/* In case a caller forgot to protect. */
-GCPRO1 (object);
 print_depth = 0;
-if (!CONSP (Vprint_gensym))
+RESET_PRINT_GENSYM;
-Vprint_gensym_alist = Qnil;
+print_internal (object, stream, NILP (noescape));
-print_internal (object, Vprin1_to_string_stream, NILP (noescape));
+RESET_PRINT_GENSYM;
-if (!CONSP (Vprint_gensym))
+Lstream_flush (str);
-Vprint_gensym_alist = Qnil;
-Lstream_flush (stream);
 UNGCPRO;
-return make_string (resizing_buffer_stream_ptr (stream),
+return make_string (resizing_buffer_stream_ptr (str),
-		      Lstream_byte_count (stream));
+		      Lstream_byte_count (str));
 }
 DEFUN ("princ", Fprinc, 1, 2, 0, /*
 Output the printed representation of OBJECT, any Lisp object.
 No quoting characters are used; no delimiters are printed around
 Output stream is STREAM, or value of standard-output (which see).
 */
 (obj, stream))
 {
 /* This function can GC */
-Lisp_Object the_stream = Qnil;
+Lisp_Object the_stream = Qnil, frame = Qnil;
 struct gcpro gcpro1, gcpro2, gcpro3;
 GCPRO3 (obj, stream, the_stream);
-the_stream = print_prepare (stream);
+the_stream = print_prepare (stream, &frame);
 print_depth = 0;
 print_internal (obj, the_stream, 0);
-print_finish (the_stream);
+print_finish (the_stream, frame);
 UNGCPRO;
 return obj;
 }
 DEFUN ("print", Fprint, 1, 2, 0, /*
 Output stream is STREAM, or value of `standard-output' (which see).
 */
 (obj, stream))
 {
 /* This function can GC */
-Lisp_Object the_stream = Qnil;
+Lisp_Object the_stream = Qnil, frame = Qnil;
 struct gcpro gcpro1, gcpro2, gcpro3;
 GCPRO3 (obj, stream, the_stream);
-the_stream = print_prepare (stream);
+the_stream = print_prepare (stream, &frame);
 print_depth = 0;
 write_char_internal ("\n", the_stream);
 print_internal (obj, the_stream, 1);
 write_char_internal ("\n", the_stream);
-print_finish (the_stream);
+print_finish (the_stream, frame);
 UNGCPRO;
 return obj;
 }
 	buf [i+1] = buf [i];
 buf [(buf [0] == '-' ? 1 : 0)] = '0';
 }
 }
 #endif /* LISP_FLOAT_TYPE */
+/* Print NUMBER to BUFFER.  The digits are first written in reverse
+order (the least significant digit first), and are then reversed.
+This is equivalent to sprintf(buffer, "%ld", number), only much
+faster.  */
+void
+long_to_string (char *buffer, long number)
+{
+char *p;
+int i, l;
+if (number < 0)
+{
+*buffer++ = '-';
+number = -number;
+}
+p = buffer;
+/* Print the digits to the string.  */
+do
+{
+*p++ = number % 10 + '0';
+number /= 10;
+}
+while (number);
+/* And reverse them.  */
+l = p - buffer - 1;
+for (i = l/2; i >= 0; i--)
+{
+char c = buffer[i];
+buffer[i] = buffer[l - i];
+buffer[l - i] = c;
+}
+buffer[l + 1] = '\0';
+}
 static void
 print_vector_internal (CONST char *start, CONST char *end,
 Lisp_Object obj,
 Lisp_Object printcharfun, int escapeflag)
 	      else
 		{
 		  write_char_internal ("\\", printcharfun);
 		  /* This is correct for Mule because the
 		     character is either \ or " */
-		  write_char_internal ((char *) (string_data (s) + i),
+		  write_char_internal (string_data (s) + i, printcharfun);
-				       printcharfun);
 		}
 	      last = i + 1;
 	    }
 	}
 if (bcmax > last)
 if (max < size)
 	write_c_string (" ...", printcharfun);
 write_char_internal ("\"", printcharfun);
 }
 UNGCPRO;
-return;
-}
-/* Print NUMBER to BUFFER.  The digits are first written in reverse
-order (the least significant digit first), and are then reversed.
-This is equivalent to sprintf(buffer, "%ld", number), only much
-faster.  */
-void
-long_to_string (char *buffer, long number)
-{
-char *p;
-int i, l;
-if (number < 0)
-{
-*buffer++ = '-';
-number = -number;
-}
-p = buffer;
-/* Print the digits to the string.  */
-do
-{
-*p++ = number % 10 + '0';
-number /= 10;
-}
-while (number);
-/* And reverse them.  */
-l = p - buffer - 1;
-for (i = l/2; i >= 0; i--)
-{
-char c = buffer[i];
-buffer[i] = buffer[l - i];
-buffer[l - i] = c;
-}
-buffer[l + 1] = '\0';
 }
 static void
 default_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
 			int escapeflag)
 void
 internal_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
 			 int escapeflag)
 {
 char buf[200];
-sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%p>",
+sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>",
 	   XRECORD_LHEADER_IMPLEMENTATION (obj)->name,
-	   (void *) XPNTR (obj));
+	   (unsigned long) XPNTR (obj));
 write_c_string (buf, printcharfun);
 }
 void
 print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 case Lisp_Type_Char:
 {
 	/* God intended that this be #\..., you know. */
 	Emchar ch = XCHAR (obj);
-	write_c_string ("?", printcharfun);
+	char *p = buf;
+	*p++ = '?';
 	if (ch == '\n')
-	  strcpy (buf, "\\n");
+	  *p++ = '\\', *p++ = 'n';
 	else if (ch == '\r')
-	  strcpy (buf, "\\r");
+	  *p++ = '\\', *p++ = 'r';
 	else if (ch == '\t')
-	  strcpy (buf, "\\t");
+	  *p++ = '\\', *p++ = 't';
-	else if (ch < 32) {
+	else if (ch < 32)
-	  sprintf (buf, "\\^%c", ch + 64);
+	  {
-	  if ((ch + 64) == '\\') {
+	    *p++ = '\\', *p++ = '^';
-	    strcat(buf, "\\");
+	    *p++ = ch + 64;
+	    if ((ch + 64) == '\\')
+	      *p++ = '\\';
 	  }
-	} else if (ch == 127)
+	else if (ch == 127)
-	  strcpy (buf, "\\^?");
+	  *p++ = '\\', *p++ = '^', *p++ = '?';
 	else if (ch >= 128 && ch < 160)
 	  {
-	    Bytecount i;
+	    *p++ = '\\', *p++ = '^';
-	    strcpy (buf, "\\^");
+	    p += set_charptr_emchar ((Bufbyte *)p, ch + 64);
-	    i = set_charptr_emchar ((unsigned char *) (buf + 2), ch + 64);
-	    buf[2+i] = '\0';
 	  }
 	else if (ch < 127
 		 && !isdigit (ch)
 		 && !isalpha (ch)
 		 && ch != '^') /* must not backslash this or it will
 				  be interpreted as the start of a
 				  control char */
-	  sprintf (buf, "\\%c", ch);
+	  *p++ = '\\', *p++ = ch;
 	else
-	  {
+	  p += set_charptr_emchar ((Bufbyte *)p, ch);
-	    Bytecount i;
+	output_string (printcharfun, (Bufbyte *)buf, Qnil, 0, p - buf);
-	    i = set_charptr_emchar ((unsigned char *) buf, ch);
-	    buf[i] = '\0';
-	  }
-	write_c_string (buf, printcharfun);
 	break;
 }
 #ifndef LRECORD_STRING
 case Lisp_Type_String:
 {
-	print_string(obj, printcharfun, escapeflag);
+	print_string (obj, printcharfun, escapeflag);
 	break;
 }
 #endif /* ! LRECORD_STRING */
 #ifndef LRECORD_CONS
 #endif /* ! LRECORD_CONS */
 #ifndef LRECORD_VECTOR
 case Lisp_Type_Vector:
 {
-	struct gcpro gcpro1, gcpro2;
 	/* If deeper than spec'd depth, print placeholder.  */
 	if (INTP (Vprint_level)
 	    && print_depth > XINT (Vprint_level))
 	  {
+	    struct gcpro gcpro1, gcpro2;
 	    GCPRO2 (obj, printcharfun);
 	    write_c_string ("...", printcharfun);
 	    UNGCPRO;
 	    break;
 	  }
 print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 {
 /* This function can GC */
 /* #### Bug!! (intern "") isn't printed in some distinguished way */
 /* ####  (the reader also loses on it) */
-struct Lisp_String *name = XSYMBOL (obj)->name;
+struct Lisp_String *name = symbol_name (XSYMBOL (obj));
 Bytecount size = string_length (name);
 struct gcpro gcpro1, gcpro2;
 if (!escapeflag)
 {
 }
 not_yet_confused:
 #ifdef LISP_FLOAT_TYPE
 if (!confusing)
+/* #### Ugh, this is needlessly complex and slow for what we
+need here.  It might be a good idea to copy equivalent code
+from FSF.  --hniksic */
 confusing = isfloat_string ((char *) data);
 #endif
 if (confusing)
 write_char_internal ("\\", printcharfun);
 }
 output_string (printcharfun, 0, nameobj, last, size - last);
 }
 UNGCPRO;
 }
+/* #ifdef DEBUG_XEMACS */
+/* I don't like seeing `Note: Strange doc (not fboundp) for function */
+/* alternate-debugging-output @ 429542' -slb */
 int alternate_do_pointer;
 char alternate_do_string[5000];
 DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /*
 Append CHARACTER to the array `alternate_do_string'.
 This can be used in place of `external-debugging-output' as a function
 to be passed to `print'.  Before calling `print', set `alternate_do_pointer'
 to 0.
 */
 (character))
 {
 Bufbyte str[MAX_EMCHAR_LEN];
 Bytecount len;
 memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen);
 alternate_do_pointer += extlen;
 alternate_do_string[alternate_do_pointer] = 0;
 return character;
 }
+/* #endif /* DEBUG_XEMACS */
 DEFUN ("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /*
 Write CHAR-OR-STRING to stderr or stdout.
 If optional arg STDOUT-P is non-nil, write to stdout; otherwise, write
 to stderr.  You can use this function to write directly to the terminal.
 if (! NILP (file))
 {
 file = Fexpand_file_name (file, Qnil);
 termscript = fopen ((char *) XSTRING_DATA (file), "w");
 if (termscript == NULL)
-	report_file_error ("Opening termscript", Fcons (file, Qnil));
+	report_file_error ("Opening termscript", list1 (file));
 }
 return Qnil;
 }
 #if 1
 DEFSUBR (Falternate_debugging_output);
 defsymbol (&Qalternate_debugging_output, "alternate-debugging-output");
 DEFSUBR (Fexternal_debugging_output);
 DEFSUBR (Fopen_termscript);
 defsymbol (&Qexternal_debugging_output, "external-debugging-output");
-#ifndef standalone
 DEFSUBR (Fwith_output_to_temp_buffer);
-#endif /* not standalone */
 }
 void
 vars_of_print (void)
 {
 DEFVAR_LISP ("print-message-label", &Vprint_message_label /*
 Label for minibuffer messages created with `print'.  This should
 generally be bound with `let' rather than set.  (See `display-message'.)
 */ );
 Vprint_message_label = Qprint;
+}
-Vprin1_to_string_stream = Qnil;
-staticpro (&Vprin1_to_string_stream);
-}

Mercurial > hg > xemacs-beta

comparison src/print.c @ 278:90d73dddcdc4 r21-0b37