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