![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to print.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Apple XNU] / GNUtools / emacs / src|
Return to print.c CVS log | Up to [Apple XNU] / GNUtools / emacs / src |
1.1 root 1: /* Lisp object printing and output streams.
2: Copyright (C) 1985, 1986, 1990 Free Software Foundation, Inc.
3:
4: This file is part of GNU Emacs.
5:
6: GNU Emacs is free software; you can redistribute it and/or modify
7: it under the terms of the GNU General Public License as published by
8: the Free Software Foundation; either version 1, or (at your option)
9: any later version.
10:
11: GNU Emacs is distributed in the hope that it will be useful,
12: but WITHOUT ANY WARRANTY; without even the implied warranty of
13: MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14: GNU General Public License for more details.
15:
16: You should have received a copy of the GNU General Public License
17: along with GNU Emacs; see the file COPYING. If not, write to
18: the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
19:
20:
21: #include "config.h"
22: #include <stdio.h>
23: #undef NULL
24: #include "lisp.h"
25:
26: #ifndef standalone
27: #include "buffer.h"
28: #include "window.h"
29: #include "process.h"
30: #include "dispextern.h"
31: #include "termchar.h"
32: #endif /* not standalone */
33:
34: Lisp_Object Vstandard_output, Qstandard_output;
35:
36: /* Avoid actual stack overflow in print. */
37: int print_depth;
38:
39: /* Maximum length of list to print in full; noninteger means
40: effectively infinity */
41:
42: Lisp_Object Vprint_length;
43:
44: /* Nonzero means print newlines in strings as \n. */
45:
46: int print_escape_newlines;
47:
48: /* Nonzero means print newline before next minibuffer message.
49: Defined in xdisp.c */
50:
51: extern int noninteractive_need_newline;
52: #ifdef MAX_PRINT_CHARS
53: static int print_chars;
54: static int max_print;
55: #endif /* MAX_PRINT_CHARS */
56:
57: /* Low level output routines for charaters and strings */
58:
59: /* Lisp functions to do output using a stream
60: must have the stream in a variable called printcharfun
61: and must start with PRINTPREPARE and end with PRINTFINISH.
62: Use PRINTCHAR to output one character,
63: or call strout to output a block of characters.
64: Also, each one must have the declarations
65: struct buffer *old = current_buffer;
66: int old_point = -1, start_point;
67: Lisp_Object original;
68: */
69:
70: #define PRINTPREPARE \
71: original = printcharfun; \
72: if (NULL (printcharfun)) printcharfun = Qt; \
73: if (XTYPE (printcharfun) == Lisp_Buffer) \
74: { if (XBUFFER (printcharfun) != current_buffer) Fset_buffer (printcharfun); \
75: printcharfun = Qnil;}\
76: if (XTYPE (printcharfun) == Lisp_Marker) \
77: { if (XMARKER (original)->buffer != current_buffer) \
78: set_buffer_internal (XMARKER (original)->buffer); \
79: old_point = point; \
80: SET_PT (marker_position (printcharfun)); \
81: start_point = point; \
82: printcharfun = Qnil;}
83:
84: #define PRINTFINISH \
85: if (XTYPE (original) == Lisp_Marker) \
86: Fset_marker (original, make_number (point), Qnil); \
87: if (old_point >= 0) \
88: SET_PT ((old_point >= start_point ? point - start_point : 0) + old_point); \
89: if (old != current_buffer) \
90: set_buffer_internal (old)
91:
92: #define PRINTCHAR(ch) printchar (ch, printcharfun)
93:
94: /* Index of first unused element of message_buf. */
95: static int printbufidx;
96:
97: static void
98: printchar (ch, fun)
99: unsigned char ch;
100: Lisp_Object fun;
101: {
102: Lisp_Object ch1;
103:
104: #ifdef MAX_PRINT_CHARS
105: if (max_print)
106: print_chars++;
107: #endif /* MAX_PRINT_CHARS */
108: #ifndef standalone
109: if (EQ (fun, Qnil))
110: {
111: QUIT;
112: insert (&ch, 1);
113: return;
114: }
115: if (EQ (fun, Qt))
116: {
117: if (noninteractive)
118: {
119: putchar (ch);
120: noninteractive_need_newline = 1;
121: return;
122: }
123: if (echo_area_contents != message_buf || !message_buf_print)
124: {
125: echo_area_contents = message_buf;
126: printbufidx = 0;
127: message_buf_print = 1;
128: }
129: if (printbufidx < screen_width)
130: message_buf[printbufidx++] = ch;
131: message_buf[printbufidx] = 0;
132: return;
133: }
134: #endif /* not standalone */
135:
136: XFASTINT (ch1) = ch;
137: call1 (fun, ch1);
138: }
139:
140: static void
141: strout (ptr, size, printcharfun)
142: char *ptr;
143: int size;
144: Lisp_Object printcharfun;
145: {
146: int i = 0;
147:
148: if (EQ (printcharfun, Qnil))
149: {
150: insert (ptr, size >= 0 ? size : strlen (ptr));
151: #ifdef MAX_PRINT_CHARS
152: if (max_print)
153: print_chars += size >= 0 ? size : strlen(ptr);
154: #endif /* MAX_PRINT_CHARS */
155: return;
156: }
157: if (EQ (printcharfun, Qt))
158: {
159: i = size >= 0 ? size : strlen (ptr);
160: #ifdef MAX_PRINT_CHARS
161: if (max_print)
162: print_chars += i;
163: #endif /* MAX_PRINT_CHARS */
164: if (noninteractive)
165: {
166: fwrite (ptr, 1, i, stdout);
167: noninteractive_need_newline = 1;
168: return;
169: }
170: if (echo_area_contents != message_buf || !message_buf_print)
171: {
172: echo_area_contents = message_buf;
173: printbufidx = 0;
174: message_buf_print = 1;
175: }
176: if (i > screen_width - printbufidx)
177: i = screen_width - printbufidx;
178: bcopy (ptr, &message_buf[printbufidx], i);
179: printbufidx += i;
180: message_buf[printbufidx] = 0;
181: return;
182: }
183: if (size >= 0)
184: while (i < size)
185: PRINTCHAR (ptr[i++]);
186: else
187: while (ptr[i])
188: PRINTCHAR (ptr[i++]);
189: }
190:
191: DEFUN ("write-char", Fwrite_char, Swrite_char, 1, 2, 0,
192: "Output character CHAR to stream STREAM.\n\
193: STREAM defaults to the value of `standard-output' (which see).")
194: (ch, printcharfun)
195: Lisp_Object ch, printcharfun;
196: {
197: struct buffer *old = current_buffer;
198: int old_point = -1;
199: int start_point;
200: Lisp_Object original;
201:
202: if (NULL (printcharfun))
203: printcharfun = Vstandard_output;
204: CHECK_NUMBER (ch, 0);
205: PRINTPREPARE;
206: PRINTCHAR (XINT (ch));
207: PRINTFINISH;
208: return ch;
209: }
210:
211: write_string (data, size)
212: char *data;
213: int size;
214: {
215: struct buffer *old = current_buffer;
216: Lisp_Object printcharfun;
217: int old_point = -1;
218: int start_point;
219: Lisp_Object original;
220:
221: printcharfun = Vstandard_output;
222:
223: PRINTPREPARE;
224: strout (data, size, printcharfun);
225: PRINTFINISH;
226: }
227:
228: write_string_1 (data, size, printcharfun)
229: char *data;
230: int size;
231: Lisp_Object printcharfun;
232: {
233: struct buffer *old = current_buffer;
234: int old_point = -1;
235: int start_point;
236: Lisp_Object original;
237:
238: PRINTPREPARE;
239: strout (data, size, printcharfun);
240: PRINTFINISH;
241: }
242:
243:
244: #ifndef standalone
245:
246: temp_output_buffer_setup (bufname)
247: char *bufname;
248: {
249: register struct buffer *old = current_buffer;
250: register Lisp_Object buf;
251:
252: Fset_buffer (Fget_buffer_create (build_string (bufname)));
253:
254: current_buffer->read_only = Qnil;
255: Ferase_buffer ();
256:
257: XSET (buf, Lisp_Buffer, current_buffer);
258: specbind (Qstandard_output, buf);
259:
260: set_buffer_internal (old);
261: }
262:
263: Lisp_Object
264: internal_with_output_to_temp_buffer (bufname, function, args)
265: char *bufname;
266: Lisp_Object (*function) ();
267: Lisp_Object args;
268: {
269: int count = specpdl_ptr - specpdl;
270: Lisp_Object buf, val;
271:
272: record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
273: temp_output_buffer_setup (bufname);
274: buf = Vstandard_output;
275:
276: val = (*function) (args);
277:
278: temp_output_buffer_show (buf);
279:
280: unbind_to (count);
281: return val;
282: }
283:
284: DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer, Swith_output_to_temp_buffer,
285: 1, UNEVALLED, 0,
286: "Binding `standard-output' to buffer named BUFNAME, execute BODY then display that buffer.\n\
287: The buffer is cleared out initially, and marked as unmodified when done.\n\
288: All output done by BODY is inserted in that buffer by default.\n\
289: It is displayed in another window, but not selected.\n\
290: The value of the last form in BODY is returned.\n\
291: If variable `temp-buffer-show-hook' is non-nil, call it at the end\n\
292: to get the buffer displayed. It gets one argument, the buffer to display.")
293: (args)
294: Lisp_Object args;
295: {
296: struct gcpro gcpro1;
297: Lisp_Object name;
298: int count = specpdl_ptr - specpdl;
299: Lisp_Object buf, val;
300:
301: GCPRO1(args);
302: name = Feval (Fcar (args));
303: UNGCPRO;
304:
305: CHECK_STRING (name, 0);
306: temp_output_buffer_setup (XSTRING (name)->data);
307: buf = Vstandard_output;
308:
309: val = Fprogn (Fcdr (args));
310:
311: temp_output_buffer_show (buf);
312:
313: unbind_to (count);
314: return val;
315: }
316: #endif /* not standalone */
317:
318: static void print ();
319:
320: DEFUN ("terpri", Fterpri, Sterpri, 0, 1, 0,
321: "Output a newline to STREAM (or value of standard-output).")
322: (printcharfun)
323: Lisp_Object printcharfun;
324: {
325: struct buffer *old = current_buffer;
326: int old_point = -1;
327: int start_point;
328: Lisp_Object original;
329:
330: if (NULL (printcharfun))
331: printcharfun = Vstandard_output;
332: PRINTPREPARE;
333: PRINTCHAR ('\n');
334: PRINTFINISH;
335: return Qt;
336: }
337:
338: DEFUN ("prin1", Fprin1, Sprin1, 1, 2, 0,
339: "Output the printed representation of OBJECT, any Lisp object.\n\
340: Quoting characters are printed when needed to make output that `read'\n\
341: can handle, whenever this is possible.\n\
342: Output stream is STREAM, or value of `standard-output' (which see).")
343: (obj, printcharfun)
344: Lisp_Object obj, printcharfun;
345: {
346: struct buffer *old = current_buffer;
347: int old_point = -1;
348: int start_point;
349: Lisp_Object original;
350:
351: #ifdef MAX_PRINT_CHARS
352: max_print = 0;
353: #endif /* MAX_PRINT_CHARS */
354: if (NULL (printcharfun))
355: printcharfun = Vstandard_output;
356: PRINTPREPARE;
357: print_depth = 0;
358: print (obj, printcharfun, 1);
359: PRINTFINISH;
360: return obj;
361: }
362:
363: /* a buffer which is used to hold output being built by prin1-to-string */
364: Lisp_Object Vprin1_to_string_buffer;
365:
366: DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 1, 0,
367: "Return a string containing the printed representation of OBJECT,\n\
368: any Lisp object. Quoting characters are used when needed to make output\n\
369: that `read' can handle, whenever this is possible.")
370: (obj)
371: Lisp_Object obj;
372: {
373: struct buffer *old = current_buffer;
374: int old_point = -1;
375: int start_point;
376: Lisp_Object original, printcharfun;
377: struct gcpro gcpro1;
378:
379: printcharfun = Vprin1_to_string_buffer;
380: PRINTPREPARE;
381: print_depth = 0;
382: print (obj, printcharfun, 1);
383: /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
384: PRINTFINISH;
385: set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
386: obj = Fbuffer_string ();
387: GCPRO1 (obj);
388: Ferase_buffer ();
389: set_buffer_internal (old);
390: UNGCPRO;
391: return obj;
392: }
393:
394: DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0,
395: "Output the printed representation of OBJECT, any Lisp object.\n\
396: No quoting characters are used; no delimiters are printed around\n\
397: the contents of strings.\n\
398: Output stream is STREAM, or value of standard-output (which see).")
399: (obj, printcharfun)
400: Lisp_Object obj, printcharfun;
401: {
402: struct buffer *old = current_buffer;
403: int old_point = -1;
404: int start_point;
405: Lisp_Object original;
406:
407: if (NULL (printcharfun))
408: printcharfun = Vstandard_output;
409: PRINTPREPARE;
410: print_depth = 0;
411: print (obj, printcharfun, 0);
412: PRINTFINISH;
413: return obj;
414: }
415:
416: DEFUN ("print", Fprint, Sprint, 1, 2, 0,
417: "Output the printed representation of OBJECT, with newlines around it.\n\
418: Quoting characters are printed when needed to make output that `read'\n\
419: can handle, whenever this is possible.\n\
420: Output stream is STREAM, or value of `standard-output' (which see).")
421: (obj, printcharfun)
422: Lisp_Object obj, printcharfun;
423: {
424: struct buffer *old = current_buffer;
425: int old_point = -1;
426: int start_point;
427: Lisp_Object original;
428: struct gcpro gcpro1;
429:
430: #ifdef MAX_PRINT_CHARS
431: print_chars = 0;
432: max_print = MAX_PRINT_CHARS;
433: #endif /* MAX_PRINT_CHARS */
434: if (NULL (printcharfun))
435: printcharfun = Vstandard_output;
436: GCPRO1 (obj);
437: PRINTPREPARE;
438: print_depth = 0;
439: PRINTCHAR ('\n');
440: print (obj, printcharfun, 1);
441: PRINTCHAR ('\n');
442: PRINTFINISH;
443: #ifdef MAX_PRINT_CHARS
444: max_print = 0;
445: print_chars = 0;
446: #endif /* MAX_PRINT_CHARS */
447: UNGCPRO;
448: return obj;
449: }
450:
451: static void
452: print (obj, printcharfun, escapeflag)
453: #ifndef RTPC_REGISTER_BUG
454: register Lisp_Object obj;
455: #else
456: Lisp_Object obj;
457: #endif
458: register Lisp_Object printcharfun;
459: int escapeflag;
460: {
461: char buf[30];
462:
463: QUIT;
464:
465: print_depth++;
466: if (print_depth > 200)
467: error ("Apparently circular structure being printed");
468: #ifdef MAX_PRINT_CHARS
469: if (max_print && print_chars > max_print)
470: {
471: PRINTCHAR ('\n');
472: print_chars = 0;
473: }
474: #endif /* MAX_PRINT_CHARS */
475:
476: #ifdef SWITCH_ENUM_BUG
477: switch ((int) XTYPE (obj))
478: #else
479: switch (XTYPE (obj))
480: #endif
481: {
482: default:
483: /* We're in trouble if this happens!
484: Probably should just abort () */
485: strout ("#<EMACS BUG: INVALID DATATYPE ", -1, printcharfun);
486: sprintf (buf, "(#o%3o)", (int) XTYPE (obj));
487: strout (buf, -1, printcharfun);
488: strout (" Save your buffers immediately and please report this bug>",
489: -1, printcharfun);
490: break;
491:
492: case Lisp_Int:
493: sprintf (buf, "%d", XINT (obj));
494: strout (buf, -1, printcharfun);
495: break;
496:
497: case Lisp_String:
498: if (!escapeflag)
499: strout (XSTRING (obj)->data, XSTRING (obj)->size, printcharfun);
500: else
501: {
502: register int i;
503: register unsigned char *p = XSTRING (obj)->data;
504: register unsigned char c;
505:
506: PRINTCHAR ('\"');
507: for (i = XSTRING (obj)->size; i > 0; i--)
508: {
509: QUIT;
510: c = *p++;
511: if (c == '\n' && print_escape_newlines)
512: {
513: PRINTCHAR ('\\');
514: PRINTCHAR ('n');
515: }
516: else
517: {
518: if (c == '\"' || c == '\\')
519: PRINTCHAR ('\\');
520: PRINTCHAR (c);
521: }
522: }
523: PRINTCHAR ('\"');
524: }
525: break;
526:
527: case Lisp_Symbol:
528: {
529: register int confusing;
530: register unsigned char *p = XSYMBOL (obj)->name->data;
531: register unsigned char *end = p + XSYMBOL (obj)->name->size;
532: register unsigned char c;
533:
534: if (p != end && (*p == '-' || *p == '+')) p++;
535: if (p == end)
536: confusing = 0;
537: else
538: {
539: while (p != end && *p >= '0' && *p <= '9')
540: p++;
541: confusing = (end == p);
542: }
543:
544: p = XSYMBOL (obj)->name->data;
545: while (p != end)
546: {
547: QUIT;
548: c = *p++;
549: if (escapeflag)
550: {
551: if (c == '\"' || c == '\\' || c == '\'' || c == ';' || c == '#' ||
552: c == '(' || c == ')' || c == ',' || c =='.' || c == '`' ||
553: c == '[' || c == ']' || c == '?' || c <= 040 || confusing)
554: PRINTCHAR ('\\'), confusing = 0;
555: }
556: PRINTCHAR (c);
557: }
558: }
559: break;
560:
561: case Lisp_Cons:
562: PRINTCHAR ('(');
563: {
564: register int i = 0;
565: register int max = 0;
566:
567: if (XTYPE (Vprint_length) == Lisp_Int)
568: max = XINT (Vprint_length);
569: while (CONSP (obj))
570: {
571: if (i++)
572: PRINTCHAR (' ');
573: if (max && i > max)
574: {
575: strout ("...", 3, printcharfun);
576: break;
577: }
578: print (Fcar (obj), printcharfun, escapeflag);
579: obj = Fcdr (obj);
580: }
581: }
582: if (!NULL (obj) && !CONSP (obj))
583: {
584: strout (" . ", 3, printcharfun);
585: print (obj, printcharfun, escapeflag);
586: }
587: PRINTCHAR (')');
588: break;
589:
590: case Lisp_Vector:
591: PRINTCHAR ('[');
592: {
593: register int i;
594: register Lisp_Object tem;
595: for (i = 0; i < XVECTOR (obj)->size; i++)
596: {
597: if (i) PRINTCHAR (' ');
598: tem = XVECTOR (obj)->contents[i];
599: print (tem, printcharfun, escapeflag);
600: }
601: }
602: PRINTCHAR (']');
603: break;
604:
605: #ifndef standalone
606: case Lisp_Buffer:
607: if (NULL (XBUFFER (obj)->name))
608: strout ("#<killed buffer>", -1, printcharfun);
609: else if (escapeflag)
610: {
611: strout ("#<buffer ", -1, printcharfun);
612: strout (XSTRING (XBUFFER (obj)->name)->data, -1, printcharfun);
613: PRINTCHAR ('>');
614: }
615: else
616: strout (XSTRING (XBUFFER (obj)->name)->data, -1, printcharfun);
617: break;
618:
619: case Lisp_Process:
620: if (escapeflag)
621: {
622: strout ("#<process ", -1, printcharfun);
623: strout (XSTRING (XPROCESS (obj)->name)->data, -1, printcharfun);
624: PRINTCHAR ('>');
625: }
626: else
627: strout (XSTRING (XPROCESS (obj)->name)->data, -1, printcharfun);
628: break;
629:
630: case Lisp_Window:
631: strout ("#<window ", -1, printcharfun);
632: sprintf (buf, "%d", XFASTINT (XWINDOW (obj)->sequence_number));
633: strout (buf, -1, printcharfun);
634: if (!NULL (XWINDOW (obj)->buffer))
635: {
636: unsigned char *p = XSTRING (XBUFFER (XWINDOW (obj)->buffer)->name)->data;
637: strout (" on ", -1, printcharfun);
638: strout (p, -1, printcharfun);
639: }
640: PRINTCHAR ('>');
641: break;
642:
643: case Lisp_Window_Configuration:
644: strout ("#<window-configuration>", -1, printcharfun);
645: break;
646:
647: case Lisp_Marker:
648: strout ("#<marker ", -1, printcharfun);
649: if (!(XMARKER (obj)->buffer))
650: strout ("in no buffer", -1, printcharfun);
651: else
652: {
653: sprintf (buf, "at %d", marker_position (obj));
654: strout (buf, -1, printcharfun);
655: strout (" in ", -1, printcharfun);
656: strout (XSTRING (XMARKER (obj)->buffer->name)->data, -1, printcharfun);
657: }
658: PRINTCHAR ('>');
659: break;
660: #endif /* standalone */
661:
662: case Lisp_Subr:
663: strout ("#<subr ", -1, printcharfun);
664: strout (XSUBR (obj)->symbol_name, -1, printcharfun);
665: PRINTCHAR ('>');
666: break;
667: }
668:
669: print_depth--;
670: }
671:
672: void
673: syms_of_print ()
674: {
675: DEFVAR_LISP ("standard-output", &Vstandard_output,
676: "Function print uses by default for outputting a character.\n\
677: This may be any function of one argument.\n\
678: It may also be a buffer (output is inserted before point)\n\
679: or a marker (output is inserted and the marker is advanced)\n\
680: or the symbol t (output appears in the minibuffer line).");
681: Vstandard_output = Qt;
682: Qstandard_output = intern ("standard-output");
683: staticpro (&Qstandard_output);
684:
685: DEFVAR_LISP ("print-length", &Vprint_length,
686: "Maximum length of list to print before abbreviating.\
687: `nil' means no limit.");
688: Vprint_length = Qnil;
689:
690: DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines,
691: "Non-nil means print newlines in strings as backslash-n.");
692: print_escape_newlines = 0;
693:
694: /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
695: staticpro (&Vprin1_to_string_buffer);
696:
697: defsubr (&Sprin1);
698: defsubr (&Sprin1_to_string);
699: defsubr (&Sprinc);
700: defsubr (&Sprint);
701: defsubr (&Sterpri);
702: defsubr (&Swrite_char);
703: #ifndef standalone
704: defsubr (&Swith_output_to_temp_buffer);
705: #endif /* not standalone */
706: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.