print.c

Functions

DEFUN             X
internal_with_output_to_temp_bufferX
syms_of_print     X
temp_output_buffer_setupX
write_string      X
write_string_1    X

Variables

Qstandard_output  X
Vprin1_to_string_bufferX
Vprint_length     X
Vstandard_output  X
print_depth       X

Macros

PRINTCHAR         X
PRINTFINISH       X
PRINTPREPARE      X

   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: }