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