![[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] / 43BSD / contrib / emacs / src|
Return to print.c CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / src |
1.1 root 1: /* Lisp object printing and output streams.
2: Copyright (C) 1985 Richard M. Stallman.
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 newline before next minibuffer message.
44: Defined in xdisp.c */
45:
46: extern int noninteractive_need_newline;
47:
48: /* Low level output routines for charaters and strings */
49:
50: /* Lisp functions to do output using a stream
51: must have the stream in a variable called printcharfun
52: and must start with PRINTPREPARE and end with PRINTFINISH.
53: Use PRINTCHAR to output one character,
54: or call strout to output a block of characters.
55: Also, each one must have the declarations
56: struct buffer *old = bf_cur;
57: int old_point = -1, start_point;
58: Lisp_Object original;
59: */
60:
61: #define PRINTPREPARE \
62: original = printcharfun; \
63: if (NULL (printcharfun)) printcharfun = Qt; \
64: if (XTYPE (printcharfun) == Lisp_Buffer) \
65: { if (XBUFFER (printcharfun) != bf_cur) SetBfp (XBUFFER (printcharfun)); \
66: printcharfun = Qnil;}\
67: if (XTYPE (printcharfun) == Lisp_Marker) \
68: { if (XMARKER (original)->buffer != bf_cur) \
69: SetBfp (XMARKER (original)->buffer); \
70: old_point = point; \
71: SetPoint (marker_position (printcharfun)); \
72: start_point = point; \
73: printcharfun = Qnil;}
74:
75: #define PRINTFINISH \
76: if (XTYPE (original) == Lisp_Marker) \
77: Fset_marker (original, make_number (point), Qnil); \
78: if (old_point >= 0) \
79: SetPoint ((old_point >= start_point ? point - start_point : 0) + old_point); \
80: if (old != bf_cur) \
81: SetBfp (old)
82:
83: #define PRINTCHAR(ch) printchar (ch, printcharfun)
84:
85: /* Buffer for output destined for minibuffer */
86: static char printbuf[MScreenWidth + 1];
87: /* Index of first unused element of above */
88: static int printbufidx;
89:
90: static void
91: printchar (ch, fun)
92: unsigned char ch;
93: Lisp_Object fun;
94: {
95: Lisp_Object ch1;
96:
97: #ifndef standalone
98: if (EQ (fun, Qnil))
99: {
100: QUIT;
101: InsCStr (&ch, 1);
102: return;
103: }
104: if (EQ (fun, Qt))
105: {
106: if (noninteractive)
107: {
108: putchar (ch);
109: noninteractive_need_newline = 1;
110: return;
111: }
112: if (minibuf_message != printbuf)
113: minibuf_message = printbuf, printbufidx = 0;
114: if (printbufidx < sizeof printbuf - 1)
115: printbuf[printbufidx++] = ch;
116: printbuf[printbufidx] = 0;
117: return;
118: }
119: #endif /* not standalone */
120:
121: XFASTINT (ch1) = ch;
122: call1 (fun, ch1);
123: }
124:
125: static void
126: strout (ptr, size, printcharfun)
127: char *ptr;
128: int size;
129: Lisp_Object printcharfun;
130: {
131: int i = 0;
132:
133: if (EQ (printcharfun, Qnil))
134: {
135: InsCStr (ptr, size >= 0 ? size : strlen (ptr));
136: return;
137: }
138: if (EQ (printcharfun, Qt))
139: {
140: i = size >= 0 ? size : strlen (ptr);
141: if (noninteractive)
142: {
143: fwrite (ptr, 1, i, stdout);
144: noninteractive_need_newline = 1;
145: return;
146: }
147: if (minibuf_message != printbuf)
148: minibuf_message = printbuf, printbufidx = 0;
149: if (i > sizeof printbuf - printbufidx - 1)
150: i = sizeof printbuf - printbufidx - 1;
151: bcopy (ptr, &printbuf[printbufidx], i);
152: printbufidx += i;
153: printbuf[printbufidx] = 0;
154: return;
155: }
156: if (size >= 0)
157: while (i < size)
158: PRINTCHAR (ptr[i++]);
159: else
160: while (ptr[i])
161: PRINTCHAR (ptr[i++]);
162: }
163:
164: DEFUN ("write-char", Fwrite_char, Swrite_char, 1, 2, 0,
165: "Output character CHAR to stream STREAM.\n\
166: STREAM defaults to the value of standard-output (which see).")
167: (ch, printcharfun)
168: Lisp_Object ch, printcharfun;
169: {
170: struct buffer *old = bf_cur;
171: int old_point = -1;
172: int start_point;
173: Lisp_Object original;
174:
175: CHECK_NUMBER (ch, 0);
176: PRINTPREPARE;
177: PRINTCHAR (XINT (ch));
178: PRINTFINISH;
179: return ch;
180: }
181:
182: write_string (data, size)
183: char *data;
184: int size;
185: {
186: struct buffer *old = bf_cur;
187: Lisp_Object printcharfun;
188: int old_point = -1;
189: int start_point;
190: Lisp_Object original;
191:
192: printcharfun = Vstandard_output;
193:
194: PRINTPREPARE;
195: strout (data, size, printcharfun);
196: PRINTFINISH;
197: }
198:
199: write_string_1 (data, size, printcharfun)
200: char *data;
201: int size;
202: Lisp_Object printcharfun;
203: {
204: struct buffer *old = bf_cur;
205: int old_point = -1;
206: int start_point;
207: Lisp_Object original;
208:
209: PRINTPREPARE;
210: strout (data, size, printcharfun);
211: PRINTFINISH;
212: }
213:
214:
215: #ifndef standalone
216:
217: temp_output_buffer_setup (bufname)
218: char *bufname;
219: {
220: register struct buffer *old = bf_cur;
221: register Lisp_Object buf;
222:
223: Fset_buffer (Fget_buffer_create (build_string (bufname)));
224:
225: bf_cur->read_only = Qnil;
226: Ferase_buffer ();
227:
228: XSET (buf, Lisp_Buffer, bf_cur);
229: specbind (Qstandard_output, buf);
230:
231: SetBfp (old);
232: }
233:
234: Lisp_Object
235: internal_with_output_to_temp_buffer (bufname, function, args)
236: char *bufname;
237: Lisp_Object (*function) ();
238: Lisp_Object args;
239: {
240: int count = specpdl_ptr - specpdl;
241: Lisp_Object buf, val;
242:
243: temp_output_buffer_setup (bufname);
244: buf = Vstandard_output;
245:
246: val = (*function) (args);
247:
248: temp_output_buffer_show (buf);
249:
250: unbind_to (count);
251: return val;
252: }
253:
254: DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer, Swith_output_to_temp_buffer,
255: 1, UNEVALLED, 0,
256: "Binding standard-output to buffer named BUFNAME, execute BODY then display the buffer.\n\
257: The buffer is cleared out initially, and marked as unmodified when done.\n\
258: All output done by BODY is inserted in that buffer by default.\n\
259: It is displayed in another window, but not selected.\n\
260: The value of the last form in BODY is returned.")
261: (args)
262: Lisp_Object args;
263: {
264: struct gcpro gcpro1;
265: Lisp_Object name;
266: int count = specpdl_ptr - specpdl;
267: Lisp_Object buf, val;
268:
269: GCPRO1(args);
270: name = Feval (Fcar (args));
271: UNGCPRO;
272:
273: temp_output_buffer_setup (XSTRING (name)->data);
274: buf = Vstandard_output;
275:
276: val = Fprogn (args);
277:
278: temp_output_buffer_show (buf);
279:
280: unbind_to (count);
281: return val;
282: }
283: #endif /* not standalone */
284:
285: static void print ();
286:
287: DEFUN ("terpri", Fterpri, Sterpri, 0, 1, 0,
288: "Output a newline to STREAM (or value of standard-output).")
289: (printcharfun)
290: Lisp_Object printcharfun;
291: {
292: struct buffer *old = bf_cur;
293: int old_point = -1;
294: int start_point;
295: Lisp_Object original;
296:
297: if (NULL (printcharfun))
298: printcharfun = Vstandard_output;
299: PRINTPREPARE;
300: PRINTCHAR ('\n');
301: PRINTFINISH;
302: return Qt;
303: }
304:
305: DEFUN ("prin1", Fprin1, Sprin1, 1, 2, 0,
306: "Output the printed representation of OBJECT, any Lisp object.\n\
307: Quoting characters are used, to make output that read can handle\n\
308: whenever this is possible.\n\
309: Output stream is STREAM, or value of standard-output (which see).")
310: (obj, printcharfun)
311: Lisp_Object obj, printcharfun;
312: {
313: struct buffer *old = bf_cur;
314: int old_point = -1;
315: int start_point;
316: Lisp_Object original;
317:
318: if (NULL (printcharfun))
319: printcharfun = Vstandard_output;
320: PRINTPREPARE;
321: print_depth = 0;
322: print (obj, printcharfun, 1);
323: PRINTFINISH;
324: return obj;
325: }
326:
327: /* a buffer which is used to hold output being built by prin1-to-string */
328: Lisp_Object Vprin1_to_string_buffer;
329:
330: DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 1, 0,
331: "Return a string containing the printed representation of OBJECT,\n\
332: any Lisp object. Quoting characters are used, to make output that read\n\
333: can handle whenever this is possible.")
334: (obj)
335: Lisp_Object obj;
336: {
337: struct buffer *old = bf_cur;
338: int old_point = -1;
339: int start_point;
340: Lisp_Object original, printcharfun;
341:
342: printcharfun = Vprin1_to_string_buffer;
343: PRINTPREPARE;
344: print_depth = 0;
345: print (obj, printcharfun, 1);
346: /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
347: PRINTFINISH;
348: SetBfp (XBUFFER (Vprin1_to_string_buffer));
349: obj = Fbuffer_string ();
350: Ferase_buffer ();
351: SetBfp (old);
352: return obj;
353: }
354:
355: DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0,
356: "Output the printed representation of OBJECT, any Lisp object.\n\
357: No quoting characters are used; no delimiters are printed around\n\
358: the contents of strings.\n\
359: Output stream is STREAM, or value of standard-output (which see).")
360: (obj, printcharfun)
361: Lisp_Object obj, printcharfun;
362: {
363: struct buffer *old = bf_cur;
364: int old_point = -1;
365: int start_point;
366: Lisp_Object original;
367:
368: if (NULL (printcharfun))
369: printcharfun = Vstandard_output;
370: PRINTPREPARE;
371: print_depth = 0;
372: print (obj, printcharfun, 0);
373: PRINTFINISH;
374: return obj;
375: }
376:
377: DEFUN ("print", Fprint, Sprint, 1, 2, 0,
378: "Output the printed representation of OBJECT, with newline before and\n\
379: space after. Quoting characters are used, to make output that read\n\
380: can handle whenever this is possible.\n\
381: Output stream is STREAM, or value of standard-output (which see).")
382: (obj, printcharfun)
383: Lisp_Object obj, printcharfun;
384: {
385: struct buffer *old = bf_cur;
386: int old_point = -1;
387: int start_point;
388: Lisp_Object original;
389:
390: if (NULL (printcharfun))
391: printcharfun = Vstandard_output;
392: PRINTPREPARE;
393: print_depth = 0;
394: PRINTCHAR ('\n');
395: print (obj, printcharfun, 1);
396: PRINTCHAR ('\n');
397: PRINTFINISH;
398: return obj;
399: }
400:
401: static void
402: print (obj, printcharfun, escapeflag)
403: register Lisp_Object obj;
404: Lisp_Object printcharfun;
405: int escapeflag;
406: {
407: char buf[30];
408:
409: QUIT;
410:
411: print_depth++;
412: if (print_depth > 200)
413: error ("Apparently circular structure being printed");
414:
415: #ifdef SWITCH_ENUM_BUG
416: switch ((int) XTYPE (obj))
417: #else
418: switch (XTYPE (obj))
419: #endif
420: {
421: case Lisp_Int:
422: sprintf (buf, "%d", XINT (obj));
423: strout (buf, -1, printcharfun);
424: break;
425:
426: case Lisp_String:
427: if (!escapeflag)
428: strout (XSTRING (obj)->data, XSTRING (obj)->size, printcharfun);
429: else
430: {
431: register int i;
432: register unsigned char *p = XSTRING (obj)->data;
433: register unsigned char c;
434:
435: PRINTCHAR ('\"');
436: for (i = XSTRING (obj)->size; i > 0; i--)
437: {
438: QUIT;
439: c = *p++;
440: if (c == '\"' || c == '\\')
441: PRINTCHAR ('\\');
442: PRINTCHAR (c);
443: }
444: PRINTCHAR ('\"');
445: }
446: break;
447:
448: case Lisp_Symbol:
449: {
450: register int confusing;
451: register unsigned char *p = XSYMBOL (obj)->name->data;
452: register unsigned char *end = p + XSYMBOL (obj)->name->size;
453: register unsigned char c;
454:
455: if (p != end && (*p == '-' || *p == '+')) p++;
456: if (p == end)
457: confusing = 0;
458: else
459: {
460: while (p != end && *p >= '0' && *p <= '9')
461: p++;
462: confusing = (end == p);
463: }
464:
465: p = XSYMBOL (obj)->name->data;
466: while (p != end)
467: {
468: QUIT;
469: c = *p++;
470: if (escapeflag)
471: {
472: if (c == '\"' || c == '\\' || c == '\'' || c == ';' || c == '#' ||
473: c == '(' || c == ')' || c == ',' || c =='.' || c == '`' ||
474: c == '[' || c == ']' || c == '?' || c <= 040 || confusing)
475: PRINTCHAR ('\\'), confusing = 0;
476: }
477: PRINTCHAR (c);
478: }
479: }
480: break;
481:
482: case Lisp_Cons:
483: PRINTCHAR ('(');
484: {
485: register int i = 0;
486: register int max = 0;
487:
488: if (XTYPE (Vprint_length) == Lisp_Int)
489: max = XINT (Vprint_length);
490: while (LISTP (obj))
491: {
492: if (i++)
493: PRINTCHAR (' ');
494: if (max && i > max)
495: {
496: strout ("...", 3, printcharfun);
497: break;
498: }
499: print (Fcar (obj), printcharfun, escapeflag);
500: obj = Fcdr (obj);
501: }
502: }
503: if (!NULL (obj) && !LISTP (obj))
504: {
505: strout (" . ", 3, printcharfun);
506: print (obj, printcharfun, escapeflag);
507: }
508: PRINTCHAR (')');
509: break;
510:
511: case Lisp_Vector:
512: PRINTCHAR ('[');
513: {
514: register int i;
515: register Lisp_Object tem;
516: for (i = 0; i < XVECTOR (obj)->size; i++)
517: {
518: if (i) PRINTCHAR (' ');
519: tem = XVECTOR (obj)->contents[i];
520: print (tem, printcharfun, escapeflag);
521: }
522: }
523: PRINTCHAR (']');
524: break;
525:
526: #ifndef standalone
527: case Lisp_Buffer:
528: if (NULL (XBUFFER (obj)->name))
529: strout ("#<killed buffer>", -1, printcharfun);
530: else if (escapeflag)
531: {
532: strout ("#<buffer ", -1, printcharfun);
533: strout (XSTRING (XBUFFER (obj)->name)->data, -1, printcharfun);
534: PRINTCHAR ('>');
535: }
536: else
537: strout (XSTRING (XBUFFER (obj)->name)->data, -1, printcharfun);
538: break;
539:
540: case Lisp_Process:
541: if (escapeflag)
542: {
543: strout ("#<process ", -1, printcharfun);
544: strout (XSTRING (XPROCESS (obj)->name)->data, -1, printcharfun);
545: PRINTCHAR ('>');
546: }
547: else
548: strout (XSTRING (XPROCESS (obj)->name)->data, -1, printcharfun);
549: break;
550:
551: case Lisp_Window:
552: strout ("#<window ", -1, printcharfun);
553: sprintf (buf, "%d", XFASTINT (XWINDOW (obj)->sequence_number));
554: strout (buf, -1, printcharfun);
555: if (!NULL (XWINDOW (obj)->buffer))
556: {
557: strout (" on ", -1, printcharfun);
558: strout (XSTRING (XBUFFER (XWINDOW (obj)->buffer)->name)->data,
559: -1, printcharfun);
560: }
561: PRINTCHAR ('>');
562: break;
563:
564: case Lisp_Marker:
565: strout ("#<marker ", -1, printcharfun);
566: if (!(XMARKER (obj)->buffer))
567: strout ("in no buffer", -1, printcharfun);
568: else
569: {
570: sprintf (buf, "at %d", marker_position (obj));
571: strout (buf, -1, printcharfun);
572: strout (" in ", -1, printcharfun);
573: strout (XSTRING (XMARKER (obj)->buffer->name)->data, -1, printcharfun);
574: }
575: PRINTCHAR ('>');
576: break;
577: #endif /* standalone */
578:
579: case Lisp_Subr:
580: strout ("#<subr ", -1, printcharfun);
581: strout (XSUBR (obj)->symbol_name, -1, printcharfun);
582: PRINTCHAR ('>');
583: break;
584: }
585:
586: print_depth--;
587: }
588:
589: void
590: syms_of_print ()
591: {
592: DefLispVar ("standard-output", &Vstandard_output,
593: "Function print uses by default for outputting a character.\n\
594: This may be any function of one argument.\n\
595: It may also be a buffer (output is inserted before point)\n\
596: or a marker (output is inserted and the marker is advanced)\n\
597: or the symbol t (output appears in the minibuffer line).");
598: Vstandard_output = Qt;
599: Qstandard_output = intern ("standard-output");
600: staticpro (&Qstandard_output);
601:
602: DefLispVar ("print-length", &Vprint_length,
603: "Maximum length of list to print before abbreviating.\
604: `nil' means no limit.");
605: Vprint_length = Qnil;
606:
607: /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
608: staticpro (&Vprin1_to_string_buffer);
609:
610: defsubr (&Sprin1);
611: defsubr (&Sprin1_to_string);
612: defsubr (&Sprinc);
613: defsubr (&Sprint);
614: defsubr (&Sterpri);
615: defsubr (&Swrite_char);
616: #ifndef standalone
617: defsubr (&Swith_output_to_temp_buffer);
618: #endif /* not standalone */
619: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.