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