Mercurial > hg > xemacs-beta

comparison src/print.c @ 171:929b76928fce r20-3b12

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b12
author cvs
date Mon, 13 Aug 2007 09:47:52 +0200
parents 85ec50267440
children 8eaf7971accc
comparison
equal deleted inserted replaced
170:98a42ee61975 171:929b76928fce
81 int print_readably; 81 int print_readably;
82 int print_gensym; 82 int print_gensym;
83 83
84 Lisp_Object Qprint_escape_newlines; 84 Lisp_Object Qprint_escape_newlines;
85 Lisp_Object Qprint_readably; 85 Lisp_Object Qprint_readably;
86
87 Lisp_Object Qdisplay_error;
88 Lisp_Object Qprint_message_label;
86 89
87 /* Force immediate output of all printed data. Used for debugging. */ 90 /* Force immediate output of all printed data. Used for debugging. */
88 int print_unbuffered; 91 int print_unbuffered;
89 92
90 FILE *termscript; /* Stdio stream being used for copy of all output. */ 93 FILE *termscript; /* Stdio stream being used for copy of all output. */
591 UNGCPRO; 594 UNGCPRO;
592 return obj; 595 return obj;
593 } 596 }
594 597
595 #include "emacsfns.h" 598 #include "emacsfns.h"
596 /* Synched with Emacs 19.34 */ 599
600 /* Synched with Emacs 19.34 -- underlying implementation (incarnated
601 in print_error_message) is completely divergent, though. */
597 DEFUN ("error-message-string", Ferror_message_string, 1, 1, 0, /* 602 DEFUN ("error-message-string", Ferror_message_string, 1, 1, 0, /*
598 Convert an error value (ERROR-SYMBOL . DATA) to an error message. 603 Convert an error value (ERROR-SYMBOL . DATA) to an error message.
599 */ 604 */
600 (data)) 605 (data))
601 { 606 {
607 /* This function can GC */
602 struct buffer *pbuf; 608 struct buffer *pbuf;
603 Lisp_Object original, printcharfun, value; 609 Lisp_Object value;
604 struct gcpro gcpro1; 610 struct gcpro gcpro1;
605 611
606 print_error_message (data, Vprin1_to_string_buffer); 612 print_error_message (data, Vprin1_to_string_buffer);
607 613
608 pbuf = XBUFFER (Vprin1_to_string_buffer); 614 pbuf = XBUFFER (Vprin1_to_string_buffer);
614 UNGCPRO; 620 UNGCPRO;
615 621
616 return value; 622 return value;
617 } 623 }
618 624
619 /* Print an error message for the error DATA 625 /* Print an error message for the error DATA onto Lisp output stream
620 onto Lisp output stream STREAM (suitable for the print functions). */ 626 STREAM (suitable for the print functions).
621 627
622 static void print_error_message (Lisp_Object data, Lisp_Object stream) 628 This is a complete implementation of `display-error', which used to
623 { 629 be in Lisp (see prim/cmdloop.el). It was ported to C so we can use
624 Lisp_Object errname, errmsg, file_error, tail; 630 it in Ferror_message_string. Fdisplay_error and
631 Ferror_message_string are trivial wrappers to this function. */
632 static void
633 print_error_message (Lisp_Object error_object, Lisp_Object stream)
634 {
635 /* This function can GC */
636 Lisp_Object type;
637 Lisp_Object method = Qnil;
638 Lisp_Object tail = Qnil;
625 struct gcpro gcpro1; 639 struct gcpro gcpro1;
626 int i; 640
627 641 GCPRO1 (tail);
628 errname = Fcar (data); 642
629 643 type = Fcar_safe (error_object);
630 if (EQ (errname, Qerror)) 644
631 { 645 if (! (CONSP (error_object) && SYMBOLP (type)
632 data = Fcdr (data); 646 && CONSP (Fget (type, Qerror_conditions, Qnil))))
633 if (!CONSP (data)) data = Qnil; 647 goto error_throw;
634 errmsg = Fcar (data); 648
635 file_error = Qnil; 649 tail = XCDR (error_object);
650 while (!NILP (tail))
651 {
652 if (CONSP (tail))
653 tail = XCDR (tail);
654 else
655 goto error_throw;
656 }
657 tail = Fget (type, Qerror_conditions, Qnil);
658 while (!NILP (tail))
659 {
660 if (!(CONSP (tail) && SYMBOLP (XCAR (tail))))
661 goto error_throw;
662 else if (!NILP (Fget (XCAR (tail), Qdisplay_error, Qnil)))
663 {
664 method = Fget (XCAR (tail), Qdisplay_error, Qnil);
665 goto error_throw;
666 }
667 else
668 tail = XCDR (tail);
669 }
670 /* Default method */
671 {
672 int first = 1;
673 Lisp_Object printcharfun = canonicalize_printcharfun (stream);
674 int speccount = specpdl_depth ();
675
676 specbind (Qprint_message_label, Qerror);
677 tail = Fcdr (error_object);
678 if (EQ (type, Qerror))
679 {
680 Fprinc (Fcar (tail), stream);
681 tail = Fcdr (tail);
682 }
683 else
684 {
685 Lisp_Object errmsg = Fget (type, Qerror_message, Qnil);
686 if (NILP (errmsg))
687 Fprinc (type, stream);
688 else
689 Fprinc (errmsg, stream);
690 }
691 while (!NILP (tail))
692 {
693 write_c_string (first ? ": " : ", ", printcharfun);
694 Fprin1 (Fcar (tail), stream);
695 tail = Fcdr (tail);
696 first = 0;
697 }
698 unbind_to (speccount, Qnil);
699 UNGCPRO;
700 return;
701 /* Unreached */
702 }
703
704 error_throw:
705 UNGCPRO;
706 if (NILP (method))
707 {
708 write_c_string ("Peculiar error ",
709 canonicalize_printcharfun (stream));
710 Fprin1 (error_object, stream);
711 return;
636 } 712 }
637 else 713 else
638 { 714 {
639 errmsg = Fget (errname, Qerror_message, Qnil); 715 call2 (method, error_object, stream);
640 file_error = Fmemq (Qfile_error, 716 }
641 Fget (errname, Qerror_conditions, Qnil)); 717 }
642 } 718
643 719 DEFUN ("display-error", Fdisplay_error, 2, 2, 0, /*
644 /* Print an error message including the data items. */ 720 Display an error message for ERROR-OBJECT to STREAM.
645 721 */
646 tail = Fcdr_safe (data); 722 (error_object, stream))
647 GCPRO1 (tail); 723 {
648 724 /* This function can GC */
649 /* For file-error, make error message by concatenating 725 print_error_message (error_object, stream);
650 all the data items. They are all strings. */ 726 return Qnil;
651 if (!NILP (file_error) && !NILP (tail)) 727 }
652 errmsg = XCONS (tail)->car, tail = XCONS (tail)->cdr; 728
653
654 if (STRINGP (errmsg))
655 Fprinc (errmsg, stream);
656 else
657 write_string_1 ((CONST Bufbyte *)"Peculiar error", 14, stream);
658
659 for (i = 0; CONSP (tail); tail = Fcdr (tail), i++)
660 {
661 write_string_1 ((CONST Bufbyte *)(i ? ", " : ": "), 2, stream);
662 if (!NILP (file_error))
663 Fprinc (Fcar (tail), stream);
664 else
665 Fprin1 (Fcar (tail), stream);
666 }
667 UNGCPRO;
668 }
669 729
670 #ifdef LISP_FLOAT_TYPE 730 #ifdef LISP_FLOAT_TYPE
671 731
672 Lisp_Object Vfloat_output_format; 732 Lisp_Object Vfloat_output_format;
673 Lisp_Object Qfloat_output_format; 733 Lisp_Object Qfloat_output_format;
1507 #endif 1567 #endif
1508 1568
1509 defsymbol (&Qprint_length, "print-length"); 1569 defsymbol (&Qprint_length, "print-length");
1510 1570
1511 defsymbol (&Qprint_string_length, "print-string-length"); 1571 defsymbol (&Qprint_string_length, "print-string-length");
1572
1573 defsymbol (&Qdisplay_error, "display-error");
1574 defsymbol (&Qprint_message_label, "print-message-label");
1575
1512 DEFSUBR (Fprin1); 1576 DEFSUBR (Fprin1);
1513 DEFSUBR (Fprin1_to_string); 1577 DEFSUBR (Fprin1_to_string);
1514 DEFSUBR (Fprinc); 1578 DEFSUBR (Fprinc);
1515 DEFSUBR (Fprint); 1579 DEFSUBR (Fprint);
1516 DEFSUBR (Ferror_message_string); 1580 DEFSUBR (Ferror_message_string);
1581 DEFSUBR (Fdisplay_error);
1517 DEFSUBR (Fterpri); 1582 DEFSUBR (Fterpri);
1518 DEFSUBR (Fwrite_char); 1583 DEFSUBR (Fwrite_char);
1519 DEFSUBR (Falternate_debugging_output); 1584 DEFSUBR (Falternate_debugging_output);
1520 defsymbol (&Qalternate_debugging_output, "alternate-debugging-output"); 1585 defsymbol (&Qalternate_debugging_output, "alternate-debugging-output");
1521 DEFSUBR (Fexternal_debugging_output); 1586 DEFSUBR (Fexternal_debugging_output);