Mercurial > hg > xemacs-beta
diff 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 |
line wrap: on
line diff
--- a/src/print.c Mon Aug 13 10:17:09 2007 +0200 +++ b/src/print.c Mon Aug 13 10:17:54 2007 +0200 @@ -83,7 +83,12 @@ 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; @@ -338,6 +343,8 @@ stdio_stream = stderr; } #endif + if (!CONSP (Vprint_gensym)) + Vprint_gensym_alist = Qnil; return make_print_output_stream (stdio_stream, printcharfun); } @@ -349,6 +356,9 @@ if (gc_in_progress) return; + if (!CONSP (Vprint_gensym)) + Vprint_gensym_alist = Qnil; + Lstream_delete (XLSTREAM (stream)); } @@ -893,9 +903,9 @@ 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)) @@ -917,33 +927,40 @@ 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; + bcmax = 0; + } - /* !!#### This handles MAX incorrectly for Mule. */ if (!escapeflag) { - /* This deals with GC-relocation */ - output_string (printcharfun, 0, obj, 0, max); + /* This deals with GC-relocation and Mule. */ + output_string (printcharfun, 0, obj, 0, bcmax); if (max < size) write_c_string (" ...", printcharfun); } else { - Bytecount i; - struct Lisp_String *s = XSTRING (obj); - Bytecount last = 0; + Bytecount i, 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 == '\\' @@ -969,10 +986,10 @@ 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); @@ -1326,17 +1343,35 @@ } 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 + object back with the #n# reader syntax later if needed. */ + if (!NILP (Vprint_gensym) && NILP (XSYMBOL (obj)->obarray)) { - Lisp_Object tem = oblookup (Vobarray, string_data (name), size); - if (!EQ (tem, obj)) - /* (read) would return a new symbol with the same name. - This isn't quite correct, because that symbol might not - really be uninterned (it might be interned in some other - obarray) but there's no way to win in that case without - implementing a real package system. - */ - write_c_string ("#:", printcharfun); + if (print_depth > 1) + { + Lisp_Object tem = Fassq (obj, Vprint_gensym_alist); + if (CONSP (tem)) + { + 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? */ @@ -1751,23 +1786,34 @@ */ ); 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 -causes the reader to create a new symbol instead of interning and returning -an existing one. Beware: the #: syntax creates a new symbol each time it is -seen, so if you print an object which contains two pointers to the same -uninterned symbol, `read' will not duplicate that structure. +When print-gensym is true, such symbols will be preceded by "#:", +which causes the reader to create a new symbol instead of interning +and returning an existing one. Beware: the #: syntax creates a new +symbol each time it is seen, so if you print an object which contains +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 -interned in an alternate obarray. +If the value of `print-gensym' is a cons cell, then in addition +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