Mercurial > hg > xemacs-beta

comparison src/print.c @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents c0965ff3b039
children 4be1180a9e89
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
586 print_internal (obj, the_stream, 1); 586 print_internal (obj, the_stream, 1);
587 write_char_internal ("\n", the_stream); 587 write_char_internal ("\n", the_stream);
588 print_finish (the_stream); 588 print_finish (the_stream);
589 UNGCPRO; 589 UNGCPRO;
590 return obj; 590 return obj;
591 }
592
593 # include "emacsfns.h"
594 static void print_error_message (Lisp_Object data, Lisp_Object stream);
595 /* Synched with Emacs 19.34 */
596 DEFUN ("error-message-string", Ferror_message_string, 1, 1, 0, /*
597 Convert an error value (ERROR-SYMBOL . DATA) to an error message.
598 */
599 (obj))
600 {
601 struct buffer *old = XBUFFER(Fcurrent_buffer());
602 Lisp_Object original, printcharfun, value;
603 struct gcpro gcpro1;
604
605 print_error_message (obj, Vprin1_to_string_buffer);
606
607 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
608 value = Fbuffer_substring (Fpoint_min(Fcurrent_buffer()),
609 Fpoint_max(Fcurrent_buffer()),
610 Fcurrent_buffer());
611
612 GCPRO1 (value);
613 Ferase_buffer (Fcurrent_buffer());
614 set_buffer_internal (old);
615 UNGCPRO;
616
617 return value;
618 }
619
620 /* Print an error message for the error DATA
621 onto Lisp output stream STREAM (suitable for the print functions). */
622
623 static void
624 print_error_message (Lisp_Object data, Lisp_Object stream)
625 {
626 Lisp_Object errname, errmsg, file_error, tail;
627 struct gcpro gcpro1;
628 int i;
629
630 errname = Fcar (data);
631
632 if (EQ (errname, Qerror))
633 {
634 data = Fcdr (data);
635 if (!CONSP (data)) data = Qnil;
636 errmsg = Fcar (data);
637 file_error = Qnil;
638 }
639 else
640 {
641 errmsg = Fget (errname, Qerror_message, Qnil);
642 file_error = Fmemq (Qfile_error,
643 Fget (errname, Qerror_conditions, Qnil));
644 }
645
646 /* Print an error message including the data items. */
647
648 tail = Fcdr_safe (data);
649 GCPRO1 (tail);
650
651 /* For file-error, make error message by concatenating
652 all the data items. They are all strings. */
653 if (!NILP (file_error) && !NILP (tail))
654 errmsg = XCONS (tail)->car, tail = XCONS (tail)->cdr;
655
656 if (STRINGP (errmsg))
657 Fprinc (errmsg, stream);
658 else
659 write_string_1 ((CONST Bufbyte *)"Peculiar error", 14, stream);
660
661 for (i = 0; CONSP (tail); tail = Fcdr (tail), i++)
662 {
663 write_string_1 ((CONST Bufbyte *)(i ? ", " : ": "), 2, stream);
664 if (!NILP (file_error))
665 Fprinc (Fcar (tail), stream);
666 else
667 Fprin1 (Fcar (tail), stream);
668 }
669 UNGCPRO;
670 } 591 }
671 592
672 #ifdef LISP_FLOAT_TYPE 593 #ifdef LISP_FLOAT_TYPE
673 594
674 Lisp_Object Vfloat_output_format; 595 Lisp_Object Vfloat_output_format;
851 switch (XTYPE (obj)) 772 switch (XTYPE (obj))
852 { 773 {
853 case Lisp_Int: 774 case Lisp_Int:
854 { 775 {
855 sprintf (buf, "%d", XINT (obj)); 776 sprintf (buf, "%d", XINT (obj));
777 write_c_string (buf, printcharfun);
778 break;
779 }
780
781 case Lisp_Char:
782 {
783 /* God intended that this be #\..., you know. */
784 Emchar ch = XCHAR (obj);
785 write_c_string ("?", printcharfun);
786 if (ch == '\n')
787 strcpy (buf, "\\n");
788 else if (ch == '\r')
789 strcpy (buf, "\\r");
790 else if (ch == '\t')
791 strcpy (buf, "\\t");
792 else if (ch < 32)
793 sprintf (buf, "\\^%c", ch + 64);
794 else if (ch == 127)
795 strcpy (buf, "\\^?");
796 else if (ch >= 128 && ch < 160)
797 {
798 Bytecount i;
799 strcpy (buf, "\\^");
800 i = set_charptr_emchar ((unsigned char *) (buf + 2), ch + 64);
801 buf[2+i] = '\0';
802 }
803 else if (ch < 127
804 && !isdigit (ch)
805 && !isalpha (ch)
806 && ch != '^') /* must not backslash this or it will
807 be interpreted as the start of a
808 control char */
809 sprintf (buf, "\\%c", ch);
810 else
811 {
812 Bytecount i;
813 i = set_charptr_emchar ((unsigned char *) buf, ch);
814 buf[i] = '\0';
815 }
856 write_c_string (buf, printcharfun); 816 write_c_string (buf, printcharfun);
857 break; 817 break;
858 } 818 }
859 819
860 case Lisp_String: 820 case Lisp_String:
1474 defsymbol (&Qprint_string_length, "print-string-length"); 1434 defsymbol (&Qprint_string_length, "print-string-length");
1475 DEFSUBR (Fprin1); 1435 DEFSUBR (Fprin1);
1476 DEFSUBR (Fprin1_to_string); 1436 DEFSUBR (Fprin1_to_string);
1477 DEFSUBR (Fprinc); 1437 DEFSUBR (Fprinc);
1478 DEFSUBR (Fprint); 1438 DEFSUBR (Fprint);
1479 DEFSUBR (Ferror_message_string);
1480 DEFSUBR (Fterpri); 1439 DEFSUBR (Fterpri);
1481 DEFSUBR (Fwrite_char); 1440 DEFSUBR (Fwrite_char);
1482 DEFSUBR (Falternate_debugging_output); 1441 DEFSUBR (Falternate_debugging_output);
1483 defsymbol (&Qalternate_debugging_output, "alternate-debugging-output"); 1442 defsymbol (&Qalternate_debugging_output, "alternate-debugging-output");
1484 DEFSUBR (Fexternal_debugging_output); 1443 DEFSUBR (Fexternal_debugging_output);
1573 If non-nil, then uninterned symbols will be printed specially. 1532 If non-nil, then uninterned symbols will be printed specially.
1574 Uninterned symbols are those which are not present in `obarray', that is, 1533 Uninterned symbols are those which are not present in `obarray', that is,
1575 those which were made with `make-symbol' or by calling `intern' with a 1534 those which were made with `make-symbol' or by calling `intern' with a
1576 second argument. 1535 second argument.
1577 1536
1578 When print-gensym is true, such symbols will be preceded by \"#:\", which 1537 When print-gensym is true, such symbols will be preceeded by \"#:\", which
1579 causes the reader to create a new symbol instead of interning and returning 1538 causes the reader to create a new symbol instead of interning and returning
1580 an existing one. Beware: the #: syntax creates a new symbol each time it is 1539 an existing one. Beware: the #: syntax creates a new symbol each time it is
1581 seen, so if you print an object which contains two pointers to the same 1540 seen, so if you print an object which contains two pointers to the same
1582 uninterned symbol, `read' will not duplicate that structure. 1541 uninterned symbol, `read' will not duplicate that structure.
1583 1542