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