Mercurial > hg > xemacs-beta

comparison src/print.c @ 428:3ecd8885ac67 r21-2-22

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-22
author cvs
date Mon, 13 Aug 2007 11:28:15 +0200
parents
children 9d177e8d4150
comparison
equal deleted inserted replaced
427:0a0253eac470 428:3ecd8885ac67
1 /* Lisp object printing and output streams.
2 Copyright (C) 1985, 1986, 1988, 1992-1995 Free Software Foundation, Inc.
3 Copyright (C) 1995, 1996 Ben Wing.
4
5 This file is part of XEmacs.
6
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
10 later version.
11
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
21
22 /* Synched up with: Not synched with FSF. */
23
24 /* This file has been Mule-ized. */
25
26 /* Seriously hacked on by Ben Wing for Mule. */
27
28 #include <config.h>
29 #include "lisp.h"
30
31 #include "backtrace.h"
32 #include "buffer.h"
33 #include "bytecode.h"
34 #include "console-tty.h"
35 #include "console-stream.h"
36 #include "extents.h"
37 #include "frame.h"
38 #include "insdel.h"
39 #include "lstream.h"
40 #include "sysfile.h"
41
42 #include <limits.h>
43 #include <float.h>
44 /* Define if not in float.h */
45 #ifndef DBL_DIG
46 #define DBL_DIG 16
47 #endif
48
49 Lisp_Object Vstandard_output, Qstandard_output;
50
51 /* The subroutine object for external-debugging-output is kept here
52 for the convenience of the debugger. */
53 Lisp_Object Qexternal_debugging_output;
54
55 /* Avoid actual stack overflow in print. */
56 static int print_depth;
57
58 /* Detect most circularities to print finite output. */
59 #define PRINT_CIRCLE 200
60 static Lisp_Object being_printed[PRINT_CIRCLE];
61
62 /* Maximum length of list or vector to print in full; noninteger means
63 effectively infinity */
64
65 Lisp_Object Vprint_length;
66 Lisp_Object Qprint_length;
67
68 /* Maximum length of string to print in full; noninteger means
69 effectively infinity */
70
71 Lisp_Object Vprint_string_length;
72 Lisp_Object Qprint_string_length;
73
74 /* Maximum depth of list to print in full; noninteger means
75 effectively infinity. */
76
77 Lisp_Object Vprint_level;
78
79 /* Label to use when making echo-area messages. */
80
81 Lisp_Object Vprint_message_label;
82
83 /* Nonzero means print newlines in strings as \n. */
84
85 int print_escape_newlines;
86 int print_readably;
87
88 /* Non-nil means print #: before uninterned symbols.
89 Neither t nor nil means so that and don't clear Vprint_gensym_alist
90 on entry to and exit from print functions. */
91 Lisp_Object Vprint_gensym;
92 Lisp_Object Vprint_gensym_alist;
93
94 Lisp_Object Qdisplay_error;
95 Lisp_Object Qprint_message_label;
96
97 /* Force immediate output of all printed data. Used for debugging. */
98 int print_unbuffered;
99
100 FILE *termscript; /* Stdio stream being used for copy of all output. */
101
102
103
104 int stdout_needs_newline;
105
106 /* Write a string (in internal format) to stdio stream STREAM. */
107
108 void
109 write_string_to_stdio_stream (FILE *stream, struct console *con,
110 CONST Bufbyte *str,
111 Bytecount offset, Bytecount len,
112 enum external_data_format fmt)
113 {
114 int extlen;
115 CONST Extbyte *extptr;
116
117 GET_CHARPTR_EXT_DATA_ALLOCA (str + offset, len, fmt, extptr, extlen);
118 if (stream)
119 {
120 fwrite (extptr, 1, extlen, stream);
121 #ifdef WINDOWSNT
122 /* Q122442 says that pipes are "treated as files, not as
123 devices", and that this is a feature. Before I found that
124 article, I thought it was a bug. Thanks MS, I feel much
125 better now. - kkm */
126 if (stream == stdout || stream == stderr)
127 fflush (stream);
128 #endif
129 }
130 else
131 {
132 assert (CONSOLE_TTY_P (con));
133 Lstream_write (XLSTREAM (CONSOLE_TTY_DATA (con)->outstream),
134 extptr, extlen);
135 }
136 if (stream == stdout || stream == stderr ||
137 (!stream && CONSOLE_TTY_DATA (con)->is_stdio))
138 {
139 if (termscript)
140 {
141 fwrite (extptr, 1, extlen, termscript);
142 fflush (termscript);
143 }
144 stdout_needs_newline = (extptr[extlen - 1] != '\n');
145 }
146 }
147
148 /* Write a string to the output location specified in FUNCTION.
149 Arguments NONRELOC, RELOC, OFFSET, and LEN are as in
150 buffer_insert_string_1() in insdel.c. */
151
152 static void
153 output_string (Lisp_Object function, CONST Bufbyte *nonreloc,
154 Lisp_Object reloc, Bytecount offset, Bytecount len)
155 {
156 /* This function can GC */
157 Charcount cclen;
158 /* We change the value of nonreloc (fetching it from reloc as
159 necessary), but we don't want to pass this changed value on to
160 other functions that take both a nonreloc and a reloc, or things
161 may get confused and an assertion failure in
162 fixup_internal_substring() may get triggered. */
163 CONST Bufbyte *newnonreloc = nonreloc;
164 struct gcpro gcpro1, gcpro2;
165
166 /* Emacs won't print while GCing, but an external debugger might */
167 if (gc_in_progress) return;
168
169 /* Perhaps not necessary but probably safer. */
170 GCPRO2 (function, reloc);
171
172 fixup_internal_substring (newnonreloc, reloc, offset, &len);
173
174 if (STRINGP (reloc))
175 newnonreloc = XSTRING_DATA (reloc);
176
177 cclen = bytecount_to_charcount (newnonreloc + offset, len);
178
179 if (LSTREAMP (function))
180 {
181 if (STRINGP (reloc))
182 {
183 /* Protect against Lstream_write() causing a GC and
184 relocating the string. For small strings, we do it by
185 alloc'ing the string and using a copy; for large strings,
186 we inhibit GC. */
187 if (len < 65536)
188 {
189 Bufbyte *copied = alloca_array (Bufbyte, len);
190 memcpy (copied, newnonreloc + offset, len);
191 Lstream_write (XLSTREAM (function), copied, len);
192 }
193 else
194 {
195 int speccount = specpdl_depth ();
196 record_unwind_protect (restore_gc_inhibit,
197 make_int (gc_currently_forbidden));
198 gc_currently_forbidden = 1;
199 Lstream_write (XLSTREAM (function), newnonreloc + offset, len);
200 unbind_to (speccount, Qnil);
201 }
202 }
203 else
204 Lstream_write (XLSTREAM (function), newnonreloc + offset, len);
205
206 if (print_unbuffered)
207 Lstream_flush (XLSTREAM (function));
208 }
209 else if (BUFFERP (function))
210 {
211 CHECK_LIVE_BUFFER (function);
212 buffer_insert_string (XBUFFER (function), nonreloc, reloc, offset, len);
213 }
214 else if (MARKERP (function))
215 {
216 /* marker_position() will err if marker doesn't point anywhere. */
217 Bufpos spoint = marker_position (function);
218
219 buffer_insert_string_1 (XMARKER (function)->buffer,
220 spoint, nonreloc, reloc, offset, len,
221 0);
222 Fset_marker (function, make_int (spoint + cclen),
223 Fmarker_buffer (function));
224 }
225 else if (FRAMEP (function))
226 {
227 /* This gets used by functions not invoking print_prepare(),
228 such as Fwrite_char, Fterpri, etc.. */
229 struct frame *f = XFRAME (function);
230 CHECK_LIVE_FRAME (function);
231
232 if (!EQ (Vprint_message_label, echo_area_status (f)))
233 clear_echo_area_from_print (f, Qnil, 1);
234 echo_area_append (f, nonreloc, reloc, offset, len, Vprint_message_label);
235 }
236 else if (EQ (function, Qt) || EQ (function, Qnil))
237 {
238 write_string_to_stdio_stream (stdout, 0, newnonreloc, offset, len,
239 FORMAT_TERMINAL);
240 }
241 else
242 {
243 Charcount ccoff = bytecount_to_charcount (newnonreloc, offset);
244 Charcount iii;
245
246 for (iii = ccoff; iii < cclen + ccoff; iii++)
247 {
248 call1 (function,
249 make_char (charptr_emchar_n (newnonreloc, iii)));
250 if (STRINGP (reloc))
251 newnonreloc = XSTRING_DATA (reloc);
252 }
253 }
254
255 UNGCPRO;
256 }
257
258 #define RESET_PRINT_GENSYM do { \
259 if (!CONSP (Vprint_gensym)) \
260 Vprint_gensym_alist = Qnil; \
261 } while (0)
262
263 static Lisp_Object
264 canonicalize_printcharfun (Lisp_Object printcharfun)
265 {
266 if (NILP (printcharfun))
267 printcharfun = Vstandard_output;
268
269 if (EQ (printcharfun, Qt) || NILP (printcharfun))
270 printcharfun = Fselected_frame (Qnil); /* print to minibuffer */
271
272 return printcharfun;
273 }
274
275 static Lisp_Object
276 print_prepare (Lisp_Object printcharfun, Lisp_Object *frame_kludge)
277 {
278 /* Emacs won't print while GCing, but an external debugger might */
279 if (gc_in_progress)
280 return Qnil;
281
282 RESET_PRINT_GENSYM;
283
284 printcharfun = canonicalize_printcharfun (printcharfun);
285
286 /* Here we could safely return the canonicalized PRINTCHARFUN.
287 However, if PRINTCHARFUN is a frame, printing of complex
288 structures becomes very expensive, because `append-message'
289 (called by echo_area_append) gets called as many times as
290 output_string() is called (and that's a *lot*). append-message
291 tries to keep top of the message-stack in sync with the contents
292 of " *Echo Area" buffer, consing a new string for each component
293 of the printed structure. For instance, if you print (a a),
294 append-message will cons up the following strings:
295
296 "("
297 "(a"
298 "(a "
299 "(a a"
300 "(a a)"
301
302 and will use only the last one. With larger objects, this turns
303 into an O(n^2) consing frenzy that locks up XEmacs in incessant
304 garbage collection.
305
306 We prevent this by creating a resizing_buffer stream and letting
307 the printer write into it. print_finish() will notice this
308 stream, and invoke echo_area_append() with the stream's buffer,
309 only once. */
310 if (FRAMEP (printcharfun))
311 {
312 CHECK_LIVE_FRAME (printcharfun);
313 *frame_kludge = printcharfun;
314 printcharfun = make_resizing_buffer_output_stream ();
315 }
316
317 return printcharfun;
318 }
319
320 static void
321 print_finish (Lisp_Object stream, Lisp_Object frame_kludge)
322 {
323 /* Emacs won't print while GCing, but an external debugger might */
324 if (gc_in_progress)
325 return;
326
327 RESET_PRINT_GENSYM;
328
329 /* See the comment in print_prepare(). */
330 if (FRAMEP (frame_kludge))
331 {
332 struct frame *f = XFRAME (frame_kludge);
333 Lstream *str = XLSTREAM (stream);
334 CHECK_LIVE_FRAME (frame_kludge);
335
336 Lstream_flush (str);
337 if (!EQ (Vprint_message_label, echo_area_status (f)))
338 clear_echo_area_from_print (f, Qnil, 1);
339 echo_area_append (f, resizing_buffer_stream_ptr (str),
340 Qnil, 0, Lstream_byte_count (str),
341 Vprint_message_label);
342 Lstream_delete (str);
343 }
344 }
345
346 /* Used for printing a single-byte character (*not* any Emchar). */
347 #define write_char_internal(string_of_length_1, stream) \
348 output_string (stream, (CONST Bufbyte *) (string_of_length_1), \
349 Qnil, 0, 1)
350
351 /* NOTE: Do not call this with the data of a Lisp_String, as
352 printcharfun might cause a GC, which might cause the string's data
353 to be relocated. To princ a Lisp string, use:
354
355 print_internal (string, printcharfun, 0);
356
357 Also note that STREAM should be the result of
358 canonicalize_printcharfun() (i.e. Qnil means stdout, not
359 Vstandard_output, etc.) */
360 void
361 write_string_1 (CONST Bufbyte *str, Bytecount size, Lisp_Object stream)
362 {
363 /* This function can GC */
364 #ifdef ERROR_CHECK_BUFPOS
365 assert (size >= 0);
366 #endif
367 output_string (stream, str, Qnil, 0, size);
368 }
369
370 void
371 write_c_string (CONST char *str, Lisp_Object stream)
372 {
373 /* This function can GC */
374 write_string_1 ((CONST Bufbyte *) str, strlen (str), stream);
375 }
376
377
378 DEFUN ("write-char", Fwrite_char, 1, 2, 0, /*
379 Output character CH to stream STREAM.
380 STREAM defaults to the value of `standard-output' (which see).
381 */
382 (ch, stream))
383 {
384 /* This function can GC */
385 Bufbyte str[MAX_EMCHAR_LEN];
386 Bytecount len;
387
388 CHECK_CHAR_COERCE_INT (ch);
389 len = set_charptr_emchar (str, XCHAR (ch));
390 output_string (canonicalize_printcharfun (stream), str, Qnil, 0, len);
391 return ch;
392 }
393
394 void
395 temp_output_buffer_setup (Lisp_Object bufname)
396 {
397 /* This function can GC */
398 struct buffer *old = current_buffer;
399 Lisp_Object buf;
400
401 #ifdef I18N3
402 /* #### This function should accept a Lisp_Object instead of a char *,
403 so that proper translation on the buffer name can occur. */
404 #endif
405
406 Fset_buffer (Fget_buffer_create (bufname));
407
408 current_buffer->read_only = Qnil;
409 Ferase_buffer (Qnil);
410
411 XSETBUFFER (buf, current_buffer);
412 specbind (Qstandard_output, buf);
413
414 set_buffer_internal (old);
415 }
416
417 Lisp_Object
418 internal_with_output_to_temp_buffer (Lisp_Object bufname,
419 Lisp_Object (*function) (Lisp_Object arg),
420 Lisp_Object arg,
421 Lisp_Object same_frame)
422 {
423 int speccount = specpdl_depth ();
424 struct gcpro gcpro1, gcpro2, gcpro3;
425 Lisp_Object buf = Qnil;
426
427 GCPRO3 (buf, arg, same_frame);
428
429 temp_output_buffer_setup (bufname);
430 buf = Vstandard_output;
431
432 arg = (*function) (arg);
433
434 temp_output_buffer_show (buf, same_frame);
435 UNGCPRO;
436
437 return unbind_to (speccount, arg);
438 }
439
440 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer, 1, UNEVALLED, 0, /*
441 Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
442 The buffer is cleared out initially, and marked as unmodified when done.
443 All output done by BODY is inserted in that buffer by default.
444 The buffer is displayed in another window, but not selected.
445 The value of the last form in BODY is returned.
446 If BODY does not finish normally, the buffer BUFNAME is not displayed.
447
448 If variable `temp-buffer-show-function' is non-nil, call it at the end
449 to get the buffer displayed. It gets one argument, the buffer to display.
450 */
451 (args))
452 {
453 /* This function can GC */
454 Lisp_Object name = Qnil;
455 int speccount = specpdl_depth ();
456 struct gcpro gcpro1, gcpro2;
457 Lisp_Object val = Qnil;
458
459 #ifdef I18N3
460 /* #### should set the buffer to be translating. See print_internal(). */
461 #endif
462
463 GCPRO2 (name, val);
464 name = Feval (XCAR (args));
465
466 CHECK_STRING (name);
467
468 temp_output_buffer_setup (name);
469 UNGCPRO;
470
471 val = Fprogn (XCDR (args));
472
473 temp_output_buffer_show (Vstandard_output, Qnil);
474
475 return unbind_to (speccount, val);
476 }
477
478 DEFUN ("terpri", Fterpri, 0, 1, 0, /*
479 Output a newline to STREAM.
480 If STREAM is omitted or nil, the value of `standard-output' is used.
481 */
482 (stream))
483 {
484 /* This function can GC */
485 write_char_internal ("\n", canonicalize_printcharfun (stream));
486 return Qt;
487 }
488
489 DEFUN ("prin1", Fprin1, 1, 2, 0, /*
490 Output the printed representation of OBJECT, any Lisp object.
491 Quoting characters are printed when needed to make output that `read'
492 can handle, whenever this is possible.
493 Output stream is STREAM, or value of `standard-output' (which see).
494 */
495 (object, stream))
496 {
497 /* This function can GC */
498 Lisp_Object frame = Qnil;
499 struct gcpro gcpro1, gcpro2;
500 GCPRO2 (object, stream);
501
502 print_depth = 0;
503 stream = print_prepare (stream, &frame);
504 print_internal (object, stream, 1);
505 print_finish (stream, frame);
506
507 UNGCPRO;
508 return object;
509 }
510
511 DEFUN ("prin1-to-string", Fprin1_to_string, 1, 2, 0, /*
512 Return a string containing the printed representation of OBJECT,
513 any Lisp object. Quoting characters are used when needed to make output
514 that `read' can handle, whenever this is possible, unless the optional
515 second argument NOESCAPE is non-nil.
516 */
517 (object, noescape))
518 {
519 /* This function can GC */
520 Lisp_Object result = Qnil;
521 Lisp_Object stream = make_resizing_buffer_output_stream ();
522 Lstream *str = XLSTREAM (stream);
523 /* gcpro OBJECT in case a caller forgot to do so */
524 struct gcpro gcpro1, gcpro2, gcpro3;
525 GCPRO3 (object, stream, result);
526
527 print_depth = 0;
528 RESET_PRINT_GENSYM;
529 print_internal (object, stream, NILP (noescape));
530 RESET_PRINT_GENSYM;
531 Lstream_flush (str);
532 UNGCPRO;
533 result = make_string (resizing_buffer_stream_ptr (str),
534 Lstream_byte_count (str));
535 Lstream_delete (str);
536 return result;
537 }
538
539 DEFUN ("princ", Fprinc, 1, 2, 0, /*
540 Output the printed representation of OBJECT, any Lisp object.
541 No quoting characters are used; no delimiters are printed around
542 the contents of strings.
543 Output stream is STREAM, or value of standard-output (which see).
544 */
545 (object, stream))
546 {
547 /* This function can GC */
548 Lisp_Object frame = Qnil;
549 struct gcpro gcpro1, gcpro2;
550
551 GCPRO2 (object, stream);
552 stream = print_prepare (stream, &frame);
553 print_depth = 0;
554 print_internal (object, stream, 0);
555 print_finish (stream, frame);
556 UNGCPRO;
557 return object;
558 }
559
560 DEFUN ("print", Fprint, 1, 2, 0, /*
561 Output the printed representation of OBJECT, with newlines around it.
562 Quoting characters are printed when needed to make output that `read'
563 can handle, whenever this is possible.
564 Output stream is STREAM, or value of `standard-output' (which see).
565 */
566 (object, stream))
567 {
568 /* This function can GC */
569 Lisp_Object frame = Qnil;
570 struct gcpro gcpro1, gcpro2;
571
572 GCPRO2 (object, stream);
573 stream = print_prepare (stream, &frame);
574 print_depth = 0;
575 write_char_internal ("\n", stream);
576 print_internal (object, stream, 1);
577 write_char_internal ("\n", stream);
578 print_finish (stream, frame);
579 UNGCPRO;
580 return object;
581 }
582
583 /* Print an error message for the error DATA to STREAM. This is a
584 complete implementation of `display-error', which used to be in
585 Lisp (see prim/cmdloop.el). It was ported to C so it can be used
586 efficiently by Ferror_message_string. Fdisplay_error and
587 Ferror_message_string are trivial wrappers around this function.
588
589 STREAM should be the result of canonicalize_printcharfun(). */
590 static void
591 print_error_message (Lisp_Object error_object, Lisp_Object stream)
592 {
593 /* This function can GC */
594 Lisp_Object type = Fcar_safe (error_object);
595 Lisp_Object method = Qnil;
596 Lisp_Object tail;
597
598 /* No need to GCPRO anything under the assumption that ERROR_OBJECT
599 is GCPRO'd. */
600
601 if (! (CONSP (error_object) && SYMBOLP (type)
602 && CONSP (Fget (type, Qerror_conditions, Qnil))))
603 goto error_throw;
604
605 tail = XCDR (error_object);
606 while (!NILP (tail))
607 {
608 if (CONSP (tail))
609 tail = XCDR (tail);
610 else
611 goto error_throw;
612 }
613 tail = Fget (type, Qerror_conditions, Qnil);
614 while (!NILP (tail))
615 {
616 if (!(CONSP (tail) && SYMBOLP (XCAR (tail))))
617 goto error_throw;
618 else if (!NILP (Fget (XCAR (tail), Qdisplay_error, Qnil)))
619 {
620 method = Fget (XCAR (tail), Qdisplay_error, Qnil);
621 goto error_throw;
622 }
623 else
624 tail = XCDR (tail);
625 }
626 /* Default method */
627 {
628 int first = 1;
629 int speccount = specpdl_depth ();
630
631 specbind (Qprint_message_label, Qerror);
632 tail = Fcdr (error_object);
633 if (EQ (type, Qerror))
634 {
635 print_internal (Fcar (tail), stream, 0);
636 tail = Fcdr (tail);
637 }
638 else
639 {
640 Lisp_Object errmsg = Fget (type, Qerror_message, Qnil);
641 if (NILP (errmsg))
642 print_internal (type, stream, 0);
643 else
644 print_internal (LISP_GETTEXT (errmsg), stream, 0);
645 }
646 while (!NILP (tail))
647 {
648 write_c_string (first ? ": " : ", ", stream);
649 print_internal (Fcar (tail), stream, 1);
650 tail = Fcdr (tail);
651 first = 0;
652 }
653 unbind_to (speccount, Qnil);
654 return;
655 /* not reached */
656 }
657
658 error_throw:
659 if (NILP (method))
660 {
661 write_c_string (GETTEXT ("Peculiar error "), stream);
662 print_internal (error_object, stream, 1);
663 return;
664 }
665 else
666 {
667 call2 (method, error_object, stream);
668 }
669 }
670
671 DEFUN ("error-message-string", Ferror_message_string, 1, 1, 0, /*
672 Convert ERROR-OBJECT to an error message, and return it.
673
674 The format of ERROR-OBJECT should be (ERROR-SYMBOL . DATA). The
675 message is equivalent to the one that would be issued by
676 `display-error' with the same argument.
677 */
678 (error_object))
679 {
680 /* This function can GC */
681 Lisp_Object result = Qnil;
682 Lisp_Object stream = make_resizing_buffer_output_stream ();
683 struct gcpro gcpro1;
684 GCPRO1 (stream);
685
686 print_error_message (error_object, stream);
687 Lstream_flush (XLSTREAM (stream));
688 result = make_string (resizing_buffer_stream_ptr (XLSTREAM (stream)),
689 Lstream_byte_count (XLSTREAM (stream)));
690 Lstream_delete (XLSTREAM (stream));
691
692 UNGCPRO;
693 return result;
694 }
695
696 DEFUN ("display-error", Fdisplay_error, 2, 2, 0, /*
697 Display ERROR-OBJECT on STREAM in a user-friendly way.
698 */
699 (error_object, stream))
700 {
701 /* This function can GC */
702 print_error_message (error_object, canonicalize_printcharfun (stream));
703 return Qnil;
704 }
705
706
707 #ifdef LISP_FLOAT_TYPE
708
709 Lisp_Object Vfloat_output_format;
710
711 /*
712 * This buffer should be at least as large as the max string size of the
713 * largest float, printed in the biggest notation. This is undoubtably
714 * 20d float_output_format, with the negative of the C-constant "HUGE"
715 * from <math.h>.
716 *
717 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
718 *
719 * I assume that IEEE-754 format numbers can take 329 bytes for the worst
720 * case of -1e307 in 20d float_output_format. What is one to do (short of
721 * re-writing _doprnt to be more sane)?
722 * -wsr
723 */
724 void
725 float_to_string (char *buf, double data)
726 {
727 Bufbyte *cp, c;
728 int width;
729
730 if (NILP (Vfloat_output_format)
731 || !STRINGP (Vfloat_output_format))
732 lose:
733 sprintf (buf, "%.16g", data);
734 else /* oink oink */
735 {
736 /* Check that the spec we have is fully valid.
737 This means not only valid for printf,
738 but meant for floats, and reasonable. */
739 cp = XSTRING_DATA (Vfloat_output_format);
740
741 if (cp[0] != '%')
742 goto lose;
743 if (cp[1] != '.')
744 goto lose;
745
746 cp += 2;
747 for (width = 0; (c = *cp, isdigit (c)); cp++)
748 {
749 width *= 10;
750 width += c - '0';
751 }
752
753 if (*cp != 'e' && *cp != 'f' && *cp != 'g' && *cp != 'E' && *cp != 'G')
754 goto lose;
755
756 if (width < (int) (*cp != 'e' && *cp != 'E') || width > DBL_DIG)
757 goto lose;
758
759 if (cp[1] != 0)
760 goto lose;
761
762 sprintf (buf, (char *) XSTRING_DATA (Vfloat_output_format),
763 data);
764 }
765
766 /* added by jwz: don't allow "1.0" to print as "1"; that destroys
767 the read-equivalence of lisp objects. (* x 1) and (* x 1.0) do
768 not do the same thing, so it's important that the printed
769 representation of that form not be corrupted by the printer.
770 */
771 {
772 Bufbyte *s = (Bufbyte *) buf; /* don't use signed chars here!
773 isdigit() can't hack them! */
774 if (*s == '-') s++;
775 for (; *s; s++)
776 /* if there's a non-digit, then there is a decimal point, or
777 it's in exponential notation, both of which are ok. */
778 if (!isdigit (*s))
779 goto DONE_LABEL;
780 /* otherwise, we need to hack it. */
781 *s++ = '.';
782 *s++ = '0';
783 *s = 0;
784 }
785 DONE_LABEL:
786
787 /* Some machines print "0.4" as ".4". I don't like that. */
788 if (buf [0] == '.' || (buf [0] == '-' && buf [1] == '.'))
789 {
790 int i;
791 for (i = strlen (buf) + 1; i >= 0; i--)
792 buf [i+1] = buf [i];
793 buf [(buf [0] == '-' ? 1 : 0)] = '0';
794 }
795 }
796 #endif /* LISP_FLOAT_TYPE */
797
798 /* Print NUMBER to BUFFER. The digits are first written in reverse
799 order (the least significant digit first), and are then reversed.
800 This is equivalent to sprintf(buffer, "%ld", number), only much
801 faster.
802
803 BUFFER should accept 24 bytes. This should suffice for the longest
804 numbers on 64-bit machines, including the `-' sign and the trailing
805 \0. */
806 void
807 long_to_string (char *buffer, long number)
808 {
809 #if (SIZEOF_LONG != 4) && (SIZEOF_LONG != 8)
810 /* Huh? */
811 sprintf (buffer, "%ld", number);
812 #else /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
813 char *p = buffer;
814 int force = 0;
815
816 if (number < 0)
817 {
818 *p++ = '-';
819 number = -number;
820 }
821
822 #define FROB(figure) do { \
823 if (force || number >= figure) \
824 *p++ = number / figure + '0', number %= figure, force = 1; \
825 } while (0)
826 #if SIZEOF_LONG == 8
827 FROB (1000000000000000000L);
828 FROB (100000000000000000L);
829 FROB (10000000000000000L);
830 FROB (1000000000000000L);
831 FROB (100000000000000L);
832 FROB (10000000000000L);
833 FROB (1000000000000L);
834 FROB (100000000000L);
835 FROB (10000000000L);
836 #endif /* SIZEOF_LONG == 8 */
837 FROB (1000000000);
838 FROB (100000000);
839 FROB (10000000);
840 FROB (1000000);
841 FROB (100000);
842 FROB (10000);
843 FROB (1000);
844 FROB (100);
845 FROB (10);
846 #undef FROB
847 *p++ = number + '0';
848 *p = '\0';
849 #endif /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
850 }
851
852 static void
853 print_vector_internal (CONST char *start, CONST char *end,
854 Lisp_Object obj,
855 Lisp_Object printcharfun, int escapeflag)
856 {
857 /* This function can GC */
858 int i;
859 int len = XVECTOR_LENGTH (obj);
860 int last = len;
861 struct gcpro gcpro1, gcpro2;
862 GCPRO2 (obj, printcharfun);
863
864 if (INTP (Vprint_length))
865 {
866 int max = XINT (Vprint_length);
867 if (max < len) last = max;
868 }
869
870 write_c_string (start, printcharfun);
871 for (i = 0; i < last; i++)
872 {
873 Lisp_Object elt = XVECTOR_DATA (obj)[i];
874 if (i != 0) write_char_internal (" ", printcharfun);
875 print_internal (elt, printcharfun, escapeflag);
876 }
877 UNGCPRO;
878 if (last != len)
879 write_c_string (" ...", printcharfun);
880 write_c_string (end, printcharfun);
881 }
882
883 void
884 print_cons (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
885 {
886 /* This function can GC */
887 struct gcpro gcpro1, gcpro2;
888
889 /* If print_readably is on, print (quote -foo-) as '-foo-
890 (Yeah, this should really be what print-pretty does, but we
891 don't have the rest of a pretty printer, and this actually
892 has non-negligible impact on size/speed of .elc files.)
893 */
894 if (print_readably &&
895 EQ (XCAR (obj), Qquote) &&
896 CONSP (XCDR (obj)) &&
897 NILP (XCDR (XCDR (obj))))
898 {
899 obj = XCAR (XCDR (obj));
900 GCPRO2 (obj, printcharfun);
901 write_char_internal ("\'", printcharfun);
902 UNGCPRO;
903 print_internal (obj, printcharfun, escapeflag);
904 return;
905 }
906
907 GCPRO2 (obj, printcharfun);
908 write_char_internal ("(", printcharfun);
909
910 {
911 int len;
912 int max = INTP (Vprint_length) ? XINT (Vprint_length) : INT_MAX;
913 Lisp_Object tortoise;
914 /* Use tortoise/hare to make sure circular lists don't infloop */
915
916 for (tortoise = obj, len = 0;
917 CONSP (obj);
918 obj = XCDR (obj), len++)
919 {
920 if (len > 0)
921 write_char_internal (" ", printcharfun);
922 if (EQ (obj, tortoise) && len > 0)
923 {
924 if (print_readably)
925 error ("printing unreadable circular list");
926 else
927 write_c_string ("... <circular list>", printcharfun);
928 break;
929 }
930 if (len & 1)
931 tortoise = XCDR (tortoise);
932 if (len > max)
933 {
934 write_c_string ("...", printcharfun);
935 break;
936 }
937 print_internal (XCAR (obj), printcharfun, escapeflag);
938 }
939 }
940 if (!LISTP (obj))
941 {
942 write_c_string (" . ", printcharfun);
943 print_internal (obj, printcharfun, escapeflag);
944 }
945 UNGCPRO;
946
947 write_char_internal (")", printcharfun);
948 return;
949 }
950
951 void
952 print_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
953 {
954 print_vector_internal ("[", "]", obj, printcharfun, escapeflag);
955 }
956
957 void
958 print_string (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
959 {
960 struct Lisp_String *s = XSTRING (obj);
961 /* We distinguish between Bytecounts and Charcounts, to make
962 Vprint_string_length work correctly under Mule. */
963 Charcount size = string_char_length (s);
964 Charcount max = size;
965 Bytecount bcmax = string_length (s);
966 struct gcpro gcpro1, gcpro2;
967 GCPRO2 (obj, printcharfun);
968
969 if (INTP (Vprint_string_length) &&
970 XINT (Vprint_string_length) < max)
971 {
972 max = XINT (Vprint_string_length);
973 bcmax = charcount_to_bytecount (string_data (s), max);
974 }
975 if (max < 0)
976 {
977 max = 0;
978 bcmax = 0;
979 }
980
981 if (!escapeflag)
982 {
983 /* This deals with GC-relocation and Mule. */
984 output_string (printcharfun, 0, obj, 0, bcmax);
985 if (max < size)
986 write_c_string (" ...", printcharfun);
987 }
988 else
989 {
990 Bytecount i, last = 0;
991
992 write_char_internal ("\"", printcharfun);
993 for (i = 0; i < bcmax; i++)
994 {
995 Bufbyte ch = string_byte (s, i);
996 if (ch == '\"' || ch == '\\'
997 || (ch == '\n' && print_escape_newlines))
998 {
999 if (i > last)
1000 {
1001 output_string (printcharfun, 0, obj, last,
1002 i - last);
1003 }
1004 if (ch == '\n')
1005 {
1006 write_c_string ("\\n", printcharfun);
1007 }
1008 else
1009 {
1010 write_char_internal ("\\", printcharfun);
1011 /* This is correct for Mule because the
1012 character is either \ or " */
1013 write_char_internal (string_data (s) + i, printcharfun);
1014 }
1015 last = i + 1;
1016 }
1017 }
1018 if (bcmax > last)
1019 {
1020 output_string (printcharfun, 0, obj, last,
1021 bcmax - last);
1022 }
1023 if (max < size)
1024 write_c_string (" ...", printcharfun);
1025 write_char_internal ("\"", printcharfun);
1026 }
1027 UNGCPRO;
1028 }
1029
1030 static void
1031 default_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
1032 int escapeflag)
1033 {
1034 struct lcrecord_header *header =
1035 (struct lcrecord_header *) XPNTR (obj);
1036 char buf[200];
1037
1038 if (print_readably)
1039 error ("printing unreadable object #<%s 0x%x>",
1040 LHEADER_IMPLEMENTATION (&header->lheader)->name,
1041 header->uid);
1042
1043 sprintf (buf, "#<%s 0x%x>",
1044 LHEADER_IMPLEMENTATION (&header->lheader)->name,
1045 header->uid);
1046 write_c_string (buf, printcharfun);
1047 }
1048
1049 void
1050 internal_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
1051 int escapeflag)
1052 {
1053 char buf[200];
1054 sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>",
1055 XRECORD_LHEADER_IMPLEMENTATION (obj)->name,
1056 (unsigned long) XPNTR (obj));
1057 write_c_string (buf, printcharfun);
1058 }
1059
1060 void
1061 print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1062 {
1063 /* This function can GC */
1064
1065 QUIT;
1066
1067 /* Emacs won't print while GCing, but an external debugger might */
1068 if (gc_in_progress) return;
1069
1070 #ifdef I18N3
1071 /* #### Both input and output streams should have a flag associated
1072 with them indicating whether output to that stream, or strings
1073 read from the stream, get translated using Fgettext(). Such a
1074 stream is called a "translating stream". For the minibuffer and
1075 external-debugging-output this is always true on output, and
1076 with-output-to-temp-buffer sets the flag to true for the buffer
1077 it creates. This flag should also be user-settable. Perhaps it
1078 should be split up into two flags, one for input and one for
1079 output. */
1080 #endif
1081
1082 /* Detect circularities and truncate them.
1083 No need to offer any alternative--this is better than an error. */
1084 if (CONSP (obj) || VECTORP (obj) || COMPILED_FUNCTIONP (obj))
1085 {
1086 int i;
1087 for (i = 0; i < print_depth; i++)
1088 if (EQ (obj, being_printed[i]))
1089 {
1090 char buf[32];
1091 *buf = '#';
1092 long_to_string (buf + 1, i);
1093 write_c_string (buf, printcharfun);
1094 return;
1095 }
1096 }
1097
1098 being_printed[print_depth] = obj;
1099 print_depth++;
1100
1101 if (print_depth > PRINT_CIRCLE)
1102 error ("Apparently circular structure being printed");
1103
1104 switch (XTYPE (obj))
1105 {
1106 case Lisp_Type_Int_Even:
1107 case Lisp_Type_Int_Odd:
1108 {
1109 char buf[24];
1110 long_to_string (buf, XINT (obj));
1111 write_c_string (buf, printcharfun);
1112 break;
1113 }
1114
1115 case Lisp_Type_Char:
1116 {
1117 /* God intended that this be #\..., you know. */
1118 char buf[16];
1119 Emchar ch = XCHAR (obj);
1120 char *p = buf;
1121 *p++ = '?';
1122 if (ch == '\n')
1123 *p++ = '\\', *p++ = 'n';
1124 else if (ch == '\r')
1125 *p++ = '\\', *p++ = 'r';
1126 else if (ch == '\t')
1127 *p++ = '\\', *p++ = 't';
1128 else if (ch < 32)
1129 {
1130 *p++ = '\\', *p++ = '^';
1131 *p++ = ch + 64;
1132 if ((ch + 64) == '\\')
1133 *p++ = '\\';
1134 }
1135 else if (ch == 127)
1136 *p++ = '\\', *p++ = '^', *p++ = '?';
1137 else if (ch >= 128 && ch < 160)
1138 {
1139 *p++ = '\\', *p++ = '^';
1140 p += set_charptr_emchar ((Bufbyte *)p, ch + 64);
1141 }
1142 else if (ch < 127
1143 && !isdigit (ch)
1144 && !isalpha (ch)
1145 && ch != '^') /* must not backslash this or it will
1146 be interpreted as the start of a
1147 control char */
1148 *p++ = '\\', *p++ = ch;
1149 else
1150 p += set_charptr_emchar ((Bufbyte *)p, ch);
1151 output_string (printcharfun, (Bufbyte *)buf, Qnil, 0, p - buf);
1152 break;
1153 }
1154
1155 case Lisp_Type_Record:
1156 {
1157 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
1158 struct gcpro gcpro1, gcpro2;
1159
1160 if (CONSP (obj) || VECTORP(obj))
1161 {
1162 /* If deeper than spec'd depth, print placeholder. */
1163 if (INTP (Vprint_level)
1164 && print_depth > XINT (Vprint_level))
1165 {
1166 GCPRO2 (obj, printcharfun);
1167 write_c_string ("...", printcharfun);
1168 UNGCPRO;
1169 break;
1170 }
1171 }
1172
1173 GCPRO2 (obj, printcharfun);
1174 if (LHEADER_IMPLEMENTATION (lheader)->printer)
1175 ((LHEADER_IMPLEMENTATION (lheader)->printer)
1176 (obj, printcharfun, escapeflag));
1177 else
1178 default_object_printer (obj, printcharfun, escapeflag);
1179 UNGCPRO;
1180 break;
1181 }
1182
1183 default:
1184 {
1185 #ifdef ERROR_CHECK_TYPECHECK
1186 abort ();
1187 #else /* not ERROR_CHECK_TYPECHECK */
1188 char buf[128];
1189 /* We're in trouble if this happens! */
1190 if (print_readably)
1191 error ("printing illegal data type #o%03o",
1192 (int) XTYPE (obj));
1193 write_c_string ("#<EMACS BUG: ILLEGAL DATATYPE ",
1194 printcharfun);
1195 sprintf (buf, "(#o%3o)", (int) XTYPE (obj));
1196 write_c_string (buf, printcharfun);
1197 write_c_string
1198 (" Save your buffers immediately and please report this bug>",
1199 printcharfun);
1200 #endif /* not ERROR_CHECK_TYPECHECK */
1201 break;
1202 }
1203 }
1204
1205 print_depth--;
1206 }
1207
1208
1209 #ifdef LISP_FLOAT_TYPE
1210 void
1211 print_float (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1212 {
1213 char pigbuf[350]; /* see comments in float_to_string */
1214
1215 float_to_string (pigbuf, XFLOAT_DATA (obj));
1216 write_c_string (pigbuf, printcharfun);
1217 }
1218 #endif /* LISP_FLOAT_TYPE */
1219
1220 void
1221 print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1222 {
1223 /* This function can GC */
1224 /* #### Bug!! (intern "") isn't printed in some distinguished way */
1225 /* #### (the reader also loses on it) */
1226 struct Lisp_String *name = symbol_name (XSYMBOL (obj));
1227 Bytecount size = string_length (name);
1228 struct gcpro gcpro1, gcpro2;
1229
1230 if (!escapeflag)
1231 {
1232 /* This deals with GC-relocation */
1233 Lisp_Object nameobj;
1234 XSETSTRING (nameobj, name);
1235 output_string (printcharfun, 0, nameobj, 0, size);
1236 return;
1237 }
1238 GCPRO2 (obj, printcharfun);
1239
1240 /* If we print an uninterned symbol as part of a complex object and
1241 the flag print-gensym is non-nil, prefix it with #n= to read the
1242 object back with the #n# reader syntax later if needed. */
1243 if (!NILP (Vprint_gensym)
1244 /* #### Test whether this produces a noticable slow-down for
1245 printing when print-gensym is non-nil. */
1246 && !EQ (obj, oblookup (Vobarray,
1247 string_data (symbol_name (XSYMBOL (obj))),
1248 string_length (symbol_name (XSYMBOL (obj))))))
1249 {
1250 if (print_depth > 1)
1251 {
1252 Lisp_Object tem = Fassq (obj, Vprint_gensym_alist);
1253 if (CONSP (tem))
1254 {
1255 write_char_internal ("#", printcharfun);
1256 print_internal (XCDR (tem), printcharfun, escapeflag);
1257 write_char_internal ("#", printcharfun);
1258 return;
1259 }
1260 else
1261 {
1262 if (CONSP (Vprint_gensym_alist))
1263 {
1264 /* Vprint_gensym_alist is exposed to Lisp, so we
1265 have to be careful. */
1266 CHECK_CONS (XCAR (Vprint_gensym_alist));
1267 CHECK_INT (XCDR (XCAR (Vprint_gensym_alist)));
1268 XSETINT (tem, XINT (XCDR (XCAR (Vprint_gensym_alist))) + 1);
1269 }
1270 else
1271 XSETINT (tem, 1);
1272 Vprint_gensym_alist = Fcons (Fcons (obj, tem), Vprint_gensym_alist);
1273
1274 write_char_internal ("#", printcharfun);
1275 print_internal (tem, printcharfun, escapeflag);
1276 write_char_internal ("=", printcharfun);
1277 }
1278 }
1279 write_c_string ("#:", printcharfun);
1280 }
1281
1282 /* Does it look like an integer or a float? */
1283 {
1284 Bufbyte *data = string_data (name);
1285 Bytecount confusing = 0;
1286
1287 if (size == 0)
1288 goto not_yet_confused; /* Really confusing */
1289 else if (isdigit (data[0]))
1290 confusing = 0;
1291 else if (size == 1)
1292 goto not_yet_confused;
1293 else if (data[0] == '-' || data[0] == '+')
1294 confusing = 1;
1295 else
1296 goto not_yet_confused;
1297
1298 for (; confusing < size; confusing++)
1299 {
1300 if (!isdigit (data[confusing]))
1301 {
1302 confusing = 0;
1303 break;
1304 }
1305 }
1306 not_yet_confused:
1307
1308 #ifdef LISP_FLOAT_TYPE
1309 if (!confusing)
1310 /* #### Ugh, this is needlessly complex and slow for what we
1311 need here. It might be a good idea to copy equivalent code
1312 from FSF. --hniksic */
1313 confusing = isfloat_string ((char *) data);
1314 #endif
1315 if (confusing)
1316 write_char_internal ("\\", printcharfun);
1317 }
1318
1319 {
1320 Lisp_Object nameobj;
1321 Bytecount i;
1322 Bytecount last = 0;
1323
1324 XSETSTRING (nameobj, name);
1325 for (i = 0; i < size; i++)
1326 {
1327 switch (string_byte (name, i))
1328 {
1329 case 0: case 1: case 2: case 3:
1330 case 4: case 5: case 6: case 7:
1331 case 8: case 9: case 10: case 11:
1332 case 12: case 13: case 14: case 15:
1333 case 16: case 17: case 18: case 19:
1334 case 20: case 21: case 22: case 23:
1335 case 24: case 25: case 26: case 27:
1336 case 28: case 29: case 30: case 31:
1337 case ' ': case '\"': case '\\': case '\'':
1338 case ';': case '#' : case '(' : case ')':
1339 case ',': case '.' : case '`' :
1340 case '[': case ']' : case '?' :
1341 if (i > last)
1342 output_string (printcharfun, 0, nameobj, last, i - last);
1343 write_char_internal ("\\", printcharfun);
1344 last = i;
1345 }
1346 }
1347 output_string (printcharfun, 0, nameobj, last, size - last);
1348 }
1349 UNGCPRO;
1350 }
1351
1352 /* #ifdef DEBUG_XEMACS */
1353
1354 /* I don't like seeing `Note: Strange doc (not fboundp) for function
1355 alternate-debugging-output @ 429542' -slb */
1356 /* #### Eek! Any clue how to get rid of it? In fact, how about
1357 getting rid of this function altogether? Does anything actually
1358 *use* it? --hniksic */
1359
1360 static int alternate_do_pointer;
1361 static char alternate_do_string[5000];
1362
1363 DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /*
1364 Append CHARACTER to the array `alternate_do_string'.
1365 This can be used in place of `external-debugging-output' as a function
1366 to be passed to `print'. Before calling `print', set `alternate_do_pointer'
1367 to 0.
1368 */
1369 (character))
1370 {
1371 Bufbyte str[MAX_EMCHAR_LEN];
1372 Bytecount len;
1373 int extlen;
1374 CONST Extbyte *extptr;
1375
1376 CHECK_CHAR_COERCE_INT (character);
1377 len = set_charptr_emchar (str, XCHAR (character));
1378 GET_CHARPTR_EXT_DATA_ALLOCA (str, len, FORMAT_TERMINAL, extptr, extlen);
1379 memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen);
1380 alternate_do_pointer += extlen;
1381 alternate_do_string[alternate_do_pointer] = 0;
1382 return character;
1383 }
1384 /* #endif / * DEBUG_XEMACS */
1385
1386 DEFUN ("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /*
1387 Write CHAR-OR-STRING to stderr or stdout.
1388 If optional arg STDOUT-P is non-nil, write to stdout; otherwise, write
1389 to stderr. You can use this function to write directly to the terminal.
1390 This function can be used as the STREAM argument of Fprint() or the like.
1391
1392 If you have opened a termscript file (using `open-termscript'), then
1393 the output also will be logged to this file.
1394 */
1395 (char_or_string, stdout_p, device))
1396 {
1397 FILE *file = 0;
1398 struct console *con = 0;
1399
1400 if (NILP (device))
1401 {
1402 if (!NILP (stdout_p))
1403 file = stdout;
1404 else
1405 file = stderr;
1406 }
1407 else
1408 {
1409 CHECK_LIVE_DEVICE (device);
1410 if (!DEVICE_TTY_P (XDEVICE (device)) &&
1411 !DEVICE_STREAM_P (XDEVICE (device)))
1412 signal_simple_error ("Must be tty or stream device", device);
1413 con = XCONSOLE (DEVICE_CONSOLE (XDEVICE (device)));
1414 if (DEVICE_TTY_P (XDEVICE (device)))
1415 file = 0;
1416 else if (!NILP (stdout_p))
1417 file = CONSOLE_STREAM_DATA (con)->out;
1418 else
1419 file = CONSOLE_STREAM_DATA (con)->err;
1420 }
1421
1422 if (STRINGP (char_or_string))
1423 write_string_to_stdio_stream (file, con,
1424 XSTRING_DATA (char_or_string),
1425 0, XSTRING_LENGTH (char_or_string),
1426 FORMAT_TERMINAL);
1427 else
1428 {
1429 Bufbyte str[MAX_EMCHAR_LEN];
1430 Bytecount len;
1431
1432 CHECK_CHAR_COERCE_INT (char_or_string);
1433 len = set_charptr_emchar (str, XCHAR (char_or_string));
1434 write_string_to_stdio_stream (file, con, str, 0, len, FORMAT_TERMINAL);
1435 }
1436
1437 return char_or_string;
1438 }
1439
1440 DEFUN ("open-termscript", Fopen_termscript, 1, 1, "FOpen termscript file: ", /*
1441 Start writing all terminal output to FILE as well as the terminal.
1442 FILE = nil means just close any termscript file currently open.
1443 */
1444 (file))
1445 {
1446 /* This function can GC */
1447 if (termscript != 0)
1448 fclose (termscript);
1449 termscript = 0;
1450
1451 if (! NILP (file))
1452 {
1453 file = Fexpand_file_name (file, Qnil);
1454 termscript = fopen ((char *) XSTRING_DATA (file), "w");
1455 if (termscript == NULL)
1456 report_file_error ("Opening termscript", list1 (file));
1457 }
1458 return Qnil;
1459 }
1460
1461 #if 1
1462 /* Debugging kludge -- unbuffered */
1463 static int debug_print_length = 50;
1464 static int debug_print_level = 15;
1465
1466 static void
1467 debug_print_no_newline (Lisp_Object debug_print_obj)
1468 {
1469 /* This function can GC */
1470 int old_print_readably = print_readably;
1471 int old_print_depth = print_depth;
1472 Lisp_Object old_print_length = Vprint_length;
1473 Lisp_Object old_print_level = Vprint_level;
1474 Lisp_Object old_inhibit_quit = Vinhibit_quit;
1475 struct gcpro gcpro1, gcpro2, gcpro3;
1476 GCPRO3 (old_print_level, old_print_length, old_inhibit_quit);
1477
1478 if (gc_in_progress)
1479 stderr_out ("** gc-in-progress! Bad idea to print anything! **\n");
1480
1481 print_depth = 0;
1482 print_readably = 0;
1483 print_unbuffered++;
1484 /* Could use unwind-protect, but why bother? */
1485 if (debug_print_length > 0)
1486 Vprint_length = make_int (debug_print_length);
1487 if (debug_print_level > 0)
1488 Vprint_level = make_int (debug_print_level);
1489 print_internal (debug_print_obj, Qexternal_debugging_output, 1);
1490 Vinhibit_quit = old_inhibit_quit;
1491 Vprint_level = old_print_level;
1492 Vprint_length = old_print_length;
1493 print_depth = old_print_depth;
1494 print_readably = old_print_readably;
1495 print_unbuffered--;
1496 UNGCPRO;
1497 }
1498
1499 void
1500 debug_print (Lisp_Object debug_print_obj)
1501 {
1502 debug_print_no_newline (debug_print_obj);
1503 stderr_out ("\n");
1504 fflush (stderr);
1505 }
1506
1507 /* Debugging kludge -- unbuffered */
1508 /* This function provided for the benefit of the debugger. */
1509 void debug_backtrace (void);
1510 void
1511 debug_backtrace (void)
1512 {
1513 /* This function can GC */
1514 int old_print_readably = print_readably;
1515 int old_print_depth = print_depth;
1516 Lisp_Object old_print_length = Vprint_length;
1517 Lisp_Object old_print_level = Vprint_level;
1518 Lisp_Object old_inhibit_quit = Vinhibit_quit;
1519
1520 struct gcpro gcpro1, gcpro2, gcpro3;
1521 GCPRO3 (old_print_level, old_print_length, old_inhibit_quit);
1522
1523 if (gc_in_progress)
1524 stderr_out ("** gc-in-progress! Bad idea to print anything! **\n");
1525
1526 print_depth = 0;
1527 print_readably = 0;
1528 print_unbuffered++;
1529 /* Could use unwind-protect, but why bother? */
1530 if (debug_print_length > 0)
1531 Vprint_length = make_int (debug_print_length);
1532 if (debug_print_level > 0)
1533 Vprint_level = make_int (debug_print_level);
1534
1535 Fbacktrace (Qexternal_debugging_output, Qt);
1536 stderr_out ("\n");
1537 fflush (stderr);
1538
1539 Vinhibit_quit = old_inhibit_quit;
1540 Vprint_level = old_print_level;
1541 Vprint_length = old_print_length;
1542 print_depth = old_print_depth;
1543 print_readably = old_print_readably;
1544 print_unbuffered--;
1545
1546 UNGCPRO;
1547 }
1548
1549 void
1550 debug_short_backtrace (int length)
1551 {
1552 int first = 1;
1553 struct backtrace *bt = backtrace_list;
1554 stderr_out (" [");
1555 fflush (stderr);
1556 while (length > 0 && bt)
1557 {
1558 if (!first)
1559 {
1560 stderr_out (", ");
1561 fflush (stderr);
1562 }
1563 if (COMPILED_FUNCTIONP (*bt->function))
1564 {
1565 #if defined(COMPILED_FUNCTION_ANNOTATION_HACK)
1566 Lisp_Object ann =
1567 compiled_function_annotation (XCOMPILED_FUNCTION (*bt->function));
1568 #else
1569 Lisp_Object ann = Qnil;
1570 #endif
1571 if (!NILP (ann))
1572 {
1573 stderr_out ("<compiled-function from ");
1574 fflush (stderr);
1575 debug_print_no_newline (ann);
1576 stderr_out (">");
1577 fflush (stderr);
1578 }
1579 else
1580 {
1581 stderr_out ("<compiled-function of unknown origin>");
1582 fflush (stderr);
1583 }
1584 }
1585 else
1586 debug_print_no_newline (*bt->function);
1587 first = 0;
1588 length--;
1589 bt = bt->next;
1590 }
1591 stderr_out ("]\n");
1592 fflush (stderr);
1593 }
1594
1595 #endif /* debugging kludge */
1596
1597
1598 void
1599 syms_of_print (void)
1600 {
1601 defsymbol (&Qstandard_output, "standard-output");
1602
1603 defsymbol (&Qprint_length, "print-length");
1604
1605 defsymbol (&Qprint_string_length, "print-string-length");
1606
1607 defsymbol (&Qdisplay_error, "display-error");
1608 defsymbol (&Qprint_message_label, "print-message-label");
1609
1610 DEFSUBR (Fprin1);
1611 DEFSUBR (Fprin1_to_string);
1612 DEFSUBR (Fprinc);
1613 DEFSUBR (Fprint);
1614 DEFSUBR (Ferror_message_string);
1615 DEFSUBR (Fdisplay_error);
1616 DEFSUBR (Fterpri);
1617 DEFSUBR (Fwrite_char);
1618 DEFSUBR (Falternate_debugging_output);
1619 DEFSUBR (Fexternal_debugging_output);
1620 DEFSUBR (Fopen_termscript);
1621 defsymbol (&Qexternal_debugging_output, "external-debugging-output");
1622 DEFSUBR (Fwith_output_to_temp_buffer);
1623 }
1624
1625 void
1626 reinit_vars_of_print (void)
1627 {
1628 alternate_do_pointer = 0;
1629 }
1630
1631 void
1632 vars_of_print (void)
1633 {
1634 reinit_vars_of_print ();
1635
1636 DEFVAR_LISP ("standard-output", &Vstandard_output /*
1637 Output stream `print' uses by default for outputting a character.
1638 This may be any function of one argument.
1639 It may also be a buffer (output is inserted before point)
1640 or a marker (output is inserted and the marker is advanced)
1641 or the symbol t (output appears in the minibuffer line).
1642 */ );
1643 Vstandard_output = Qt;
1644
1645 #ifdef LISP_FLOAT_TYPE
1646 DEFVAR_LISP ("float-output-format", &Vfloat_output_format /*
1647 The format descriptor string that lisp uses to print floats.
1648 This is a %-spec like those accepted by `printf' in C,
1649 but with some restrictions. It must start with the two characters `%.'.
1650 After that comes an integer precision specification,
1651 and then a letter which controls the format.
1652 The letters allowed are `e', `f' and `g'.
1653 Use `e' for exponential notation "DIG.DIGITSeEXPT"
1654 Use `f' for decimal point notation "DIGITS.DIGITS".
1655 Use `g' to choose the shorter of those two formats for the number at hand.
1656 The precision in any of these cases is the number of digits following
1657 the decimal point. With `f', a precision of 0 means to omit the
1658 decimal point. 0 is not allowed with `f' or `g'.
1659
1660 A value of nil means to use `%.16g'.
1661
1662 Regardless of the value of `float-output-format', a floating point number
1663 will never be printed in such a way that it is ambiguous with an integer;
1664 that is, a floating-point number will always be printed with a decimal
1665 point and/or an exponent, even if the digits following the decimal point
1666 are all zero. This is to preserve read-equivalence.
1667 */ );
1668 Vfloat_output_format = Qnil;
1669 #endif /* LISP_FLOAT_TYPE */
1670
1671 DEFVAR_LISP ("print-length", &Vprint_length /*
1672 Maximum length of list or vector to print before abbreviating.
1673 A value of nil means no limit.
1674 */ );
1675 Vprint_length = Qnil;
1676
1677 DEFVAR_LISP ("print-string-length", &Vprint_string_length /*
1678 Maximum length of string to print before abbreviating.
1679 A value of nil means no limit.
1680 */ );
1681 Vprint_string_length = Qnil;
1682
1683 DEFVAR_LISP ("print-level", &Vprint_level /*
1684 Maximum depth of list nesting to print before abbreviating.
1685 A value of nil means no limit.
1686 */ );
1687 Vprint_level = Qnil;
1688
1689 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines /*
1690 Non-nil means print newlines in strings as backslash-n.
1691 */ );
1692 print_escape_newlines = 0;
1693
1694 DEFVAR_BOOL ("print-readably", &print_readably /*
1695 If non-nil, then all objects will be printed in a readable form.
1696 If an object has no readable representation, then an error is signalled.
1697 When print-readably is true, compiled-function objects will be written in
1698 #[...] form instead of in #<compiled-function [...]> form, and two-element
1699 lists of the form (quote object) will be written as the equivalent 'object.
1700 Do not SET this variable; bind it instead.
1701 */ );
1702 print_readably = 0;
1703
1704 /* #### I think this should default to t. But we'd better wait
1705 until we see that it works out. */
1706 DEFVAR_LISP ("print-gensym", &Vprint_gensym /*
1707 If non-nil, then uninterned symbols will be printed specially.
1708 Uninterned symbols are those which are not present in `obarray', that is,
1709 those which were made with `make-symbol' or by calling `intern' with a
1710 second argument.
1711
1712 When print-gensym is true, such symbols will be preceded by "#:",
1713 which causes the reader to create a new symbol instead of interning
1714 and returning an existing one. Beware: the #: syntax creates a new
1715 symbol each time it is seen, so if you print an object which contains
1716 two pointers to the same uninterned symbol, `read' will not duplicate
1717 that structure.
1718
1719 If the value of `print-gensym' is a cons cell, then in addition
1720 refrain from clearing `print-gensym-alist' on entry to and exit from
1721 printing functions, so that the use of #...# and #...= can carry over
1722 for several separately printed objects.
1723 */ );
1724 Vprint_gensym = Qnil;
1725
1726 DEFVAR_LISP ("print-gensym-alist", &Vprint_gensym_alist /*
1727 Association list of elements (GENSYM . N) to guide use of #N# and #N=.
1728 In each element, GENSYM is an uninterned symbol that has been associated
1729 with #N= for the specified value of N.
1730 */ );
1731 Vprint_gensym_alist = Qnil;
1732
1733 DEFVAR_LISP ("print-message-label", &Vprint_message_label /*
1734 Label for minibuffer messages created with `print'. This should
1735 generally be bound with `let' rather than set. (See `display-message'.)
1736 */ );
1737 Vprint_message_label = Qprint;
1738 }