xemacs-beta: src/print.c comparison

comparison src/print.c @ 245:51092a27c943 r20-5b21

Import from CVS: tag r20-5b21

author	cvs
date	Mon, 13 Aug 2007 10:17:54 +0200
parents	52952cbfc5b5
children	677f6a0ee643

comparison

equal deleted inserted replaced

-:78d4f1140794
+:51092a27c943
 /* Nonzero means print newlines in strings as \n.  */
 int print_escape_newlines;
 int print_readably;
-int print_gensym;
+/* Non-nil means print #: before uninterned symbols.
+Neither t nor nil means so that and don't clear Vprint_gensym_alist
+on entry to and exit from print functions.  */
+Lisp_Object Vprint_gensym;
+Lisp_Object Vprint_gensym_alist;
 Lisp_Object Qprint_escape_newlines;
 Lisp_Object Qprint_readably;
 Lisp_Object Qdisplay_error;
 == Sexternal_debugging_output))
 {
 stdio_stream = stderr;
 }
 #endif
+if (!CONSP (Vprint_gensym))
+Vprint_gensym_alist = Qnil;
 return make_print_output_stream (stdio_stream, printcharfun);
 }
 static void
 print_finish (Lisp_Object stream)
 {
 /* Emacs won't print whilst GCing, but an external debugger might */
 if (gc_in_progress)
 return;
+if (!CONSP (Vprint_gensym))
+Vprint_gensym_alist = Qnil;
 Lstream_delete (XLSTREAM (stream));
 }
 #if 1 /* Prefer space over "speed" */
 	if (max && i > max)
 	  {
 	    write_c_string ("...", printcharfun);
 	    break;
 	  }
-	print_internal (Fcar (obj), printcharfun,
+	print_internal (XCAR (obj), printcharfun,
 			escapeflag);
-	obj = Fcdr (obj);
+	obj = XCDR (obj);
 }
 }
 if (!NILP (obj) && !CONSP (obj))
 {
 write_c_string (" . ", printcharfun);
 }
 void
 print_string (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 {
-Bytecount size = XSTRING_LENGTH (obj);
+struct Lisp_String *s = XSTRING (obj);
+/* We distinguish between Bytecounts and Charcounts, to make
+Vprint_string_length work correctly under Mule.  */
+Charcount size = string_char_length (s);
+Charcount max = size;
+Bytecount bcmax = string_length (s);
 struct gcpro gcpro1, gcpro2;
-int max = size;
 GCPRO2 (obj, printcharfun);
 if (INTP (Vprint_string_length) &&
 XINT (Vprint_string_length) < max)
-max = XINT (Vprint_string_length);
+{
+max = XINT (Vprint_string_length);
+bcmax = charcount_to_bytecount (string_data (s), max);
+}
 if (max < 0)
-max = 0;
+{
+max = 0;
-/* !!#### This handles MAX incorrectly for Mule. */
+bcmax = 0;
+}
 if (!escapeflag)
 {
-/* This deals with GC-relocation */
+/* This deals with GC-relocation and Mule. */
-output_string (printcharfun, 0, obj, 0, max);
+output_string (printcharfun, 0, obj, 0, bcmax);
 if (max < size)
 	write_c_string (" ...", printcharfun);
 }
 else
 {
-Bytecount i;
+Bytecount i, last = 0;
-struct Lisp_String *s = XSTRING (obj);
-Bytecount last = 0;
 write_char_internal ("\"", printcharfun);
-for (i = 0; i < max; i++)
+for (i = 0; i < bcmax; i++)
 	{
 	  Bufbyte ch = string_byte (s, i);
 	  if (ch == '\"' || ch == '\\'
 	      || (ch == '\n' && print_escape_newlines))
 	    {
 				       printcharfun);
 		}
 	      last = i + 1;
 	    }
 	}
-if (max > last)
+if (bcmax > last)
 	{
 	  output_string (printcharfun, 0, obj, last,
-			 max - last);
+			 bcmax - last);
 	}
 if (max < size)
 	write_c_string (" ...", printcharfun);
 write_char_internal ("\"", printcharfun);
 }
 output_string (printcharfun, 0, nameobj, 0, size);
 return;
 }
 GCPRO2 (obj, printcharfun);
-if (print_gensym)
+/* If we print an uninterned symbol as part of a complex object and
-{
+the flag print-gensym is non-nil, prefix it with #n= to read the
-Lisp_Object tem = oblookup (Vobarray, string_data (name), size);
+object back with the #n# reader syntax later if needed.  */
-if (!EQ (tem, obj))
+if (!NILP (Vprint_gensym) && NILP (XSYMBOL (obj)->obarray))
-	/* (read) would return a new symbol with the same name.
+{
-	   This isn't quite correct, because that symbol might not
+if (print_depth > 1)
-	   really be uninterned (it might be interned in some other
+	{
-	   obarray) but there's no way to win in that case without
+	  Lisp_Object tem = Fassq (obj, Vprint_gensym_alist);
-	   implementing a real package system.
+	  if (CONSP (tem))
-	   */
+	    {
-	write_c_string ("#:", printcharfun);
+	      write_char_internal ("#", printcharfun);
+	      print_internal (XCDR (tem), printcharfun, escapeflag);
+	      write_char_internal ("#", printcharfun);
+	      return;
+	    }
+	  else
+	    {
+	      if (CONSP (Vprint_gensym_alist))
+		XSETINT (tem, XINT (XCDR (XCAR (Vprint_gensym_alist))) + 1);
+	      else
+		XSETINT (tem, 1);
+	      Vprint_gensym_alist = Fcons (Fcons (obj, tem), Vprint_gensym_alist);
+	      write_char_internal ("#", printcharfun);
+	      print_internal (tem, printcharfun, escapeflag);
+	      write_char_internal ("=", printcharfun);
+	    }
+	}
+write_c_string ("#:", printcharfun);
 }
 /* Does it look like an integer or a float? */
 {
 Bufbyte *data = string_data (name);
 lists of the form (quote object) will be written as the equivalent 'object.
 Do not SET this variable; bind it instead.
 */ );
 print_readably = 0;
-DEFVAR_BOOL ("print-gensym", &print_gensym /*
+/* #### I think this should default to t.  But we'd better wait
+until we see that it works out.  */
+DEFVAR_LISP ("print-gensym", &Vprint_gensym /*
 If non-nil, then uninterned symbols will be printed specially.
 Uninterned symbols are those which are not present in `obarray', that is,
 those which were made with `make-symbol' or by calling `intern' with a
 second argument.
-When print-gensym is true, such symbols will be preceded by "#:", which
+When print-gensym is true, such symbols will be preceded by "#:",
-causes the reader to create a new symbol instead of interning and returning
+which causes the reader to create a new symbol instead of interning
-an existing one.  Beware: the #: syntax creates a new symbol each time it is
+and returning an existing one.  Beware: the #: syntax creates a new
-seen, so if you print an object which contains two pointers to the same
+symbol each time it is seen, so if you print an object which contains
-uninterned symbol, `read' will not duplicate that structure.
+two pointers to the same uninterned symbol, `read' will not duplicate
+that structure.
-Also, since XEmacs has no real notion of packages, there is no way for the
-printer to distinguish between symbols interned in no obarray, and symbols
+If the value of `print-gensym' is a cons cell, then in addition
-interned in an alternate obarray.
+refrain from clearing `print-gensym-alist' on entry to and exit from
+printing functions, so that the use of #...# and #...= can carry over
+for several separately printed objects.
 */ );
-print_gensym = 0;
+Vprint_gensym = Qnil;
+DEFVAR_LISP ("print-gensym-alist", &Vprint_gensym_alist /*
+Association list of elements (GENSYM . N) to guide use of #N# and #N=.
+In each element, GENSYM is an uninterned symbol that has been associated
+with #N= for the specified value of N.
+*/ );
+Vprint_gensym_alist = Qnil;
 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'.)
 */ );

Mercurial > hg > xemacs-beta

comparison src/print.c @ 245:51092a27c943 r20-5b21