Mercurial > emacs
comparison src/print.c @ 329:52f53a69e5c4
Initial revision
author | Jim Blandy <jimb@redhat.com> |
---|---|
date | Sat, 13 Jul 1991 22:29:48 +0000 |
parents | |
children | 7c6f74ef31a3 |
comparison
equal
deleted
inserted
replaced
328:33b259eda54d | 329:52f53a69e5c4 |
---|---|
1 /* Lisp object printing and output streams. | |
2 Copyright (C) 1985, 1986, 1988 Free Software Foundation, Inc. | |
3 | |
4 This file is part of GNU Emacs. | |
5 | |
6 GNU Emacs is free software; you can redistribute it and/or modify | |
7 it under the terms of the GNU General Public License as published by | |
8 the Free Software Foundation; either version 1, or (at your option) | |
9 any later version. | |
10 | |
11 GNU Emacs is distributed in the hope that it will be useful, | |
12 but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 GNU General Public License for more details. | |
15 | |
16 You should have received a copy of the GNU General Public License | |
17 along with GNU Emacs; see the file COPYING. If not, write to | |
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ | |
19 | |
20 | |
21 #include "config.h" | |
22 #include <stdio.h> | |
23 #undef NULL | |
24 #include "lisp.h" | |
25 | |
26 #ifndef standalone | |
27 #include "buffer.h" | |
28 #include "screen.h" | |
29 #include "window.h" | |
30 #include "process.h" | |
31 #include "dispextern.h" | |
32 #include "termchar.h" | |
33 #endif /* not standalone */ | |
34 | |
35 Lisp_Object Vstandard_output, Qstandard_output; | |
36 | |
37 #ifdef LISP_FLOAT_TYPE | |
38 Lisp_Object Vfloat_output_format, Qfloat_output_format; | |
39 #endif /* LISP_FLOAT_TYPE */ | |
40 | |
41 /* Avoid actual stack overflow in print. */ | |
42 int print_depth; | |
43 | |
44 /* Maximum length of list to print in full; noninteger means | |
45 effectively infinity */ | |
46 | |
47 Lisp_Object Vprint_length; | |
48 | |
49 /* Maximum depth of list to print in full; noninteger means | |
50 effectively infinity. */ | |
51 | |
52 Lisp_Object Vprint_level; | |
53 | |
54 /* Nonzero means print newlines in strings as \n. */ | |
55 | |
56 int print_escape_newlines; | |
57 | |
58 Lisp_Object Qprint_escape_newlines; | |
59 | |
60 /* Nonzero means print newline before next minibuffer message. | |
61 Defined in xdisp.c */ | |
62 | |
63 extern int noninteractive_need_newline; | |
64 #ifdef MAX_PRINT_CHARS | |
65 static int print_chars; | |
66 static int max_print; | |
67 #endif /* MAX_PRINT_CHARS */ | |
68 | |
69 #if 0 | |
70 /* Convert between chars and GLYPHs */ | |
71 | |
72 int | |
73 glyphlen (glyphs) | |
74 register GLYPH *glyphs; | |
75 { | |
76 register int i = 0; | |
77 | |
78 while (glyphs[i]) | |
79 i++; | |
80 return i; | |
81 } | |
82 | |
83 void | |
84 str_to_glyph_cpy (str, glyphs) | |
85 char *str; | |
86 GLYPH *glyphs; | |
87 { | |
88 register GLYPH *gp = glyphs; | |
89 register char *cp = str; | |
90 | |
91 while (*cp) | |
92 *gp++ = *cp++; | |
93 } | |
94 | |
95 void | |
96 str_to_glyph_ncpy (str, glyphs, n) | |
97 char *str; | |
98 GLYPH *glyphs; | |
99 register int n; | |
100 { | |
101 register GLYPH *gp = glyphs; | |
102 register char *cp = str; | |
103 | |
104 while (n-- > 0) | |
105 *gp++ = *cp++; | |
106 } | |
107 | |
108 void | |
109 glyph_to_str_cpy (glyphs, str) | |
110 GLYPH *glyphs; | |
111 char *str; | |
112 { | |
113 register GLYPH *gp = glyphs; | |
114 register char *cp = str; | |
115 | |
116 while (*gp) | |
117 *str++ = *gp++ & 0377; | |
118 } | |
119 #endif | |
120 | |
121 /* Low level output routines for charaters and strings */ | |
122 | |
123 /* Lisp functions to do output using a stream | |
124 must have the stream in a variable called printcharfun | |
125 and must start with PRINTPREPARE and end with PRINTFINISH. | |
126 Use PRINTCHAR to output one character, | |
127 or call strout to output a block of characters. | |
128 Also, each one must have the declarations | |
129 struct buffer *old = current_buffer; | |
130 int old_point = -1, start_point; | |
131 Lisp_Object original; | |
132 */ | |
133 | |
134 #define PRINTPREPARE \ | |
135 original = printcharfun; \ | |
136 if (NULL (printcharfun)) printcharfun = Qt; \ | |
137 if (XTYPE (printcharfun) == Lisp_Buffer) \ | |
138 { if (XBUFFER (printcharfun) != current_buffer) Fset_buffer (printcharfun); \ | |
139 printcharfun = Qnil;}\ | |
140 if (XTYPE (printcharfun) == Lisp_Marker) \ | |
141 { if (XMARKER (original)->buffer != current_buffer) \ | |
142 set_buffer_internal (XMARKER (original)->buffer); \ | |
143 old_point = point; \ | |
144 SET_PT (marker_position (printcharfun)); \ | |
145 start_point = point; \ | |
146 printcharfun = Qnil;} | |
147 | |
148 #define PRINTFINISH \ | |
149 if (XTYPE (original) == Lisp_Marker) \ | |
150 Fset_marker (original, make_number (point), Qnil); \ | |
151 if (old_point >= 0) \ | |
152 SET_PT ((old_point >= start_point ? point - start_point : 0) + old_point); \ | |
153 if (old != current_buffer) \ | |
154 set_buffer_internal (old) | |
155 | |
156 #define PRINTCHAR(ch) printchar (ch, printcharfun) | |
157 | |
158 /* Index of first unused element of message_buf */ | |
159 static int printbufidx; | |
160 | |
161 static void | |
162 printchar (ch, fun) | |
163 unsigned char ch; | |
164 Lisp_Object fun; | |
165 { | |
166 Lisp_Object ch1; | |
167 | |
168 #ifdef MAX_PRINT_CHARS | |
169 if (max_print) | |
170 print_chars++; | |
171 #endif /* MAX_PRINT_CHARS */ | |
172 #ifndef standalone | |
173 if (EQ (fun, Qnil)) | |
174 { | |
175 QUIT; | |
176 insert (&ch, 1); | |
177 return; | |
178 } | |
179 | |
180 if (EQ (fun, Qt)) | |
181 { | |
182 if (noninteractive) | |
183 { | |
184 putchar (ch); | |
185 noninteractive_need_newline = 1; | |
186 return; | |
187 } | |
188 | |
189 if (echo_area_glyphs != SCREEN_MESSAGE_BUF (selected_screen) | |
190 || !message_buf_print) | |
191 { | |
192 echo_area_glyphs = SCREEN_MESSAGE_BUF (selected_screen); | |
193 printbufidx = 0; | |
194 message_buf_print = 1; | |
195 } | |
196 | |
197 if (printbufidx < SCREEN_WIDTH (selected_screen) - 1) | |
198 SCREEN_MESSAGE_BUF (selected_screen)[printbufidx++] = ch; | |
199 SCREEN_MESSAGE_BUF (selected_screen)[printbufidx] = 0; | |
200 | |
201 return; | |
202 } | |
203 #endif /* not standalone */ | |
204 | |
205 XFASTINT (ch1) = ch; | |
206 call1 (fun, ch1); | |
207 } | |
208 | |
209 static void | |
210 strout (ptr, size, printcharfun) | |
211 char *ptr; | |
212 int size; | |
213 Lisp_Object printcharfun; | |
214 { | |
215 int i = 0; | |
216 | |
217 if (EQ (printcharfun, Qnil)) | |
218 { | |
219 insert (ptr, size >= 0 ? size : strlen (ptr)); | |
220 #ifdef MAX_PRINT_CHARS | |
221 if (max_print) | |
222 print_chars += size >= 0 ? size : strlen(ptr); | |
223 #endif /* MAX_PRINT_CHARS */ | |
224 return; | |
225 } | |
226 if (EQ (printcharfun, Qt)) | |
227 { | |
228 i = size >= 0 ? size : strlen (ptr); | |
229 #ifdef MAX_PRINT_CHARS | |
230 if (max_print) | |
231 print_chars += i; | |
232 #endif /* MAX_PRINT_CHARS */ | |
233 | |
234 if (noninteractive) | |
235 { | |
236 fwrite (ptr, 1, i, stdout); | |
237 noninteractive_need_newline = 1; | |
238 return; | |
239 } | |
240 | |
241 if (echo_area_glyphs != SCREEN_MESSAGE_BUF (selected_screen) | |
242 || !message_buf_print) | |
243 { | |
244 echo_area_glyphs = SCREEN_MESSAGE_BUF (selected_screen); | |
245 printbufidx = 0; | |
246 message_buf_print = 1; | |
247 } | |
248 | |
249 if (i > SCREEN_WIDTH (selected_screen) - printbufidx - 1) | |
250 i = SCREEN_WIDTH (selected_screen) - printbufidx - 1; | |
251 bcopy (ptr, &SCREEN_MESSAGE_BUF (selected_screen) [printbufidx], i); | |
252 printbufidx += i; | |
253 SCREEN_MESSAGE_BUF (selected_screen) [printbufidx] = 0; | |
254 | |
255 return; | |
256 } | |
257 | |
258 if (size >= 0) | |
259 while (i < size) | |
260 PRINTCHAR (ptr[i++]); | |
261 else | |
262 while (ptr[i]) | |
263 PRINTCHAR (ptr[i++]); | |
264 } | |
265 | |
266 /* Print the contents of a string STRING using PRINTCHARFUN. | |
267 It isn't safe to use strout, because printing one char can relocate. */ | |
268 | |
269 print_string (string, printcharfun) | |
270 Lisp_Object string; | |
271 Lisp_Object printcharfun; | |
272 { | |
273 if (EQ (printcharfun, Qnil) || EQ (printcharfun, Qt)) | |
274 /* In predictable cases, strout is safe: output to buffer or screen. */ | |
275 strout (XSTRING (string)->data, XSTRING (string)->size, printcharfun); | |
276 else | |
277 { | |
278 /* Otherwise, fetch the string address for each character. */ | |
279 int i; | |
280 int size = XSTRING (string)->size; | |
281 struct gcpro gcpro1; | |
282 GCPRO1 (string); | |
283 for (i = 0; i < size; i++) | |
284 PRINTCHAR (XSTRING (string)->data[i]); | |
285 UNGCPRO; | |
286 } | |
287 } | |
288 | |
289 DEFUN ("write-char", Fwrite_char, Swrite_char, 1, 2, 0, | |
290 "Output character CHAR to stream STREAM.\n\ | |
291 STREAM defaults to the value of `standard-output' (which see).") | |
292 (ch, printcharfun) | |
293 Lisp_Object ch, printcharfun; | |
294 { | |
295 struct buffer *old = current_buffer; | |
296 int old_point = -1; | |
297 int start_point; | |
298 Lisp_Object original; | |
299 | |
300 if (NULL (printcharfun)) | |
301 printcharfun = Vstandard_output; | |
302 CHECK_NUMBER (ch, 0); | |
303 PRINTPREPARE; | |
304 PRINTCHAR (XINT (ch)); | |
305 PRINTFINISH; | |
306 return ch; | |
307 } | |
308 | |
309 /* Used from outside of print.c to print a block of SIZE chars at DATA | |
310 on the default output stream. | |
311 Do not use this on the contents of a Lisp string. */ | |
312 | |
313 write_string (data, size) | |
314 char *data; | |
315 int size; | |
316 { | |
317 struct buffer *old = current_buffer; | |
318 Lisp_Object printcharfun; | |
319 int old_point = -1; | |
320 int start_point; | |
321 Lisp_Object original; | |
322 | |
323 printcharfun = Vstandard_output; | |
324 | |
325 PRINTPREPARE; | |
326 strout (data, size, printcharfun); | |
327 PRINTFINISH; | |
328 } | |
329 | |
330 /* Used from outside of print.c to print a block of SIZE chars at DATA | |
331 on a specified stream PRINTCHARFUN. | |
332 Do not use this on the contents of a Lisp string. */ | |
333 | |
334 write_string_1 (data, size, printcharfun) | |
335 char *data; | |
336 int size; | |
337 Lisp_Object printcharfun; | |
338 { | |
339 struct buffer *old = current_buffer; | |
340 int old_point = -1; | |
341 int start_point; | |
342 Lisp_Object original; | |
343 | |
344 PRINTPREPARE; | |
345 strout (data, size, printcharfun); | |
346 PRINTFINISH; | |
347 } | |
348 | |
349 | |
350 #ifndef standalone | |
351 | |
352 void | |
353 temp_output_buffer_setup (bufname) | |
354 char *bufname; | |
355 { | |
356 register struct buffer *old = current_buffer; | |
357 register Lisp_Object buf; | |
358 | |
359 Fset_buffer (Fget_buffer_create (build_string (bufname))); | |
360 | |
361 current_buffer->read_only = Qnil; | |
362 Ferase_buffer (); | |
363 | |
364 XSET (buf, Lisp_Buffer, current_buffer); | |
365 specbind (Qstandard_output, buf); | |
366 | |
367 set_buffer_internal (old); | |
368 } | |
369 | |
370 Lisp_Object | |
371 internal_with_output_to_temp_buffer (bufname, function, args) | |
372 char *bufname; | |
373 Lisp_Object (*function) (); | |
374 Lisp_Object args; | |
375 { | |
376 int count = specpdl_ptr - specpdl; | |
377 Lisp_Object buf, val; | |
378 | |
379 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); | |
380 temp_output_buffer_setup (bufname); | |
381 buf = Vstandard_output; | |
382 | |
383 val = (*function) (args); | |
384 | |
385 temp_output_buffer_show (buf); | |
386 | |
387 return unbind_to (count, val); | |
388 } | |
389 | |
390 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer, Swith_output_to_temp_buffer, | |
391 1, UNEVALLED, 0, | |
392 "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.\n\ | |
393 The buffer is cleared out initially, and marked as unmodified when done.\n\ | |
394 All output done by BODY is inserted in that buffer by default.\n\ | |
395 The buffer is displayed in another window, but not selected.\n\ | |
396 The value of the last form in BODY is returned.\n\ | |
397 If BODY does not finish normally, the buffer BUFNAME is not displayed.\n\n\ | |
398 If variable `temp-buffer-show-hook' is non-nil, call it at the end\n\ | |
399 to get the buffer displayed. It gets one argument, the buffer to display.") | |
400 (args) | |
401 Lisp_Object args; | |
402 { | |
403 struct gcpro gcpro1; | |
404 Lisp_Object name; | |
405 int count = specpdl_ptr - specpdl; | |
406 Lisp_Object buf, val; | |
407 | |
408 GCPRO1(args); | |
409 name = Feval (Fcar (args)); | |
410 UNGCPRO; | |
411 | |
412 CHECK_STRING (name, 0); | |
413 temp_output_buffer_setup (XSTRING (name)->data); | |
414 buf = Vstandard_output; | |
415 | |
416 val = Fprogn (Fcdr (args)); | |
417 | |
418 temp_output_buffer_show (buf); | |
419 | |
420 return unbind_to (count, val); | |
421 } | |
422 #endif /* not standalone */ | |
423 | |
424 static void print (); | |
425 | |
426 DEFUN ("terpri", Fterpri, Sterpri, 0, 1, 0, | |
427 "Output a newline to STREAM.\n\ | |
428 If STREAM is omitted or nil, the value of `standard-output' is used.") | |
429 (printcharfun) | |
430 Lisp_Object printcharfun; | |
431 { | |
432 struct buffer *old = current_buffer; | |
433 int old_point = -1; | |
434 int start_point; | |
435 Lisp_Object original; | |
436 | |
437 if (NULL (printcharfun)) | |
438 printcharfun = Vstandard_output; | |
439 PRINTPREPARE; | |
440 PRINTCHAR ('\n'); | |
441 PRINTFINISH; | |
442 return Qt; | |
443 } | |
444 | |
445 DEFUN ("prin1", Fprin1, Sprin1, 1, 2, 0, | |
446 "Output the printed representation of OBJECT, any Lisp object.\n\ | |
447 Quoting characters are printed when needed to make output that `read'\n\ | |
448 can handle, whenever this is possible.\n\ | |
449 Output stream is STREAM, or value of `standard-output' (which see).") | |
450 (obj, printcharfun) | |
451 Lisp_Object obj, printcharfun; | |
452 { | |
453 struct buffer *old = current_buffer; | |
454 int old_point = -1; | |
455 int start_point; | |
456 Lisp_Object original; | |
457 | |
458 #ifdef MAX_PRINT_CHARS | |
459 max_print = 0; | |
460 #endif /* MAX_PRINT_CHARS */ | |
461 if (NULL (printcharfun)) | |
462 printcharfun = Vstandard_output; | |
463 PRINTPREPARE; | |
464 print_depth = 0; | |
465 print (obj, printcharfun, 1); | |
466 PRINTFINISH; | |
467 return obj; | |
468 } | |
469 | |
470 /* a buffer which is used to hold output being built by prin1-to-string */ | |
471 Lisp_Object Vprin1_to_string_buffer; | |
472 | |
473 DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 2, 0, | |
474 "Return a string containing the printed representation of OBJECT,\n\ | |
475 any Lisp object. Quoting characters are used when needed to make output\n\ | |
476 that `read' can handle, whenever this is possible, unless the optional\n\ | |
477 second argument NOESCAPE is non-nil.") | |
478 (obj, noescape) | |
479 Lisp_Object obj, noescape; | |
480 { | |
481 struct buffer *old = current_buffer; | |
482 int old_point = -1; | |
483 int start_point; | |
484 Lisp_Object original, printcharfun; | |
485 struct gcpro gcpro1; | |
486 | |
487 printcharfun = Vprin1_to_string_buffer; | |
488 PRINTPREPARE; | |
489 print_depth = 0; | |
490 print (obj, printcharfun, NULL (noescape)); | |
491 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */ | |
492 PRINTFINISH; | |
493 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer)); | |
494 obj = Fbuffer_string (); | |
495 | |
496 GCPRO1 (obj); | |
497 Ferase_buffer (); | |
498 set_buffer_internal (old); | |
499 UNGCPRO; | |
500 | |
501 return obj; | |
502 } | |
503 | |
504 DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0, | |
505 "Output the printed representation of OBJECT, any Lisp object.\n\ | |
506 No quoting characters are used; no delimiters are printed around\n\ | |
507 the contents of strings.\n\ | |
508 Output stream is STREAM, or value of standard-output (which see).") | |
509 (obj, printcharfun) | |
510 Lisp_Object obj, printcharfun; | |
511 { | |
512 struct buffer *old = current_buffer; | |
513 int old_point = -1; | |
514 int start_point; | |
515 Lisp_Object original; | |
516 | |
517 if (NULL (printcharfun)) | |
518 printcharfun = Vstandard_output; | |
519 PRINTPREPARE; | |
520 print_depth = 0; | |
521 print (obj, printcharfun, 0); | |
522 PRINTFINISH; | |
523 return obj; | |
524 } | |
525 | |
526 DEFUN ("print", Fprint, Sprint, 1, 2, 0, | |
527 "Output the printed representation of OBJECT, with newlines around it.\n\ | |
528 Quoting characters are printed when needed to make output that `read'\n\ | |
529 can handle, whenever this is possible.\n\ | |
530 Output stream is STREAM, or value of `standard-output' (which see).") | |
531 (obj, printcharfun) | |
532 Lisp_Object obj, printcharfun; | |
533 { | |
534 struct buffer *old = current_buffer; | |
535 int old_point = -1; | |
536 int start_point; | |
537 Lisp_Object original; | |
538 struct gcpro gcpro1; | |
539 | |
540 #ifdef MAX_PRINT_CHARS | |
541 print_chars = 0; | |
542 max_print = MAX_PRINT_CHARS; | |
543 #endif /* MAX_PRINT_CHARS */ | |
544 if (NULL (printcharfun)) | |
545 printcharfun = Vstandard_output; | |
546 GCPRO1 (obj); | |
547 PRINTPREPARE; | |
548 print_depth = 0; | |
549 PRINTCHAR ('\n'); | |
550 print (obj, printcharfun, 1); | |
551 PRINTCHAR ('\n'); | |
552 PRINTFINISH; | |
553 #ifdef MAX_PRINT_CHARS | |
554 max_print = 0; | |
555 print_chars = 0; | |
556 #endif /* MAX_PRINT_CHARS */ | |
557 UNGCPRO; | |
558 return obj; | |
559 } | |
560 | |
561 /* The subroutine object for external-debugging-output is kept here | |
562 for the convenience of the debugger. */ | |
563 Lisp_Object Qexternal_debugging_output; | |
564 | |
565 DEFUN ("external-debugging-output", | |
566 Fexternal_debugging_output, Sexternal_debugging_output, | |
567 1, 1, 0, "Write CHARACTER to stderr.\n\ | |
568 You can call print while debugging emacs, and pass it this function\n\ | |
569 to make it write to the debugging output.\n") | |
570 (Lisp_Object character) | |
571 { | |
572 CHECK_NUMBER (character, 0); | |
573 putc (XINT (character), stderr); | |
574 | |
575 return character; | |
576 } | |
577 | |
578 #ifdef LISP_FLOAT_TYPE | |
579 | |
580 void | |
581 float_to_string (buf, data) | |
582 char *buf; | |
583 /* | |
584 * This buffer should be at least as large as the max string size of the | |
585 * largest float, printed in the biggest notation. This is undoubtably | |
586 * 20d float_output_format, with the negative of the C-constant "HUGE" | |
587 * from <math.h>. | |
588 * | |
589 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes. | |
590 * | |
591 * I assume that IEEE-754 format numbers can take 329 bytes for the worst | |
592 * case of -1e307 in 20d float_output_format. What is one to do (short of | |
593 * re-writing _doprnt to be more sane)? | |
594 * -wsr | |
595 */ | |
596 double data; | |
597 { | |
598 register unsigned char *cp, c; | |
599 register int width; | |
600 | |
601 if (NULL (Vfloat_output_format) | |
602 || XTYPE (Vfloat_output_format) != Lisp_String) | |
603 lose: | |
604 sprintf (buf, "%.20g", data); | |
605 else /* oink oink */ | |
606 { | |
607 /* Check that the spec we have is fully valid. | |
608 This means not only valid for printf, | |
609 but meant for floats, and reasonable. */ | |
610 cp = XSTRING (Vfloat_output_format)->data; | |
611 | |
612 if (cp[0] != '%') | |
613 goto lose; | |
614 if (cp[1] != '.') | |
615 goto lose; | |
616 | |
617 cp += 2; | |
618 for (width = 0; | |
619 ((c = *cp) >= '0' && c <= '9'); | |
620 cp++) | |
621 { | |
622 width *= 10; | |
623 width += c - '0'; | |
624 } | |
625 | |
626 if (*cp != 'e' && *cp != 'f' && *cp != 'g') | |
627 goto lose; | |
628 | |
629 if (width < (*cp != 'e') || width > DBL_DIG) | |
630 goto lose; | |
631 | |
632 if (cp[1] != 0) | |
633 goto lose; | |
634 | |
635 sprintf (buf, XSTRING (Vfloat_output_format)->data, data); | |
636 } | |
637 } | |
638 #endif /* LISP_FLOAT_TYPE */ | |
639 | |
640 static void | |
641 print (obj, printcharfun, escapeflag) | |
642 #ifndef RTPC_REGISTER_BUG | |
643 register Lisp_Object obj; | |
644 #else | |
645 Lisp_Object obj; | |
646 #endif | |
647 register Lisp_Object printcharfun; | |
648 int escapeflag; | |
649 { | |
650 char buf[30]; | |
651 | |
652 QUIT; | |
653 | |
654 print_depth++; | |
655 | |
656 if (print_depth > 200) | |
657 error ("Apparently circular structure being printed"); | |
658 #ifdef MAX_PRINT_CHARS | |
659 if (max_print && print_chars > max_print) | |
660 { | |
661 PRINTCHAR ('\n'); | |
662 print_chars = 0; | |
663 } | |
664 #endif /* MAX_PRINT_CHARS */ | |
665 | |
666 #ifdef SWITCH_ENUM_BUG | |
667 switch ((int) XTYPE (obj)) | |
668 #else | |
669 switch (XTYPE (obj)) | |
670 #endif | |
671 { | |
672 default: | |
673 /* We're in trouble if this happens! | |
674 Probably should just abort () */ | |
675 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, printcharfun); | |
676 sprintf (buf, "(#o%3o)", (int) XTYPE (obj)); | |
677 strout (buf, -1, printcharfun); | |
678 strout (" Save your buffers immediately and please report this bug>", | |
679 -1, printcharfun); | |
680 break; | |
681 | |
682 #ifdef LISP_FLOAT_TYPE | |
683 case Lisp_Float: | |
684 { | |
685 char pigbuf[350]; /* see comments in float_to_string */ | |
686 | |
687 float_to_string (pigbuf, XFLOAT(obj)->data); | |
688 strout (pigbuf, -1, printcharfun); | |
689 } | |
690 break; | |
691 #endif /* LISP_FLOAT_TYPE */ | |
692 | |
693 case Lisp_Int: | |
694 sprintf (buf, "%d", XINT (obj)); | |
695 strout (buf, -1, printcharfun); | |
696 break; | |
697 | |
698 case Lisp_String: | |
699 if (!escapeflag) | |
700 print_string (obj, printcharfun); | |
701 else | |
702 { | |
703 register int i; | |
704 register unsigned char c; | |
705 Lisp_Object obj1; | |
706 struct gcpro gcpro1; | |
707 | |
708 /* You can't gcpro register variables, so copy obj to a | |
709 non-register variable so we can gcpro it without | |
710 making it non-register. */ | |
711 obj1 = obj; | |
712 GCPRO1 (obj1); | |
713 | |
714 PRINTCHAR ('\"'); | |
715 for (i = 0; i < XSTRING (obj)->size; i++) | |
716 { | |
717 QUIT; | |
718 c = XSTRING (obj)->data[i]; | |
719 if (c == '\n' && print_escape_newlines) | |
720 { | |
721 PRINTCHAR ('\\'); | |
722 PRINTCHAR ('n'); | |
723 } | |
724 else | |
725 { | |
726 if (c == '\"' || c == '\\') | |
727 PRINTCHAR ('\\'); | |
728 PRINTCHAR (c); | |
729 } | |
730 } | |
731 PRINTCHAR ('\"'); | |
732 UNGCPRO; | |
733 } | |
734 break; | |
735 | |
736 case Lisp_Symbol: | |
737 { | |
738 register int confusing; | |
739 register unsigned char *p = XSYMBOL (obj)->name->data; | |
740 register unsigned char *end = p + XSYMBOL (obj)->name->size; | |
741 register unsigned char c; | |
742 | |
743 if (p != end && (*p == '-' || *p == '+')) p++; | |
744 if (p == end) | |
745 confusing = 0; | |
746 else | |
747 { | |
748 while (p != end && *p >= '0' && *p <= '9') | |
749 p++; | |
750 confusing = (end == p); | |
751 } | |
752 | |
753 p = XSYMBOL (obj)->name->data; | |
754 while (p != end) | |
755 { | |
756 QUIT; | |
757 c = *p++; | |
758 if (escapeflag) | |
759 { | |
760 if (c == '\"' || c == '\\' || c == '\'' || c == ';' || c == '#' || | |
761 c == '(' || c == ')' || c == ',' || c =='.' || c == '`' || | |
762 c == '[' || c == ']' || c == '?' || c <= 040 || confusing) | |
763 PRINTCHAR ('\\'), confusing = 0; | |
764 } | |
765 PRINTCHAR (c); | |
766 } | |
767 } | |
768 break; | |
769 | |
770 case Lisp_Cons: | |
771 /* If deeper than spec'd depth, print placeholder. */ | |
772 if (XTYPE (Vprint_level) == Lisp_Int | |
773 && print_depth > XINT (Vprint_level)) | |
774 { | |
775 strout ("...", -1, printcharfun); | |
776 break; | |
777 } | |
778 | |
779 PRINTCHAR ('('); | |
780 { | |
781 register int i = 0; | |
782 register int max = 0; | |
783 | |
784 if (XTYPE (Vprint_length) == Lisp_Int) | |
785 max = XINT (Vprint_length); | |
786 while (CONSP (obj)) | |
787 { | |
788 if (i++) | |
789 PRINTCHAR (' '); | |
790 if (max && i > max) | |
791 { | |
792 strout ("...", 3, printcharfun); | |
793 break; | |
794 } | |
795 print (Fcar (obj), printcharfun, escapeflag); | |
796 obj = Fcdr (obj); | |
797 } | |
798 } | |
799 if (!NULL (obj) && !CONSP (obj)) | |
800 { | |
801 strout (" . ", 3, printcharfun); | |
802 print (obj, printcharfun, escapeflag); | |
803 } | |
804 PRINTCHAR (')'); | |
805 break; | |
806 | |
807 case Lisp_Compiled: | |
808 strout ("#<byte-code ", -1, printcharfun); | |
809 case Lisp_Vector: | |
810 PRINTCHAR ('['); | |
811 { | |
812 register int i; | |
813 register Lisp_Object tem; | |
814 for (i = 0; i < XVECTOR (obj)->size; i++) | |
815 { | |
816 if (i) PRINTCHAR (' '); | |
817 tem = XVECTOR (obj)->contents[i]; | |
818 print (tem, printcharfun, escapeflag); | |
819 } | |
820 } | |
821 PRINTCHAR (']'); | |
822 if (XTYPE (obj) == Lisp_Compiled) | |
823 PRINTCHAR ('>'); | |
824 break; | |
825 | |
826 #ifndef standalone | |
827 case Lisp_Buffer: | |
828 if (NULL (XBUFFER (obj)->name)) | |
829 strout ("#<killed buffer>", -1, printcharfun); | |
830 else if (escapeflag) | |
831 { | |
832 strout ("#<buffer ", -1, printcharfun); | |
833 print_string (XBUFFER (obj)->name, printcharfun); | |
834 PRINTCHAR ('>'); | |
835 } | |
836 else | |
837 print_string (XBUFFER (obj)->name, printcharfun); | |
838 break; | |
839 | |
840 case Lisp_Process: | |
841 if (escapeflag) | |
842 { | |
843 strout ("#<process ", -1, printcharfun); | |
844 print_string (XPROCESS (obj)->name, printcharfun); | |
845 PRINTCHAR ('>'); | |
846 } | |
847 else | |
848 print_string (XPROCESS (obj)->name, printcharfun); | |
849 break; | |
850 | |
851 case Lisp_Window: | |
852 strout ("#<window ", -1, printcharfun); | |
853 sprintf (buf, "%d", XFASTINT (XWINDOW (obj)->sequence_number)); | |
854 strout (buf, -1, printcharfun); | |
855 if (!NULL (XWINDOW (obj)->buffer)) | |
856 { | |
857 strout (" on ", -1, printcharfun); | |
858 print_string (XBUFFER (XWINDOW (obj)->buffer)->name, printcharfun); | |
859 } | |
860 PRINTCHAR ('>'); | |
861 break; | |
862 | |
863 case Lisp_Window_Configuration: | |
864 strout ("#<window-configuration>", -1, printcharfun); | |
865 break; | |
866 | |
867 #ifdef MULTI_SCREEN | |
868 case Lisp_Screen: | |
869 strout ("#<screen ", -1, printcharfun); | |
870 print_string (XSCREEN (obj)->name, printcharfun); | |
871 sprintf (buf, " 0x%x", XFASTINT (XSCREEN (obj))); | |
872 strout (buf, -1, printcharfun); | |
873 strout (">", -1, printcharfun); | |
874 break; | |
875 #endif /* MULTI_SCREEN */ | |
876 | |
877 case Lisp_Marker: | |
878 strout ("#<marker ", -1, printcharfun); | |
879 if (!(XMARKER (obj)->buffer)) | |
880 strout ("in no buffer", -1, printcharfun); | |
881 else | |
882 { | |
883 sprintf (buf, "at %d", marker_position (obj)); | |
884 strout (buf, -1, printcharfun); | |
885 strout (" in ", -1, printcharfun); | |
886 print_string (XMARKER (obj)->buffer->name, printcharfun); | |
887 } | |
888 PRINTCHAR ('>'); | |
889 break; | |
890 #endif /* standalone */ | |
891 | |
892 case Lisp_Subr: | |
893 strout ("#<subr ", -1, printcharfun); | |
894 strout (XSUBR (obj)->symbol_name, -1, printcharfun); | |
895 PRINTCHAR ('>'); | |
896 break; | |
897 } | |
898 | |
899 print_depth--; | |
900 } | |
901 | |
902 void | |
903 syms_of_print () | |
904 { | |
905 staticpro (&Qprint_escape_newlines); | |
906 Qprint_escape_newlines = intern ("print-escape-newlines"); | |
907 | |
908 DEFVAR_LISP ("standard-output", &Vstandard_output, | |
909 "Output stream `print' uses by default for outputting a character.\n\ | |
910 This may be any function of one argument.\n\ | |
911 It may also be a buffer (output is inserted before point)\n\ | |
912 or a marker (output is inserted and the marker is advanced)\n\ | |
913 or the symbol t (output appears in the minibuffer line)."); | |
914 Vstandard_output = Qt; | |
915 Qstandard_output = intern ("standard-output"); | |
916 staticpro (&Qstandard_output); | |
917 | |
918 #ifdef LISP_FLOAT_TYPE | |
919 DEFVAR_LISP ("float-output-format", &Vfloat_output_format, | |
920 "The format descriptor string that lisp uses to print floats.\n\ | |
921 This is a %-spec like those accepted by `printf' in C,\n\ | |
922 but with some restrictions. It must start with the two characters `%.'.\n\ | |
923 After that comes an integer precision specification,\n\ | |
924 and then a letter which controls the format.\n\ | |
925 The letters allowed are `e', `f' and `g'.\n\ | |
926 Use `e' for exponential notation \"DIG.DIGITSeEXPT\"\n\ | |
927 Use `f' for decimal point notation \"DIGITS.DIGITS\".\n\ | |
928 Use `g' to choose the shorter of those two formats for the number at hand.\n\ | |
929 The precision in any of these cases is the number of digits following\n\ | |
930 the decimal point. With `f', a precision of 0 means to omit the\n\ | |
931 decimal point. 0 is not allowed with `f' or `g'.\n\n\ | |
932 A value of nil means to use `%.20g'."); | |
933 Vfloat_output_format = Qnil; | |
934 Qfloat_output_format = intern ("float-output-format"); | |
935 staticpro (&Qfloat_output_format); | |
936 #endif /* LISP_FLOAT_TYPE */ | |
937 | |
938 DEFVAR_LISP ("print-length", &Vprint_length, | |
939 "Maximum length of list to print before abbreviating.\ | |
940 A value of nil means no limit."); | |
941 Vprint_length = Qnil; | |
942 | |
943 DEFVAR_LISP ("print-level", &Vprint_level, | |
944 "Maximum depth of list nesting to print before abbreviating.\ | |
945 A value of nil means no limit."); | |
946 Vprint_level = Qnil; | |
947 | |
948 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines, | |
949 "Non-nil means print newlines in strings as backslash-n."); | |
950 print_escape_newlines = 0; | |
951 | |
952 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */ | |
953 staticpro (&Vprin1_to_string_buffer); | |
954 | |
955 defsubr (&Sprin1); | |
956 defsubr (&Sprin1_to_string); | |
957 defsubr (&Sprinc); | |
958 defsubr (&Sprint); | |
959 defsubr (&Sterpri); | |
960 defsubr (&Swrite_char); | |
961 defsubr (&Sexternal_debugging_output); | |
962 | |
963 Qexternal_debugging_output = intern ("external-debugging-output"); | |
964 staticpro (&Qexternal_debugging_output); | |
965 | |
966 #ifndef standalone | |
967 defsubr (&Swith_output_to_temp_buffer); | |
968 #endif /* not standalone */ | |
969 } |